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       edfadis=0.0d0
 184       if (wdfa_dist.gt.0) call edfad(edfadis)
 185 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 186       edfator=0.0d0
 187       if (wdfa_tor.gt.0) call edfat(edfator)
 188 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 189       edfanei=0.0d0
 190       if (wdfa_nei.gt.0) call edfan(edfanei)
 191 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 192       edfabet=0.0d0
 193       if (wdfa_beta.gt.0) call edfab(edfabet)
 194 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 195 #else
 196       edfadis=0.0d0
 197       edfator=0.0d0
 198       edfanei=0.0d0
 199       edfabet=0.0d0
 200 #endif
 201
 202 #ifdef SPLITELE
 203       if (shield_mode.gt.0) then
 204       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 205      & +welec*fact(1)*ees
 206      & +fact(1)*wvdwpp*evdw1
 207      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 208      & +wstrain*ehpb
 209      & +wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 210      & +wcorr6*fact(5)*ecorr6
 211      & +wturn4*fact(3)*eello_turn4
 212      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 213      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 214      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 215      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 216      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 217      & +wdfa_beta*edfabet
 218       else
 219       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 220      & +wvdwpp*evdw1
 221      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 222      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 223      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 224      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 225      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 226      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 227      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 228      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 229      & +wdfa_beta*edfabet
 230       endif
 231 #else
 232       if (shield_mode.gt.0) then
 233       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 234      & +welec*fact(1)*(ees+evdw1)
 235      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 236      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 237      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 238      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 239      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 240      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 241      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 242      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 243      & +wdfa_beta*edfabet
 244       else
 245       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 246      & +welec*fact(1)*(ees+evdw1)
 247      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 248      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 249      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 250      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 251      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 252      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 253      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 254      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 255      & +wdfa_beta*edfabet
 256       endif
 257 #endif
 258       energia(0)=etot
 259       energia(1)=evdw
 260 #ifdef SCP14
 261       energia(2)=evdw2-evdw2_14
 262       energia(17)=evdw2_14
 263 #else
 264       energia(2)=evdw2
 265       energia(17)=0.0d0
 266 #endif
 267 #ifdef SPLITELE
 268       energia(3)=ees
 269       energia(16)=evdw1
 270 #else
 271       energia(3)=ees+evdw1
 272       energia(16)=0.0d0
 273 #endif
 274       energia(4)=ecorr
 275       energia(5)=ecorr5
 276       energia(6)=ecorr6
 277       energia(7)=eel_loc
 278       energia(8)=eello_turn3
 279       energia(9)=eello_turn4
 280       energia(10)=eturn6
 281       energia(11)=ebe
 282       energia(12)=escloc
 283       energia(13)=etors
 284       energia(14)=etors_d
 285       energia(15)=ehpb
 286       energia(18)=estr
 287       energia(19)=esccor
 288       energia(20)=edihcnstr
 289       energia(21)=evdw_t
 290       energia(22)=eliptran
 291       energia(24)=ethetacnstr
 292       energia(26)=esaxs_constr
 293       energia(27)=ehomology_constr
 294       energia(28)=edfadis
 295       energia(29)=edfator
 296       energia(30)=edfanei
 297       energia(31)=edfabet
 298 c detecting NaNQ
 299 #ifdef ISNAN
 300 #ifdef AIX
 301       if (isnan(etot).ne.0) energia(0)=1.0d+99
 302 #else
 303       if (isnan(etot)) energia(0)=1.0d+99
 304 #endif
 305 #else
 306       i=0
 307 #ifdef WINPGI
 308       idumm=proc_proc(etot,i)
 309 #else
 310       call proc_proc(etot,i)
 311 #endif
 312       if(i.eq.1)energia(0)=1.0d+99
 313 #endif
 314 #ifdef MPL
 315 c     endif
 316 #endif
 317 #ifdef DEBUG
 318       call enerprint(energia,fact)
 319 #endif
 320       if (calc_grad) then
 321 C
 322 C Sum up the components of the Cartesian gradient.
 323 C
 324 #ifdef SPLITELE
 325       do i=1,nct
 326         do j=1,3
 327       if (shield_mode.eq.0) then
 328           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 329      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 330      &                wbond*gradb(j,i)+
 331      &                wstrain*ghpbc(j,i)+
 332      &                wcorr*fact(3)*gradcorr(j,i)+
 333      &                wel_loc*fact(2)*gel_loc(j,i)+
 334      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 335      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 336      &                wcorr5*fact(4)*gradcorr5(j,i)+
 337      &                wcorr6*fact(5)*gradcorr6(j,i)+
 338      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 339      &                wsccor*fact(2)*gsccorc(j,i)
 340      &               +wliptran*gliptranc(j,i)+
 341      &                wdfa_dist*gdfad(j,i)+
 342      &                wdfa_tor*gdfat(j,i)+
 343      &                wdfa_nei*gdfan(j,i)+
 344      &                wdfa_beta*gdfab(j,i)
 345           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 346      &                  wbond*gradbx(j,i)+
 347      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 348      &                  wsccor*fact(2)*gsccorx(j,i)
 349      &                 +wliptran*gliptranx(j,i)
 350         else
 351           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 352      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 353      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 354      &                wbond*gradb(j,i)+
 355      &                wstrain*ghpbc(j,i)+
 356      &                wcorr*fact(3)*gradcorr(j,i)+
 357      &                wel_loc*fact(2)*gel_loc(j,i)+
 358      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 359      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 360      &                wcorr5*fact(4)*gradcorr5(j,i)+
 361      &                wcorr6*fact(5)*gradcorr6(j,i)+
 362      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 363      &                wsccor*fact(2)*gsccorc(j,i)
 364      &               +wliptran*gliptranc(j,i)
 365      &                 +welec*gshieldc(j,i)
 366      &                 +welec*gshieldc_loc(j,i)
 367      &                 +wcorr*gshieldc_ec(j,i)
 368      &                 +wcorr*gshieldc_loc_ec(j,i)
 369      &                 +wturn3*gshieldc_t3(j,i)
 370      &                 +wturn3*gshieldc_loc_t3(j,i)
 371      &                 +wturn4*gshieldc_t4(j,i)
 372      &                 +wturn4*gshieldc_loc_t4(j,i)
 373      &                 +wel_loc*gshieldc_ll(j,i)
 374      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 375      &                wdfa_dist*gdfad(j,i)+
 376      &                wdfa_tor*gdfat(j,i)+
 377      &                wdfa_nei*gdfan(j,i)+
 378      &                wdfa_beta*gdfab(j,i)
 379           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 380      &                 +fact(1)*wscp*gradx_scp(j,i)+
 381      &                  wbond*gradbx(j,i)+
 382      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 383      &                  wsccor*fact(2)*gsccorx(j,i)
 384      &                 +wliptran*gliptranx(j,i)
 385      &                 +welec*gshieldx(j,i)
 386      &                 +wcorr*gshieldx_ec(j,i)
 387      &                 +wturn3*gshieldx_t3(j,i)
 388      &                 +wturn4*gshieldx_t4(j,i)
 389      &                 +wel_loc*gshieldx_ll(j,i)
 390
 391
 392         endif
 393         enddo
 394 #else
 395       do i=1,nct
 396         do j=1,3
 397                 if (shield_mode.eq.0) then
 398           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 399      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 400      &                wbond*gradb(j,i)+
 401      &                wcorr*fact(3)*gradcorr(j,i)+
 402      &                wel_loc*fact(2)*gel_loc(j,i)+
 403      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 404      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 405      &                wcorr5*fact(4)*gradcorr5(j,i)+
 406      &                wcorr6*fact(5)*gradcorr6(j,i)+
 407      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 408      &                wsccor*fact(2)*gsccorc(j,i)
 409      &               +wliptran*gliptranc(j,i)+
 410      &                wdfa_dist*gdfad(j,i)+
 411      &                wdfa_tor*gdfat(j,i)+
 412      &                wdfa_nei*gdfan(j,i)+
 413      &                wdfa_beta*gdfab(j,i)
 414           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 415      &                  wbond*gradbx(j,i)+
 416      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 417      &                  wsccor*fact(1)*gsccorx(j,i)
 418      &                 +wliptran*gliptranx(j,i)
 419               else
 420           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 421      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 422      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 423      &                wbond*gradb(j,i)+
 424      &                wcorr*fact(3)*gradcorr(j,i)+
 425      &                wel_loc*fact(2)*gel_loc(j,i)+
 426      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 427      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 428      &                wcorr5*fact(4)*gradcorr5(j,i)+
 429      &                wcorr6*fact(5)*gradcorr6(j,i)+
 430      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 431      &                wsccor*fact(2)*gsccorc(j,i)
 432      &               +wliptran*gliptranc(j,i)
 433      &                 +welec*gshieldc(j,i)
 434      &                 +welec*gshieldc_loc(j,i)
 435      &                 +wcorr*gshieldc_ec(j,i)
 436      &                 +wcorr*gshieldc_loc_ec(j,i)
 437      &                 +wturn3*gshieldc_t3(j,i)
 438      &                 +wturn3*gshieldc_loc_t3(j,i)
 439      &                 +wturn4*gshieldc_t4(j,i)
 440      &                 +wturn4*gshieldc_loc_t4(j,i)
 441      &                 +wel_loc*gshieldc_ll(j,i)
 442      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 443      &                wdfa_dist*gdfad(j,i)+
 444      &                wdfa_tor*gdfat(j,i)+
 445      &                wdfa_nei*gdfan(j,i)+
 446      &                wdfa_beta*gdfab(j,i)
 447           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 448      &                  fact(1)*wscp*gradx_scp(j,i)+
 449      &                  wbond*gradbx(j,i)+
 450      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 451      &                  wsccor*fact(1)*gsccorx(j,i)
 452      &                 +wliptran*gliptranx(j,i)
 453      &                 +welec*gshieldx(j,i)
 454      &                 +wcorr*gshieldx_ec(j,i)
 455      &                 +wturn3*gshieldx_t3(j,i)
 456      &                 +wturn4*gshieldx_t4(j,i)
 457      &                 +wel_loc*gshieldx_ll(j,i)
 458          endif
 459         enddo
 460 #endif
 461       enddo
 462
 463
 464       do i=1,nres-3
 465         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 466      &   +wcorr5*fact(4)*g_corr5_loc(i)
 467      &   +wcorr6*fact(5)*g_corr6_loc(i)
 468      &   +wturn4*fact(3)*gel_loc_turn4(i)
 469      &   +wturn3*fact(2)*gel_loc_turn3(i)
 470      &   +wturn6*fact(5)*gel_loc_turn6(i)
 471      &   +wel_loc*fact(2)*gel_loc_loc(i)
 472 c     &   +wsccor*fact(1)*gsccor_loc(i)
 473 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 474       enddo
 475       endif
 476       if (dyn_ss) call dyn_set_nss
 477       return
 478       end
 479 C------------------------------------------------------------------------
 480       subroutine enerprint(energia,fact)
 481       implicit real*8 (a-h,o-z)
 482       include 'DIMENSIONS'
 483       include 'COMMON.IOUNITS'
 484       include 'COMMON.FFIELD'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CONTROL'
 487       double precision energia(0:max_ene),fact(6)
 488       etot=energia(0)
 489       evdw=energia(1)+fact(6)*energia(21)
 490 #ifdef SCP14
 491       evdw2=energia(2)+energia(17)
 492 #else
 493       evdw2=energia(2)
 494 #endif
 495       ees=energia(3)
 496 #ifdef SPLITELE
 497       evdw1=energia(16)
 498 #endif
 499       ecorr=energia(4)
 500       ecorr5=energia(5)
 501       ecorr6=energia(6)
 502       eel_loc=energia(7)
 503       eello_turn3=energia(8)
 504       eello_turn4=energia(9)
 505       eello_turn6=energia(10)
 506       ebe=energia(11)
 507       escloc=energia(12)
 508       etors=energia(13)
 509       etors_d=energia(14)
 510       ehpb=energia(15)
 511       esccor=energia(19)
 512       edihcnstr=energia(20)
 513       estr=energia(18)
 514       ethetacnstr=energia(24)
 515       eliptran=energia(22)
 516       esaxs=energia(26)
 517       ehomology_constr=energia(27)
 518 C     Bartek
 519       edfadis = energia(28)
 520       edfator = energia(29)
 521       edfanei = energia(30)
 522       edfabet = energia(31)
 523       Eafmforc=0.0d0
 524       etube=0.0d0
 525       Uconst=0.0d0
 526 #ifdef SPLITELE
 527       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 528      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 529      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 530 #ifdef FOURBODY
 531      &  ecorr,wcorr*fact(3),
 532      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 533 #endif
 534      &  eel_loc,
 535      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 536      &  eello_turn4,wturn4*fact(3),
 537 #ifdef FOURBODY
 538      &  eello_turn6,wturn6*fact(5),
 539 #endif
 540      &  esccor,wsccor*fact(1),edihcnstr,
 541      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 542      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 543      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 544      &  edfabet,wdfa_beta,
 545      &  etot
 546    10 format (/'Virtual-chain energies:'//
 547      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 548      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 549      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 550      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 551      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 552      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 553      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 554      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 555      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 556      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 557      & ' (SS bridges & dist. cnstr.)'/
 558 #ifdef FOURBODY
 559      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 560      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 561      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 562 #endif
 563      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 564      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 565      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 566 #ifdef FOURBODY
 567      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 568 #endif
 569      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 570      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 571      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 572      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 573      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 574      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 575      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 576      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 577      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 578      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 579      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 580      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 581      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 582      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 583      & 'ETOT=  ',1pE16.6,' (total)')
 584
 585 #else
 586       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 587      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 588      &  etors_d,wtor_d*fact(2),ehpb,
 589 #ifdef FOURBODY
 590      &  wstrain,ecorr,wcorr*fact(3),
 591      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 592 #endif
 593      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 594      &  eello_turn4,wturn4*fact(3),
 595 #ifdef FOURBODY
 596      &  eello_turn6,wturn6*fact(5),
 597 #endif
 598      &  esccor,wsccor*fact(1),edihcnstr,
 599      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 600      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 601      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 602      &  edfabet,wdfa_beta,
 603      &  etot
 604    10 format (/'Virtual-chain energies:'//
 605      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 606      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 607      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 608      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 609      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 610      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 611      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 612      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 613      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 614      & ' (SS bridges & dist. restr.)'/
 615 #ifdef FOURBODY
 616      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 617      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 618      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 619 #endif
 620      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 621      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 622      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 623 #ifdef FOURBODY
 624      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 625 #endif
 626      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 627      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 628      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 629      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 630      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 631      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 632      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 633      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 634      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 635      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 636      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 637      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 638      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 639      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 640      & 'ETOT=  ',1pE16.6,' (total)')
 641 #endif
 642       return
 643       end
 644 C-----------------------------------------------------------------------
 645       subroutine elj(evdw,evdw_t)
 646 C
 647 C This subroutine calculates the interaction energy of nonbonded side chains
 648 C assuming the LJ potential of interaction.
 649 C
 650       implicit real*8 (a-h,o-z)
 651       include 'DIMENSIONS'
 652       include "DIMENSIONS.COMPAR"
 653       parameter (accur=1.0d-10)
 654       include 'COMMON.GEO'
 655       include 'COMMON.VAR'
 656       include 'COMMON.LOCAL'
 657       include 'COMMON.CHAIN'
 658       include 'COMMON.DERIV'
 659       include 'COMMON.INTERACT'
 660       include 'COMMON.TORSION'
 661       include 'COMMON.SBRIDGE'
 662       include 'COMMON.NAMES'
 663       include 'COMMON.IOUNITS'
 664 #ifdef FOURBODY
 665       include 'COMMON.CONTACTS'
 666       include 'COMMON.CONTMAT'
 667 #endif
 668       dimension gg(3)
 669       integer icant
 670       external icant
 671 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 672 c ROZNICA z cluster
 673 c      do i=1,210
 674 c        do j=1,2
 675 c          eneps_temp(j,i)=0.0d0
 676 c        enddo
 677 c      enddo
 678 cROZNICA
 679
 680       evdw=0.0D0
 681       evdw_t=0.0d0
 682       do i=iatsc_s,iatsc_e
 683         itypi=iabs(itype(i))
 684         if (itypi.eq.ntyp1) cycle
 685         itypi1=iabs(itype(i+1))
 686         xi=c(1,nres+i)
 687         yi=c(2,nres+i)
 688         zi=c(3,nres+i)
 689         call to_box(xi,yi,zi)
 690 C Change 12/1/95
 691         num_conti=0
 692 C
 693 C Calculate SC interaction energy.
 694 C
 695         do iint=1,nint_gr(i)
 696 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 697 cd   &                  'iend=',iend(i,iint)
 698           do j=istart(i,iint),iend(i,iint)
 699             itypj=iabs(itype(j))
 700             if (itypj.eq.ntyp1) cycle
 701             xj=c(1,nres+j)-xi
 702             yj=c(2,nres+j)-yi
 703             zj=c(3,nres+j)-zi
 704             call to_box(xj,yj,zj)
 705             xj=boxshift(xj-xi,boxxsize)
 706             yj=boxshift(yj-yi,boxysize)
 707             zj=boxshift(zj-zi,boxzsize)
 708 C Change 12/1/95 to calculate four-body interactions
 709             rij=xj*xj+yj*yj+zj*zj
 710             rrij=1.0D0/rij
 711             sqrij=dsqrt(rij)
 712             sss1=sscale(sqrij)
 713             if (sss1.eq.0.0d0) cycle
 714             sssgrad1=sscagrad(sqrij)
 715 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 716             eps0ij=eps(itypi,itypj)
 717             fac=rrij**expon2
 718             e1=fac*fac*aa
 719             e2=fac*bb
 720             evdwij=e1+e2
 721             ij=icant(itypi,itypj)
 722 c ROZNICA z cluster
 723 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 724 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 725 c
 726
 727 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 728 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 729 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 730 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 731 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 732 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 733             if (bb.gt.0.0d0) then
 734               evdw=evdw+sss1*evdwij
 735             else
 736               evdw_t=evdw_t+sss1*evdwij
 737             endif
 738             if (calc_grad) then
 739 C
 740 C Calculate the components of the gradient in DC and X
 741 C
 742             fac=-rrij*(e1+evdwij)*sss1
 743      &          +evdwij*sssgrad1/sqrij/expon
 744             gg(1)=xj*fac
 745             gg(2)=yj*fac
 746             gg(3)=zj*fac
 747             do k=1,3
 748               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 749               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 750             enddo
 751             do k=i,j-1
 752               do l=1,3
 753                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 754               enddo
 755             enddo
 756             endif
 757 #ifdef FOURBODY
 758 C
 759 C 12/1/95, revised on 5/20/97
 760 C
 761 C Calculate the contact function. The ith column of the array JCONT will
 762 C contain the numbers of atoms that make contacts with the atom I (of numbers
 763 C greater than I). The arrays FACONT and GACONT will contain the values of
 764 C the contact function and its derivative.
 765 C
 766 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 767 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 768 C Uncomment next line, if the correlation interactions are contact function only
 769             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 770               rij=dsqrt(rij)
 771               sigij=sigma(itypi,itypj)
 772               r0ij=rs0(itypi,itypj)
 773 C
 774 C Check whether the SC's are not too far to make a contact.
 775 C
 776               rcut=1.5d0*r0ij
 777               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 778 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 779 C
 780               if (fcont.gt.0.0D0) then
 781 C If the SC-SC distance if close to sigma, apply spline.
 782 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 783 cAdam &             fcont1,fprimcont1)
 784 cAdam           fcont1=1.0d0-fcont1
 785 cAdam           if (fcont1.gt.0.0d0) then
 786 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 787 cAdam             fcont=fcont*fcont1
 788 cAdam           endif
 789 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 790 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 791 cga             do k=1,3
 792 cga               gg(k)=gg(k)*eps0ij
 793 cga             enddo
 794 cga             eps0ij=-evdwij*eps0ij
 795 C Uncomment for AL's type of SC correlation interactions.
 796 cadam           eps0ij=-evdwij
 797                 num_conti=num_conti+1
 798                 jcont(num_conti,i)=j
 799                 facont(num_conti,i)=fcont*eps0ij
 800                 fprimcont=eps0ij*fprimcont/rij
 801                 fcont=expon*fcont
 802 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 803 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 804 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 805 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 806                 gacont(1,num_conti,i)=-fprimcont*xj
 807                 gacont(2,num_conti,i)=-fprimcont*yj
 808                 gacont(3,num_conti,i)=-fprimcont*zj
 809 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 810 cd              write (iout,'(2i3,3f10.5)')
 811 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 812               endif
 813             endif
 814 #endif
 815           enddo      ! j
 816         enddo        ! iint
 817 #ifdef FOURBODY
 818 C Change 12/1/95
 819         num_cont(i)=num_conti
 820 #endif
 821       enddo          ! i
 822       if (calc_grad) then
 823       do i=1,nct
 824         do j=1,3
 825           gvdwc(j,i)=expon*gvdwc(j,i)
 826           gvdwx(j,i)=expon*gvdwx(j,i)
 827         enddo
 828       enddo
 829       endif
 830 C******************************************************************************
 831 C
 832 C                              N O T E !!!
 833 C
 834 C To save time, the factor of EXPON has been extracted from ALL components
 835 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 836 C use!
 837 C
 838 C******************************************************************************
 839       return
 840       end
 841 C-----------------------------------------------------------------------------
 842       subroutine eljk(evdw,evdw_t)
 843 C
 844 C This subroutine calculates the interaction energy of nonbonded side chains
 845 C assuming the LJK potential of interaction.
 846 C
 847       implicit real*8 (a-h,o-z)
 848       include 'DIMENSIONS'
 849       include "DIMENSIONS.COMPAR"
 850       include 'COMMON.GEO'
 851       include 'COMMON.VAR'
 852       include 'COMMON.LOCAL'
 853       include 'COMMON.CHAIN'
 854       include 'COMMON.DERIV'
 855       include 'COMMON.INTERACT'
 856       include 'COMMON.IOUNITS'
 857       include 'COMMON.NAMES'
 858       dimension gg(3)
 859       logical scheck
 860       integer icant
 861       external icant
 862 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 863 c      do i=1,210
 864 c        do j=1,2
 865 c          eneps_temp(j,i)=0.0d0
 866 c        enddo
 867 c      enddo
 868       evdw=0.0D0
 869       evdw_t=0.0d0
 870       do i=iatsc_s,iatsc_e
 871         itypi=iabs(itype(i))
 872         if (itypi.eq.ntyp1) cycle
 873         itypi1=iabs(itype(i+1))
 874         xi=c(1,nres+i)
 875         yi=c(2,nres+i)
 876         zi=c(3,nres+i)
 877         call to_box(xi,yi,zi)
 878 C
 879 C Calculate SC interaction energy.
 880 C
 881         do iint=1,nint_gr(i)
 882           do j=istart(i,iint),iend(i,iint)
 883             itypj=iabs(itype(j))
 884             if (itypj.eq.ntyp1) cycle
 885             xj=c(1,nres+j)-xi
 886             yj=c(2,nres+j)-yi
 887             zj=c(3,nres+j)-zi
 888             call to_box(xj,yj,zj)
 889             xj=boxshift(xj-xi,boxxsize)
 890             yj=boxshift(yj-yi,boxysize)
 891             zj=boxshift(zj-zi,boxzsize)
 892             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 893             fac_augm=rrij**expon
 894             e_augm=augm(itypi,itypj)*fac_augm
 895             r_inv_ij=dsqrt(rrij)
 896             rij=1.0D0/r_inv_ij
 897             sss1=sscale(rij)
 898             if (sss1.eq.0.0d0) cycle
 899             sssgrad1=sscagrad(rij)
 900             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 901             fac=r_shift_inv**expon
 902             e1=fac*fac*aa
 903             e2=fac*bb
 904             evdwij=e_augm+e1+e2
 905             ij=icant(itypi,itypj)
 906 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 907 c     &        /dabs(eps(itypi,itypj))
 908 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 909 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 910 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 911 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 912 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 913 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 914 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 915 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 916             if (bb.gt.0.0d0) then
 917               evdw=evdw+evdwij*sss1
 918             else
 919               evdw_t=evdw_t+evdwij*sss1
 920             endif
 921             if (calc_grad) then
 922 C
 923 C Calculate the components of the gradient in DC and X
 924 C
 925            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 926      &          +evdwij*sssgrad1*r_inv_ij/expon
 927             gg(1)=xj*fac
 928             gg(2)=yj*fac
 929             gg(3)=zj*fac
 930             do k=1,3
 931               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 932               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 933             enddo
 934             do k=i,j-1
 935               do l=1,3
 936                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 937               enddo
 938             enddo
 939             endif
 940           enddo      ! j
 941         enddo        ! iint
 942       enddo          ! i
 943       if (calc_grad) then
 944       do i=1,nct
 945         do j=1,3
 946           gvdwc(j,i)=expon*gvdwc(j,i)
 947           gvdwx(j,i)=expon*gvdwx(j,i)
 948         enddo
 949       enddo
 950       endif
 951       return
 952       end
 953 C-----------------------------------------------------------------------------
 954       subroutine ebp(evdw,evdw_t)
 955 C
 956 C This subroutine calculates the interaction energy of nonbonded side chains
 957 C assuming the Berne-Pechukas potential of interaction.
 958 C
 959       implicit real*8 (a-h,o-z)
 960       include 'DIMENSIONS'
 961       include "DIMENSIONS.COMPAR"
 962       include 'COMMON.GEO'
 963       include 'COMMON.VAR'
 964       include 'COMMON.LOCAL'
 965       include 'COMMON.CHAIN'
 966       include 'COMMON.DERIV'
 967       include 'COMMON.NAMES'
 968       include 'COMMON.INTERACT'
 969       include 'COMMON.IOUNITS'
 970       include 'COMMON.CALC'
 971       common /srutu/ icall
 972 c     double precision rrsave(maxdim)
 973       logical lprn
 974       integer icant
 975       external icant
 976 c      do i=1,210
 977 c        do j=1,2
 978 c          eneps_temp(j,i)=0.0d0
 979 c        enddo
 980 c      enddo
 981       evdw=0.0D0
 982       evdw_t=0.0d0
 983 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 984 c     if (icall.eq.0) then
 985 c       lprn=.true.
 986 c     else
 987         lprn=.false.
 988 c     endif
 989       ind=0
 990       do i=iatsc_s,iatsc_e
 991         itypi=iabs(itype(i))
 992         if (itypi.eq.ntyp1) cycle
 993         itypi1=iabs(itype(i+1))
 994         xi=c(1,nres+i)
 995         yi=c(2,nres+i)
 996         zi=c(3,nres+i)
 997         call to_box(xi,yi,zi)
 998         dxi=dc_norm(1,nres+i)
 999         dyi=dc_norm(2,nres+i)
1000         dzi=dc_norm(3,nres+i)
1001         dsci_inv=vbld_inv(i+nres)
1002 C
1003 C Calculate SC interaction energy.
1004 C
1005         do iint=1,nint_gr(i)
1006           do j=istart(i,iint),iend(i,iint)
1007             ind=ind+1
1008             itypj=iabs(itype(j))
1009             if (itypj.eq.ntyp1) cycle
1010             dscj_inv=vbld_inv(j+nres)
1011             chi1=chi(itypi,itypj)
1012             chi2=chi(itypj,itypi)
1013             chi12=chi1*chi2
1014             chip1=chip(itypi)
1015             chip2=chip(itypj)
1016             chip12=chip1*chip2
1017             alf1=alp(itypi)
1018             alf2=alp(itypj)
1019             alf12=0.5D0*(alf1+alf2)
1020 C For diagnostics only!!!
1021 c           chi1=0.0D0
1022 c           chi2=0.0D0
1023 c           chi12=0.0D0
1024 c           chip1=0.0D0
1025 c           chip2=0.0D0
1026 c           chip12=0.0D0
1027 c           alf1=0.0D0
1028 c           alf2=0.0D0
1029 c           alf12=0.0D0
1030             xj=c(1,nres+j)
1031             yj=c(2,nres+j)
1032             zj=c(3,nres+j)
1033             call to_box(xj,yj,zj)
1034             xj=boxshift(xj-xi,boxxsize)
1035             yj=boxshift(yj-yi,boxysize)
1036             zj=boxshift(zj-zi,boxzsize)
1037             dxj=dc_norm(1,nres+j)
1038             dyj=dc_norm(2,nres+j)
1039             dzj=dc_norm(3,nres+j)
1040             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1041 cd          if (icall.eq.0) then
1042 cd            rrsave(ind)=rrij
1043 cd          else
1044 cd            rrij=rrsave(ind)
1045 cd          endif
1046             rij=dsqrt(rrij)
1047 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1048             call sc_angular
1049 C Calculate whole angle-dependent part of epsilon and contributions
1050 C to its derivatives
1051             fac=(rrij*sigsq)**expon2
1052             e1=fac*fac*aa
1053             e2=fac*bb
1054             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1055             eps2der=evdwij*eps3rt
1056             eps3der=evdwij*eps2rt
1057             evdwij=evdwij*eps2rt*eps3rt
1058             ij=icant(itypi,itypj)
1059             aux=eps1*eps2rt**2*eps3rt**2
1060 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1061 c     &        /dabs(eps(itypi,itypj))
1062 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1063             if (bb.gt.0.0d0) then
1064               evdw=evdw+evdwij
1065             else
1066               evdw_t=evdw_t+evdwij
1067             endif
1068             if (calc_grad) then
1069             if (lprn) then
1070             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1071             epsi=bb**2/aa
1072             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1073      &        restyp(itypi),i,restyp(itypj),j,
1074      &        epsi,sigm,chi1,chi2,chip1,chip2,
1075      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1076      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1077      &        evdwij
1078             endif
1079 C Calculate gradient components.
1080             e1=e1*eps1*eps2rt**2*eps3rt**2
1081             fac=-expon*(e1+evdwij)
1082             sigder=fac/sigsq
1083             fac=rrij*fac
1084 C Calculate radial part of the gradient
1085             gg(1)=xj*fac
1086             gg(2)=yj*fac
1087             gg(3)=zj*fac
1088 C Calculate the angular part of the gradient and sum add the contributions
1089 C to the appropriate components of the Cartesian gradient.
1090             call sc_grad
1091             endif
1092           enddo      ! j
1093         enddo        ! iint
1094       enddo          ! i
1095 c     stop
1096       return
1097       end
1098 C-----------------------------------------------------------------------------
1099       subroutine egb(evdw,evdw_t)
1100 C
1101 C This subroutine calculates the interaction energy of nonbonded side chains
1102 C assuming the Gay-Berne potential of interaction.
1103 C
1104       implicit real*8 (a-h,o-z)
1105       include 'DIMENSIONS'
1106       include "DIMENSIONS.COMPAR"
1107       include 'COMMON.GEO'
1108       include 'COMMON.VAR'
1109       include 'COMMON.LOCAL'
1110       include 'COMMON.CHAIN'
1111       include 'COMMON.DERIV'
1112       include 'COMMON.NAMES'
1113       include 'COMMON.INTERACT'
1114       include 'COMMON.IOUNITS'
1115       include 'COMMON.CALC'
1116       include 'COMMON.SBRIDGE'
1117       logical lprn
1118       common /srutu/icall
1119       integer icant,xshift,yshift,zshift
1120       external icant
1121 c      do i=1,210
1122 c        do j=1,2
1123 c          eneps_temp(j,i)=0.0d0
1124 c        enddo
1125 c      enddo
1126 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1127       evdw=0.0D0
1128       evdw_t=0.0d0
1129       lprn=.false.
1130 c      if (icall.gt.0) lprn=.true.
1131       ind=0
1132       do i=iatsc_s,iatsc_e
1133         itypi=iabs(itype(i))
1134         if (itypi.eq.ntyp1) cycle
1135         itypi1=iabs(itype(i+1))
1136         xi=c(1,nres+i)
1137         yi=c(2,nres+i)
1138         zi=c(3,nres+i)
1139 C returning the ith atom to box
1140         call to_box(xi,yi,zi)
1141         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
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             call to_box(xj,yj,zj)
1200             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1201             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1202      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1203             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1204      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1205             xj=boxshift(xj-xi,boxxsize)
1206             yj=boxshift(yj-yi,boxysize)
1207             zj=boxshift(zj-zi,boxzsize)
1208             dxj=dc_norm(1,nres+j)
1209             dyj=dc_norm(2,nres+j)
1210             dzj=dc_norm(3,nres+j)
1211 c            write (iout,*) i,j,xj,yj,zj
1212             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1213             rij=dsqrt(rrij)
1214             sss=sscale(1.0d0/rij)
1215             sssgrad=sscagrad(1.0d0/rij)
1216             if (sss.le.0.0) cycle
1217 C Calculate angle-dependent terms of energy and contributions to their
1218 C derivatives.
1219
1220             call sc_angular
1221             sigsq=1.0D0/sigsq
1222             sig=sig0ij*dsqrt(sigsq)
1223             rij_shift=1.0D0/rij-sig+sig0ij
1224 C I hate to put IF's in the loops, but here don't have another choice!!!!
1225             if (rij_shift.le.0.0D0) then
1226               evdw=1.0D20
1227               return
1228             endif
1229             sigder=-sig*sigsq
1230 c---------------------------------------------------------------
1231             rij_shift=1.0D0/rij_shift
1232             fac=rij_shift**expon
1233             e1=fac*fac*aa
1234             e2=fac*bb
1235             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1236             eps2der=evdwij*eps3rt
1237             eps3der=evdwij*eps2rt
1238             evdwij=evdwij*eps2rt*eps3rt
1239             if (bb.gt.0) then
1240               evdw=evdw+evdwij*sss
1241             else
1242               evdw_t=evdw_t+evdwij*sss
1243             endif
1244             ij=icant(itypi,itypj)
1245             aux=eps1*eps2rt**2*eps3rt**2
1246 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1247 c     &        /dabs(eps(itypi,itypj))
1248 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1249 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1250 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1251 c     &         aux*e2/eps(itypi,itypj)
1252 c            if (lprn) then
1253             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1254             epsi=bb**2/aa
1255 C#define DEBUG
1256 #ifdef DEBUG
1257             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1258      &        restyp(itypi),i,restyp(itypj),j,
1259      &        epsi,sigm,chi1,chi2,chip1,chip2,
1260      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1261      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1262      &        evdwij
1263              write (iout,*) "partial sum", evdw, evdw_t
1264 #endif
1265 C#undef DEBUG
1266 c            endif
1267             if (calc_grad) then
1268 C Calculate gradient components.
1269             e1=e1*eps1*eps2rt**2*eps3rt**2
1270             fac=-expon*(e1+evdwij)*rij_shift
1271             sigder=fac*sigder
1272             fac=rij*fac
1273             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1274 C Calculate the radial part of the gradient
1275             gg(1)=xj*fac
1276             gg(2)=yj*fac
1277             gg(3)=zj*fac
1278 C Calculate angular part of the gradient.
1279             call sc_grad
1280             endif
1281 C            write(iout,*)  "partial sum", evdw, evdw_t
1282             ENDIF    ! dyn_ss
1283           enddo      ! j
1284         enddo        ! iint
1285       enddo          ! i
1286       return
1287       end
1288 C-----------------------------------------------------------------------------
1289       subroutine egbv(evdw,evdw_t)
1290 C
1291 C This subroutine calculates the interaction energy of nonbonded side chains
1292 C assuming the Gay-Berne-Vorobjev potential of interaction.
1293 C
1294       implicit real*8 (a-h,o-z)
1295       include 'DIMENSIONS'
1296       include "DIMENSIONS.COMPAR"
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.DERIV'
1302       include 'COMMON.NAMES'
1303       include 'COMMON.INTERACT'
1304       include 'COMMON.IOUNITS'
1305       include 'COMMON.CALC'
1306       common /srutu/ icall
1307       logical lprn
1308       integer icant
1309       external icant
1310 c      do i=1,210
1311 c        do j=1,2
1312 c          eneps_temp(j,i)=0.0d0
1313 c        enddo
1314 c      enddo
1315       evdw=0.0D0
1316       evdw_t=0.0d0
1317 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1318       evdw=0.0D0
1319       lprn=.false.
1320 c      if (icall.gt.0) lprn=.true.
1321       ind=0
1322       do i=iatsc_s,iatsc_e
1323         itypi=iabs(itype(i))
1324         if (itypi.eq.ntyp1) cycle
1325         itypi1=iabs(itype(i+1))
1326         xi=c(1,nres+i)
1327         yi=c(2,nres+i)
1328         zi=c(3,nres+i)
1329         call to_box(xi,yi,zi)
1330         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1331         dxi=dc_norm(1,nres+i)
1332         dyi=dc_norm(2,nres+i)
1333         dzi=dc_norm(3,nres+i)
1334         dsci_inv=vbld_inv(i+nres)
1335 C
1336 C Calculate SC interaction energy.
1337 C
1338         do iint=1,nint_gr(i)
1339           do j=istart(i,iint),iend(i,iint)
1340             ind=ind+1
1341             itypj=iabs(itype(j))
1342             if (itypj.eq.ntyp1) cycle
1343             dscj_inv=vbld_inv(j+nres)
1344             sig0ij=sigma(itypi,itypj)
1345             r0ij=r0(itypi,itypj)
1346             chi1=chi(itypi,itypj)
1347             chi2=chi(itypj,itypi)
1348             chi12=chi1*chi2
1349             chip1=chip(itypi)
1350             chip2=chip(itypj)
1351             chip12=chip1*chip2
1352             alf1=alp(itypi)
1353             alf2=alp(itypj)
1354             alf12=0.5D0*(alf1+alf2)
1355 C For diagnostics only!!!
1356 c           chi1=0.0D0
1357 c           chi2=0.0D0
1358 c           chi12=0.0D0
1359 c           chip1=0.0D0
1360 c           chip2=0.0D0
1361 c           chip12=0.0D0
1362 c           alf1=0.0D0
1363 c           alf2=0.0D0
1364 c           alf12=0.0D0
1365             xj=c(1,nres+j)
1366             yj=c(2,nres+j)
1367             zj=c(3,nres+j)
1368             call to_box(xj,yj,zj)
1369             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1370             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1371      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1372             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1373      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1374             dxj=dc_norm(1,nres+j)
1375             dyj=dc_norm(2,nres+j)
1376             dzj=dc_norm(3,nres+j)
1377             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1378             rij=dsqrt(rrij)
1379             sss=sscale(1.0d0/rij)
1380             if (sss.eq.0.0d0) cycle
1381             sssgrad=sscagrad(1.0d0/rij)
1382 C Calculate angle-dependent terms of energy and contributions to their
1383 C derivatives.
1384             call sc_angular
1385             sigsq=1.0D0/sigsq
1386             sig=sig0ij*dsqrt(sigsq)
1387             rij_shift=1.0D0/rij-sig+r0ij
1388 C I hate to put IF's in the loops, but here don't have another choice!!!!
1389             if (rij_shift.le.0.0D0) then
1390               evdw=1.0D20
1391               return
1392             endif
1393             sigder=-sig*sigsq
1394 c---------------------------------------------------------------
1395             rij_shift=1.0D0/rij_shift
1396             fac=rij_shift**expon
1397             e1=fac*fac*aa
1398             e2=fac*bb
1399             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1400             eps2der=evdwij*eps3rt
1401             eps3der=evdwij*eps2rt
1402             fac_augm=rrij**expon
1403             e_augm=augm(itypi,itypj)*fac_augm
1404             evdwij=evdwij*eps2rt*eps3rt
1405             if (bb.gt.0.0d0) then
1406               evdw=evdw+(evdwij+e_augm)*sss
1407             else
1408               evdw_t=evdw_t+(evdwij+e_augm)*sss
1409             endif
1410             ij=icant(itypi,itypj)
1411             aux=eps1*eps2rt**2*eps3rt**2
1412 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1413 c     &        /dabs(eps(itypi,itypj))
1414 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1415 c            eneps_temp(ij)=eneps_temp(ij)
1416 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1417 c            if (lprn) then
1418 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1419 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1420 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1421 c     &        restyp(itypi),i,restyp(itypj),j,
1422 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1423 c     &        chi1,chi2,chip1,chip2,
1424 c     &        eps1,eps2rt**2,eps3rt**2,
1425 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1426 c     &        evdwij+e_augm
1427 c            endif
1428             if (calc_grad) then
1429 C Calculate gradient components.
1430             e1=e1*eps1*eps2rt**2*eps3rt**2
1431             fac=-expon*(e1+evdwij)*rij_shift
1432             sigder=fac*sigder
1433             fac=rij*fac-2*expon*rrij*e_augm
1434             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1435 C Calculate the radial part of the gradient
1436             gg(1)=xj*fac
1437             gg(2)=yj*fac
1438             gg(3)=zj*fac
1439 C Calculate angular part of the gradient.
1440             call sc_grad
1441             endif
1442           enddo      ! j
1443         enddo        ! iint
1444       enddo          ! i
1445       return
1446       end
1447 C-----------------------------------------------------------------------------
1448       subroutine sc_angular
1449 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1450 C om12. Called by ebp, egb, and egbv.
1451       implicit none
1452       include 'COMMON.CALC'
1453       erij(1)=xj*rij
1454       erij(2)=yj*rij
1455       erij(3)=zj*rij
1456       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1457       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1458       om12=dxi*dxj+dyi*dyj+dzi*dzj
1459       chiom12=chi12*om12
1460 C Calculate eps1(om12) and its derivative in om12
1461       faceps1=1.0D0-om12*chiom12
1462       faceps1_inv=1.0D0/faceps1
1463       eps1=dsqrt(faceps1_inv)
1464 C Following variable is eps1*deps1/dom12
1465       eps1_om12=faceps1_inv*chiom12
1466 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1467 C and om12.
1468       om1om2=om1*om2
1469       chiom1=chi1*om1
1470       chiom2=chi2*om2
1471       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1472       sigsq=1.0D0-facsig*faceps1_inv
1473       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1474       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1475       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1476 C Calculate eps2 and its derivatives in om1, om2, and om12.
1477       chipom1=chip1*om1
1478       chipom2=chip2*om2
1479       chipom12=chip12*om12
1480       facp=1.0D0-om12*chipom12
1481       facp_inv=1.0D0/facp
1482       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1483 C Following variable is the square root of eps2
1484       eps2rt=1.0D0-facp1*facp_inv
1485 C Following three variables are the derivatives of the square root of eps
1486 C in om1, om2, and om12.
1487       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1488       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1489       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1490 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1491       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1492 C Calculate whole angle-dependent part of epsilon and contributions
1493 C to its derivatives
1494       return
1495       end
1496 C----------------------------------------------------------------------------
1497       subroutine sc_grad
1498       implicit real*8 (a-h,o-z)
1499       include 'DIMENSIONS'
1500       include 'COMMON.CHAIN'
1501       include 'COMMON.DERIV'
1502       include 'COMMON.CALC'
1503       double precision dcosom1(3),dcosom2(3)
1504       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1505       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1506       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1507      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1508       do k=1,3
1509         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1510         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1511       enddo
1512       do k=1,3
1513         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1514       enddo
1515       do k=1,3
1516         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1517      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1518      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1519         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1520      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1521      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1522       enddo
1523 C
1524 C Calculate the components of the gradient in DC and X
1525 C
1526       do k=i,j-1
1527         do l=1,3
1528           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1529         enddo
1530       enddo
1531       return
1532       end
1533 c------------------------------------------------------------------------------
1534       subroutine vec_and_deriv
1535       implicit real*8 (a-h,o-z)
1536       include 'DIMENSIONS'
1537       include 'COMMON.IOUNITS'
1538       include 'COMMON.GEO'
1539       include 'COMMON.VAR'
1540       include 'COMMON.LOCAL'
1541       include 'COMMON.CHAIN'
1542       include 'COMMON.VECTORS'
1543       include 'COMMON.DERIV'
1544       include 'COMMON.INTERACT'
1545       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1546 C Compute the local reference systems. For reference system (i), the
1547 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1548 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1549       do i=1,nres-1
1550 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1551           if (i.eq.nres-1) then
1552 C Case of the last full residue
1553 C Compute the Z-axis
1554             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1555             costh=dcos(pi-theta(nres))
1556             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1557 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1558 c     &         " uz",uz(:,i)
1559             do k=1,3
1560               uz(k,i)=fac*uz(k,i)
1561             enddo
1562             if (calc_grad) then
1563 C Compute the derivatives of uz
1564             uzder(1,1,1)= 0.0d0
1565             uzder(2,1,1)=-dc_norm(3,i-1)
1566             uzder(3,1,1)= dc_norm(2,i-1)
1567             uzder(1,2,1)= dc_norm(3,i-1)
1568             uzder(2,2,1)= 0.0d0
1569             uzder(3,2,1)=-dc_norm(1,i-1)
1570             uzder(1,3,1)=-dc_norm(2,i-1)
1571             uzder(2,3,1)= dc_norm(1,i-1)
1572             uzder(3,3,1)= 0.0d0
1573             uzder(1,1,2)= 0.0d0
1574             uzder(2,1,2)= dc_norm(3,i)
1575             uzder(3,1,2)=-dc_norm(2,i)
1576             uzder(1,2,2)=-dc_norm(3,i)
1577             uzder(2,2,2)= 0.0d0
1578             uzder(3,2,2)= dc_norm(1,i)
1579             uzder(1,3,2)= dc_norm(2,i)
1580             uzder(2,3,2)=-dc_norm(1,i)
1581             uzder(3,3,2)= 0.0d0
1582             endif ! calc_grad
1583 C Compute the Y-axis
1584             facy=fac
1585             do k=1,3
1586               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1587             enddo
1588             if (calc_grad) then
1589 C Compute the derivatives of uy
1590             do j=1,3
1591               do k=1,3
1592                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1593      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1594                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1595               enddo
1596               uyder(j,j,1)=uyder(j,j,1)-costh
1597               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1598             enddo
1599             do j=1,2
1600               do k=1,3
1601                 do l=1,3
1602                   uygrad(l,k,j,i)=uyder(l,k,j)
1603                   uzgrad(l,k,j,i)=uzder(l,k,j)
1604                 enddo
1605               enddo
1606             enddo
1607             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1608             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1609             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1610             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1611             endif
1612           else
1613 C Other residues
1614 C Compute the Z-axis
1615             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1616             costh=dcos(pi-theta(i+2))
1617             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1618             do k=1,3
1619               uz(k,i)=fac*uz(k,i)
1620             enddo
1621             if (calc_grad) then
1622 C Compute the derivatives of uz
1623             uzder(1,1,1)= 0.0d0
1624             uzder(2,1,1)=-dc_norm(3,i+1)
1625             uzder(3,1,1)= dc_norm(2,i+1)
1626             uzder(1,2,1)= dc_norm(3,i+1)
1627             uzder(2,2,1)= 0.0d0
1628             uzder(3,2,1)=-dc_norm(1,i+1)
1629             uzder(1,3,1)=-dc_norm(2,i+1)
1630             uzder(2,3,1)= dc_norm(1,i+1)
1631             uzder(3,3,1)= 0.0d0
1632             uzder(1,1,2)= 0.0d0
1633             uzder(2,1,2)= dc_norm(3,i)
1634             uzder(3,1,2)=-dc_norm(2,i)
1635             uzder(1,2,2)=-dc_norm(3,i)
1636             uzder(2,2,2)= 0.0d0
1637             uzder(3,2,2)= dc_norm(1,i)
1638             uzder(1,3,2)= dc_norm(2,i)
1639             uzder(2,3,2)=-dc_norm(1,i)
1640             uzder(3,3,2)= 0.0d0
1641             endif
1642 C Compute the Y-axis
1643             facy=fac
1644             do k=1,3
1645               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1646             enddo
1647             if (calc_grad) then
1648 C Compute the derivatives of uy
1649             do j=1,3
1650               do k=1,3
1651                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1652      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1653                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1654               enddo
1655               uyder(j,j,1)=uyder(j,j,1)-costh
1656               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1657             enddo
1658             do j=1,2
1659               do k=1,3
1660                 do l=1,3
1661                   uygrad(l,k,j,i)=uyder(l,k,j)
1662                   uzgrad(l,k,j,i)=uzder(l,k,j)
1663                 enddo
1664               enddo
1665             enddo
1666             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1667             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1668             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1669             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1670           endif
1671           endif
1672       enddo
1673       if (calc_grad) then
1674       do i=1,nres-1
1675         vbld_inv_temp(1)=vbld_inv(i+1)
1676         if (i.lt.nres-1) then
1677           vbld_inv_temp(2)=vbld_inv(i+2)
1678         else
1679           vbld_inv_temp(2)=vbld_inv(i)
1680         endif
1681         do j=1,2
1682           do k=1,3
1683             do l=1,3
1684               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1685               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1686             enddo
1687           enddo
1688         enddo
1689       enddo
1690       endif
1691       return
1692       end
1693 C--------------------------------------------------------------------------
1694       subroutine set_matrices
1695       implicit real*8 (a-h,o-z)
1696       include 'DIMENSIONS'
1697 #ifdef MPI
1698       include "mpif.h"
1699       integer IERR
1700       integer status(MPI_STATUS_SIZE)
1701 #endif
1702       include 'COMMON.IOUNITS'
1703       include 'COMMON.GEO'
1704       include 'COMMON.VAR'
1705       include 'COMMON.LOCAL'
1706       include 'COMMON.CHAIN'
1707       include 'COMMON.DERIV'
1708       include 'COMMON.INTERACT'
1709       include 'COMMON.CONTACTS'
1710       include 'COMMON.TORSION'
1711       include 'COMMON.VECTORS'
1712       include 'COMMON.FFIELD'
1713       include 'COMMON.CORRMAT'
1714       double precision auxvec(2),auxmat(2,2)
1715 C
1716 C Compute the virtual-bond-torsional-angle dependent quantities needed
1717 C to calculate the el-loc multibody terms of various order.
1718 C
1719 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1720       do i=3,nres+1
1721         ii=ireschain(i-2)
1722         if (ii.eq.0) cycle
1723         innt=chain_border(1,ii)
1724         inct=chain_border(2,ii)
1725         if (i.gt. innt+2 .and. i.lt.inct+2) then
1726           iti = itype2loc(itype(i-2))
1727         else
1728           iti=nloctyp
1729         endif
1730 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1731         if (i.gt. innt+1 .and. i.lt.inct+1) then
1732           iti1 = itype2loc(itype(i-1))
1733         else
1734           iti1=nloctyp
1735         endif
1736 #ifdef NEWCORR
1737         cost1=dcos(theta(i-1))
1738         sint1=dsin(theta(i-1))
1739         sint1sq=sint1*sint1
1740         sint1cub=sint1sq*sint1
1741         sint1cost1=2*sint1*cost1
1742 #ifdef DEBUG
1743         write (iout,*) "bnew1",i,iti
1744         write (iout,*) (bnew1(k,1,iti),k=1,3)
1745         write (iout,*) (bnew1(k,2,iti),k=1,3)
1746         write (iout,*) "bnew2",i,iti
1747         write (iout,*) (bnew2(k,1,iti),k=1,3)
1748         write (iout,*) (bnew2(k,2,iti),k=1,3)
1749 #endif
1750         do k=1,2
1751           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1752           b1(k,i-2)=sint1*b1k
1753           gtb1(k,i-2)=cost1*b1k-sint1sq*
1754      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1755           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1756           b2(k,i-2)=sint1*b2k
1757           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1758      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1759         enddo
1760         do k=1,2
1761           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1762           cc(1,k,i-2)=sint1sq*aux
1763           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1764      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1765           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1766           dd(1,k,i-2)=sint1sq*aux
1767           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1768      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1769         enddo
1770         cc(2,1,i-2)=cc(1,2,i-2)
1771         cc(2,2,i-2)=-cc(1,1,i-2)
1772         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1773         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1774         dd(2,1,i-2)=dd(1,2,i-2)
1775         dd(2,2,i-2)=-dd(1,1,i-2)
1776         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1777         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1778         do k=1,2
1779           do l=1,2
1780             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1781             EE(l,k,i-2)=sint1sq*aux
1782             if (calc_grad)
1783      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1784           enddo
1785         enddo
1786         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1787         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1788         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1789         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1790         if (calc_grad) then
1791         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1792         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1793         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1794         endif
1795 c        b1tilde(1,i-2)=b1(1,i-2)
1796 c        b1tilde(2,i-2)=-b1(2,i-2)
1797 c        b2tilde(1,i-2)=b2(1,i-2)
1798 c        b2tilde(2,i-2)=-b2(2,i-2)
1799 #ifdef DEBUG
1800         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1801         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1802         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1803         write (iout,*) 'theta=', theta(i-1)
1804 #endif
1805 #else
1806         if (i.gt. innt+2 .and. i.lt.inct+2) then
1807 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1808           iti = itype2loc(itype(i-2))
1809         else
1810           iti=nloctyp
1811         endif
1812 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
1813 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1814         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1815           iti1 = itype2loc(itype(i-1))
1816         else
1817           iti1=nloctyp
1818         endif
1819 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1820 c          iti = itype2loc(itype(i-2))
1821 c        else
1822 c          iti=nloctyp
1823 c        endif
1824 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1825 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1826 c          iti1 = itype2loc(itype(i-1))
1827 c        else
1828 c          iti1=nloctyp
1829 c        endif
1830         b1(1,i-2)=b(3,iti)
1831         b1(2,i-2)=b(5,iti)
1832         b2(1,i-2)=b(2,iti)
1833         b2(2,i-2)=b(4,iti)
1834         do k=1,2
1835           do l=1,2
1836            CC(k,l,i-2)=ccold(k,l,iti)
1837            DD(k,l,i-2)=ddold(k,l,iti)
1838            EE(k,l,i-2)=eeold(k,l,iti)
1839           enddo
1840         enddo
1841 #endif
1842         b1tilde(1,i-2)= b1(1,i-2)
1843         b1tilde(2,i-2)=-b1(2,i-2)
1844         b2tilde(1,i-2)= b2(1,i-2)
1845         b2tilde(2,i-2)=-b2(2,i-2)
1846 c
1847         Ctilde(1,1,i-2)= CC(1,1,i-2)
1848         Ctilde(1,2,i-2)= CC(1,2,i-2)
1849         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1850         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1851 c
1852         Dtilde(1,1,i-2)= DD(1,1,i-2)
1853         Dtilde(1,2,i-2)= DD(1,2,i-2)
1854         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1855         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1856 c        write(iout,*) "i",i," iti",iti
1857 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1858 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1859       enddo
1860       do i=3,nres+1
1861         if (i .lt. nres+1) then
1862           sin1=dsin(phi(i))
1863           cos1=dcos(phi(i))
1864           sintab(i-2)=sin1
1865           costab(i-2)=cos1
1866           obrot(1,i-2)=cos1
1867           obrot(2,i-2)=sin1
1868           sin2=dsin(2*phi(i))
1869           cos2=dcos(2*phi(i))
1870           sintab2(i-2)=sin2
1871           costab2(i-2)=cos2
1872           obrot2(1,i-2)=cos2
1873           obrot2(2,i-2)=sin2
1874           Ug(1,1,i-2)=-cos1
1875           Ug(1,2,i-2)=-sin1
1876           Ug(2,1,i-2)=-sin1
1877           Ug(2,2,i-2)= cos1
1878           Ug2(1,1,i-2)=-cos2
1879           Ug2(1,2,i-2)=-sin2
1880           Ug2(2,1,i-2)=-sin2
1881           Ug2(2,2,i-2)= cos2
1882         else
1883           costab(i-2)=1.0d0
1884           sintab(i-2)=0.0d0
1885           obrot(1,i-2)=1.0d0
1886           obrot(2,i-2)=0.0d0
1887           obrot2(1,i-2)=0.0d0
1888           obrot2(2,i-2)=0.0d0
1889           Ug(1,1,i-2)=1.0d0
1890           Ug(1,2,i-2)=0.0d0
1891           Ug(2,1,i-2)=0.0d0
1892           Ug(2,2,i-2)=1.0d0
1893           Ug2(1,1,i-2)=0.0d0
1894           Ug2(1,2,i-2)=0.0d0
1895           Ug2(2,1,i-2)=0.0d0
1896           Ug2(2,2,i-2)=0.0d0
1897         endif
1898         if (i .gt. 3 .and. i .lt. nres+1) then
1899           obrot_der(1,i-2)=-sin1
1900           obrot_der(2,i-2)= cos1
1901           Ugder(1,1,i-2)= sin1
1902           Ugder(1,2,i-2)=-cos1
1903           Ugder(2,1,i-2)=-cos1
1904           Ugder(2,2,i-2)=-sin1
1905           dwacos2=cos2+cos2
1906           dwasin2=sin2+sin2
1907           obrot2_der(1,i-2)=-dwasin2
1908           obrot2_der(2,i-2)= dwacos2
1909           Ug2der(1,1,i-2)= dwasin2
1910           Ug2der(1,2,i-2)=-dwacos2
1911           Ug2der(2,1,i-2)=-dwacos2
1912           Ug2der(2,2,i-2)=-dwasin2
1913         else
1914           obrot_der(1,i-2)=0.0d0
1915           obrot_der(2,i-2)=0.0d0
1916           Ugder(1,1,i-2)=0.0d0
1917           Ugder(1,2,i-2)=0.0d0
1918           Ugder(2,1,i-2)=0.0d0
1919           Ugder(2,2,i-2)=0.0d0
1920           obrot2_der(1,i-2)=0.0d0
1921           obrot2_der(2,i-2)=0.0d0
1922           Ug2der(1,1,i-2)=0.0d0
1923           Ug2der(1,2,i-2)=0.0d0
1924           Ug2der(2,1,i-2)=0.0d0
1925           Ug2der(2,2,i-2)=0.0d0
1926         endif
1927 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1928         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1929           iti = itype2loc(itype(i-2))
1930         else
1931           iti=nloctyp
1932         endif
1933 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1934         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1935           iti1 = itype2loc(itype(i-1))
1936         else
1937           iti1=nloctyp
1938         endif
1939 cd        write (iout,*) '*******i',i,' iti1',iti
1940 cd        write (iout,*) 'b1',b1(:,iti)
1941 cd        write (iout,*) 'b2',b2(:,iti)
1942 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1943 c        if (i .gt. iatel_s+2) then
1944         if (i .gt. nnt+2) then
1945           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1946 #ifdef NEWCORR
1947           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1948 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1949 #endif
1950 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1951 c     &    EE(1,2,iti),EE(2,2,i)
1952           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1953           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1954 c          write(iout,*) "Macierz EUG",
1955 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1956 c     &    eug(2,2,i-2)
1957 #ifdef FOURBODY
1958           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1959      &    then
1960           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1961           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1962           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1963           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1964           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1965           endif
1966 #endif
1967         else
1968           do k=1,2
1969             Ub2(k,i-2)=0.0d0
1970             Ctobr(k,i-2)=0.0d0
1971             Dtobr2(k,i-2)=0.0d0
1972             do l=1,2
1973               EUg(l,k,i-2)=0.0d0
1974               CUg(l,k,i-2)=0.0d0
1975               DUg(l,k,i-2)=0.0d0
1976               DtUg2(l,k,i-2)=0.0d0
1977             enddo
1978           enddo
1979         endif
1980         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1981         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1982         do k=1,2
1983           muder(k,i-2)=Ub2der(k,i-2)
1984         enddo
1985 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1986         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1987           if (itype(i-1).le.ntyp) then
1988             iti1 = itype2loc(itype(i-1))
1989           else
1990             iti1=nloctyp
1991           endif
1992         else
1993           iti1=nloctyp
1994         endif
1995         do k=1,2
1996           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
1997         enddo
1998 #ifdef MUOUT
1999         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2000      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2001      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2002      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2003      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2004      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2005 #endif
2006 cd        write (iout,*) 'mu1',mu1(:,i-2)
2007 cd        write (iout,*) 'mu2',mu2(:,i-2)
2008 #ifdef FOURBODY
2009         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2010      &  then
2011         if (calc_grad) then
2012         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2013         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2014         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2015         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2016         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2017         endif
2018 C Vectors and matrices dependent on a single virtual-bond dihedral.
2019         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2020         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2021         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2022         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2023         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2024         if (calc_grad) then
2025         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2026         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2027         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2028         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2029         endif
2030         endif
2031 #endif
2032       enddo
2033 #ifdef FOURBODY
2034 C Matrices dependent on two consecutive virtual-bond dihedrals.
2035 C The order of matrices is from left to right.
2036       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2037      &then
2038       do i=2,nres-1
2039         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2040         if (calc_grad) then
2041         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2042         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2043         endif
2044         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2045         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2046         if (calc_grad) then
2047         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2048         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2049         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2050         endif
2051       enddo
2052       endif
2053 #endif
2054       return
2055       end
2056 C--------------------------------------------------------------------------
2057       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2058 C
2059 C This subroutine calculates the average interaction energy and its gradient
2060 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2061 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2062 C The potential depends both on the distance of peptide-group centers and on
2063 C the orientation of the CA-CA virtual bonds.
2064 C
2065       implicit real*8 (a-h,o-z)
2066 #ifdef MPI
2067       include 'mpif.h'
2068 #endif
2069       include 'DIMENSIONS'
2070       include 'COMMON.CONTROL'
2071       include 'COMMON.IOUNITS'
2072       include 'COMMON.GEO'
2073       include 'COMMON.VAR'
2074       include 'COMMON.LOCAL'
2075       include 'COMMON.CHAIN'
2076       include 'COMMON.DERIV'
2077       include 'COMMON.INTERACT'
2078 #ifdef FOURBODY
2079       include 'COMMON.CONTACTS'
2080       include 'COMMON.CONTMAT'
2081 #endif
2082       include 'COMMON.CORRMAT'
2083       include 'COMMON.TORSION'
2084       include 'COMMON.VECTORS'
2085       include 'COMMON.FFIELD'
2086       include 'COMMON.TIME1'
2087       include 'COMMON.SPLITELE'
2088       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2089      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2090       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2091      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2092       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2093      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2094      &    num_conti,j1,j2
2095 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2096 #ifdef MOMENT
2097       double precision scal_el /1.0d0/
2098 #else
2099       double precision scal_el /0.5d0/
2100 #endif
2101 C 12/13/98
2102 C 13-go grudnia roku pamietnego...
2103       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2104      &                   0.0d0,1.0d0,0.0d0,
2105      &                   0.0d0,0.0d0,1.0d0/
2106 cd      write(iout,*) 'In EELEC'
2107 cd      do i=1,nloctyp
2108 cd        write(iout,*) 'Type',i
2109 cd        write(iout,*) 'B1',B1(:,i)
2110 cd        write(iout,*) 'B2',B2(:,i)
2111 cd        write(iout,*) 'CC',CC(:,:,i)
2112 cd        write(iout,*) 'DD',DD(:,:,i)
2113 cd        write(iout,*) 'EE',EE(:,:,i)
2114 cd      enddo
2115 cd      call check_vecgrad
2116 cd      stop
2117       if (icheckgrad.eq.1) then
2118         do i=1,nres-1
2119           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2120           do k=1,3
2121             dc_norm(k,i)=dc(k,i)*fac
2122           enddo
2123 c          write (iout,*) 'i',i,' fac',fac
2124         enddo
2125       endif
2126       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2127      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2128      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2129 c        call vec_and_deriv
2130 #ifdef TIMING
2131         time01=MPI_Wtime()
2132 #endif
2133         call set_matrices
2134 #ifdef TIMING
2135         time_mat=time_mat+MPI_Wtime()-time01
2136 #endif
2137       endif
2138 cd      do i=1,nres-1
2139 cd        write (iout,*) 'i=',i
2140 cd        do k=1,3
2141 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2142 cd        enddo
2143 cd        do k=1,3
2144 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2145 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2146 cd        enddo
2147 cd      enddo
2148       t_eelecij=0.0d0
2149       ees=0.0D0
2150       evdw1=0.0D0
2151       eel_loc=0.0d0
2152       eello_turn3=0.0d0
2153       eello_turn4=0.0d0
2154       ind=0
2155 #ifdef FOURBODY
2156       do i=1,nres
2157         num_cont_hb(i)=0
2158       enddo
2159 #endif
2160 cd      print '(a)','Enter EELEC'
2161 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2162 c      call flush(iout)
2163       do i=1,nres
2164         gel_loc_loc(i)=0.0d0
2165         gcorr_loc(i)=0.0d0
2166       enddo
2167 c
2168 c
2169 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2170 C
2171 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2172 C
2173 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2174       do i=iturn3_start,iturn3_end
2175 c        if (i.le.1) cycle
2176 C        write(iout,*) "tu jest i",i
2177         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2178 C changes suggested by Ana to avoid out of bounds
2179 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2180 c     & .or.((i+4).gt.nres)
2181 c     & .or.((i-1).le.0)
2182 C end of changes by Ana
2183 C dobra zmiana wycofana
2184      &  .or. itype(i+2).eq.ntyp1
2185      &  .or. itype(i+3).eq.ntyp1) cycle
2186 C Adam: Instructions below will switch off existing interactions
2187 c        if(i.gt.1)then
2188 c          if(itype(i-1).eq.ntyp1)cycle
2189 c        end if
2190 c        if(i.LT.nres-3)then
2191 c          if (itype(i+4).eq.ntyp1) cycle
2192 c        end if
2193         dxi=dc(1,i)
2194         dyi=dc(2,i)
2195         dzi=dc(3,i)
2196         dx_normi=dc_norm(1,i)
2197         dy_normi=dc_norm(2,i)
2198         dz_normi=dc_norm(3,i)
2199         xmedi=c(1,i)+0.5d0*dxi
2200         ymedi=c(2,i)+0.5d0*dyi
2201         zmedi=c(3,i)+0.5d0*dzi
2202         call to_box(xmedi,ymedi,zmedi)
2203         num_conti=0
2204         call eelecij(i,i+2,ees,evdw1,eel_loc)
2205         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2206 #ifdef FOURBODY
2207         num_cont_hb(i)=num_conti
2208 #endif
2209       enddo
2210       do i=iturn4_start,iturn4_end
2211         if (i.lt.1) cycle
2212         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2213 C changes suggested by Ana to avoid out of bounds
2214 c     & .or.((i+5).gt.nres)
2215 c     & .or.((i-1).le.0)
2216 C end of changes suggested by Ana
2217      &    .or. itype(i+3).eq.ntyp1
2218      &    .or. itype(i+4).eq.ntyp1
2219 c     &    .or. itype(i+5).eq.ntyp1
2220 c     &    .or. itype(i).eq.ntyp1
2221 c     &    .or. itype(i-1).eq.ntyp1
2222      &                             ) cycle
2223         dxi=dc(1,i)
2224         dyi=dc(2,i)
2225         dzi=dc(3,i)
2226         dx_normi=dc_norm(1,i)
2227         dy_normi=dc_norm(2,i)
2228         dz_normi=dc_norm(3,i)
2229         xmedi=c(1,i)+0.5d0*dxi
2230         ymedi=c(2,i)+0.5d0*dyi
2231         zmedi=c(3,i)+0.5d0*dzi
2232         call to_box(xmedi,ymedi,zmedi)
2233 #ifdef FOURBODY
2234         num_conti=num_cont_hb(i)
2235 #endif
2236 c        write(iout,*) "JESTEM W PETLI"
2237         call eelecij(i,i+3,ees,evdw1,eel_loc)
2238         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2239      &   call eturn4(i,eello_turn4)
2240 #ifdef FOURBODY
2241         num_cont_hb(i)=num_conti
2242 #endif
2243       enddo   ! i
2244 C Loop over all neighbouring boxes
2245 C      do xshift=-1,1
2246 C      do yshift=-1,1
2247 C      do zshift=-1,1
2248 c
2249 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2250 c
2251 CTU KURWA
2252       do i=iatel_s,iatel_e
2253 C        do i=75,75
2254 c        if (i.le.1) cycle
2255         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2256 C changes suggested by Ana to avoid out of bounds
2257 c     & .or.((i+2).gt.nres)
2258 c     & .or.((i-1).le.0)
2259 C end of changes by Ana
2260 c     &  .or. itype(i+2).eq.ntyp1
2261 c     &  .or. itype(i-1).eq.ntyp1
2262      &                ) cycle
2263         dxi=dc(1,i)
2264         dyi=dc(2,i)
2265         dzi=dc(3,i)
2266         dx_normi=dc_norm(1,i)
2267         dy_normi=dc_norm(2,i)
2268         dz_normi=dc_norm(3,i)
2269         xmedi=c(1,i)+0.5d0*dxi
2270         ymedi=c(2,i)+0.5d0*dyi
2271         zmedi=c(3,i)+0.5d0*dzi
2272         call to_box(xmedi,ymedi,zmedi)
2273 #ifdef FOURBODY
2274         num_conti=num_cont_hb(i)
2275 #endif
2276 C I TU KURWA
2277         do j=ielstart(i),ielend(i)
2278 C          do j=16,17
2279 C          write (iout,*) i,j
2280 C         if (j.le.1) cycle
2281           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2282 C changes suggested by Ana to avoid out of bounds
2283 c     & .or.((j+2).gt.nres)
2284 c     & .or.((j-1).le.0)
2285 C end of changes by Ana
2286 c     & .or.itype(j+2).eq.ntyp1
2287 c     & .or.itype(j-1).eq.ntyp1
2288      &) cycle
2289           call eelecij(i,j,ees,evdw1,eel_loc)
2290         enddo ! j
2291 #ifdef FOURBODY
2292         num_cont_hb(i)=num_conti
2293 #endif
2294       enddo   ! i
2295 C     enddo   ! zshift
2296 C      enddo   ! yshift
2297 C      enddo   ! xshift
2298
2299 c      write (iout,*) "Number of loop steps in EELEC:",ind
2300 cd      do i=1,nres
2301 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2302 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2303 cd      enddo
2304 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2305 ccc      eel_loc=eel_loc+eello_turn3
2306 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2307       return
2308       end
2309 C-------------------------------------------------------------------------------
2310       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2311       implicit real*8 (a-h,o-z)
2312       include 'DIMENSIONS'
2313 #ifdef MPI
2314       include "mpif.h"
2315 #endif
2316       include 'COMMON.CONTROL'
2317       include 'COMMON.IOUNITS'
2318       include 'COMMON.GEO'
2319       include 'COMMON.VAR'
2320       include 'COMMON.LOCAL'
2321       include 'COMMON.CHAIN'
2322       include 'COMMON.DERIV'
2323       include 'COMMON.INTERACT'
2324 #ifdef FOURBODY
2325       include 'COMMON.CONTACTS'
2326       include 'COMMON.CONTMAT'
2327 #endif
2328       include 'COMMON.CORRMAT'
2329       include 'COMMON.TORSION'
2330       include 'COMMON.VECTORS'
2331       include 'COMMON.FFIELD'
2332       include 'COMMON.TIME1'
2333       include 'COMMON.SPLITELE'
2334       include 'COMMON.SHIELD'
2335       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2336      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2337       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2338      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2339      &    gmuij2(4),gmuji2(4)
2340       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2341      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2342      &    num_conti,j1,j2
2343 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2344 #ifdef MOMENT
2345       double precision scal_el /1.0d0/
2346 #else
2347       double precision scal_el /0.5d0/
2348 #endif
2349 C 12/13/98
2350 C 13-go grudnia roku pamietnego...
2351       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2352      &                   0.0d0,1.0d0,0.0d0,
2353      &                   0.0d0,0.0d0,1.0d0/
2354        integer xshift,yshift,zshift
2355 c          time00=MPI_Wtime()
2356 cd      write (iout,*) "eelecij",i,j
2357 c          ind=ind+1
2358           iteli=itel(i)
2359           itelj=itel(j)
2360           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2361           aaa=app(iteli,itelj)
2362           bbb=bpp(iteli,itelj)
2363           ael6i=ael6(iteli,itelj)
2364           ael3i=ael3(iteli,itelj)
2365           dxj=dc(1,j)
2366           dyj=dc(2,j)
2367           dzj=dc(3,j)
2368           dx_normj=dc_norm(1,j)
2369           dy_normj=dc_norm(2,j)
2370           dz_normj=dc_norm(3,j)
2371 C          xj=c(1,j)+0.5D0*dxj-xmedi
2372 C          yj=c(2,j)+0.5D0*dyj-ymedi
2373 C          zj=c(3,j)+0.5D0*dzj-zmedi
2374           xj=c(1,j)+0.5D0*dxj
2375           yj=c(2,j)+0.5D0*dyj
2376           zj=c(3,j)+0.5D0*dzj
2377           call to_box(xj,yj,zj)
2378           xj=boxshift(xj-xmedi,boxxsize)
2379           yj=boxshift(yj-ymedi,boxysize)
2380           zj=boxshift(zj-zmedi,boxzsize)
2381           rij=xj*xj+yj*yj+zj*zj
2382           sss=sscale(sqrt(rij))
2383           if (sss.eq.0.0d0) return
2384           sssgrad=sscagrad(sqrt(rij))
2385 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2386 c     &       " rlamb",rlamb," sss",sss
2387 c            if (sss.gt.0.0d0) then
2388           rrmij=1.0D0/rij
2389           rij=dsqrt(rij)
2390           rmij=1.0D0/rij
2391           r3ij=rrmij*rmij
2392           r6ij=r3ij*r3ij
2393           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2394           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2395           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2396           fac=cosa-3.0D0*cosb*cosg
2397           ev1=aaa*r6ij*r6ij
2398 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2399           if (j.eq.i+2) ev1=scal_el*ev1
2400           ev2=bbb*r6ij
2401           fac3=ael6i*r6ij
2402           fac4=ael3i*r3ij
2403           evdwij=(ev1+ev2)
2404           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2405           el2=fac4*fac
2406 C MARYSIA
2407 C          eesij=(el1+el2)
2408 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2409           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2410           if (shield_mode.gt.0) then
2411 C          fac_shield(i)=0.4
2412 C          fac_shield(j)=0.6
2413           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2414           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2415           eesij=(el1+el2)
2416           ees=ees+eesij
2417           else
2418           fac_shield(i)=1.0
2419           fac_shield(j)=1.0
2420           eesij=(el1+el2)
2421           ees=ees+eesij
2422           endif
2423           evdw1=evdw1+evdwij*sss
2424 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2425 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2426 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2427 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2428
2429           if (energy_dec) then
2430               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2431      &'evdw1',i,j,evdwij
2432      &,iteli,itelj,aaa,evdw1,sss
2433               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2434      &fac_shield(i),fac_shield(j)
2435           endif
2436
2437 C
2438 C Calculate contributions to the Cartesian gradient.
2439 C
2440 #ifdef SPLITELE
2441           facvdw=-6*rrmij*(ev1+evdwij)*sss
2442           facel=-3*rrmij*(el1+eesij)
2443           fac1=fac
2444           erij(1)=xj*rmij
2445           erij(2)=yj*rmij
2446           erij(3)=zj*rmij
2447
2448 *
2449 * Radial derivatives. First process both termini of the fragment (i,j)
2450 *
2451           if (calc_grad) then
2452           ggg(1)=facel*xj
2453           ggg(2)=facel*yj
2454           ggg(3)=facel*zj
2455           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2456      &  (shield_mode.gt.0)) then
2457 C          print *,i,j
2458           do ilist=1,ishield_list(i)
2459            iresshield=shield_list(ilist,i)
2460            do k=1,3
2461            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2462      &      *2.0
2463            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2464      &              rlocshield
2465      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2466             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2467 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2468 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2469 C             if (iresshield.gt.i) then
2470 C               do ishi=i+1,iresshield-1
2471 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2472 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2473 C
2474 C              enddo
2475 C             else
2476 C               do ishi=iresshield,i
2477 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2478 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2479 C
2480 C               enddo
2481 C              endif
2482            enddo
2483           enddo
2484           do ilist=1,ishield_list(j)
2485            iresshield=shield_list(ilist,j)
2486            do k=1,3
2487            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2488      &     *2.0
2489            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2490      &              rlocshield
2491      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2492            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2493
2494 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2495 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2496 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2497 C             if (iresshield.gt.j) then
2498 C               do ishi=j+1,iresshield-1
2499 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2500 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2501 C
2502 C               enddo
2503 C            else
2504 C               do ishi=iresshield,j
2505 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2506 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2507 C               enddo
2508 C              endif
2509            enddo
2510           enddo
2511
2512           do k=1,3
2513             gshieldc(k,i)=gshieldc(k,i)+
2514      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2515             gshieldc(k,j)=gshieldc(k,j)+
2516      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2517             gshieldc(k,i-1)=gshieldc(k,i-1)+
2518      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2519             gshieldc(k,j-1)=gshieldc(k,j-1)+
2520      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2521
2522            enddo
2523            endif
2524 c          do k=1,3
2525 c            ghalf=0.5D0*ggg(k)
2526 c            gelc(k,i)=gelc(k,i)+ghalf
2527 c            gelc(k,j)=gelc(k,j)+ghalf
2528 c          enddo
2529 c 9/28/08 AL Gradient compotents will be summed only at the end
2530 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2531           do k=1,3
2532             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2533 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2534             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2535 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2536 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2537 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2538 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2539 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2540           enddo
2541 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2542
2543 *
2544 * Loop over residues i+1 thru j-1.
2545 *
2546 cgrad          do k=i+1,j-1
2547 cgrad            do l=1,3
2548 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2549 cgrad            enddo
2550 cgrad          enddo
2551           if (sss.gt.0.0) then
2552           facvdw=facvdw+sssgrad*rmij*evdwij
2553           ggg(1)=facvdw*xj
2554           ggg(2)=facvdw*yj
2555           ggg(3)=facvdw*zj
2556           else
2557           ggg(1)=0.0
2558           ggg(2)=0.0
2559           ggg(3)=0.0
2560           endif
2561 c          do k=1,3
2562 c            ghalf=0.5D0*ggg(k)
2563 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2564 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2565 c          enddo
2566 c 9/28/08 AL Gradient compotents will be summed only at the end
2567           do k=1,3
2568             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2569             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2570           enddo
2571 *
2572 * Loop over residues i+1 thru j-1.
2573 *
2574 cgrad          do k=i+1,j-1
2575 cgrad            do l=1,3
2576 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2577 cgrad            enddo
2578 cgrad          enddo
2579           endif ! calc_grad
2580 #else
2581 C MARYSIA
2582           facvdw=(ev1+evdwij)
2583           facel=(el1+eesij)
2584           fac1=fac
2585           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2586      &       +(evdwij+eesij)*sssgrad*rrmij
2587           erij(1)=xj*rmij
2588           erij(2)=yj*rmij
2589           erij(3)=zj*rmij
2590 *
2591 * Radial derivatives. First process both termini of the fragment (i,j)
2592 *
2593           if (calc_grad) then
2594           ggg(1)=fac*xj
2595 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2596           ggg(2)=fac*yj
2597 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2598           ggg(3)=fac*zj
2599 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2600 c          do k=1,3
2601 c            ghalf=0.5D0*ggg(k)
2602 c            gelc(k,i)=gelc(k,i)+ghalf
2603 c            gelc(k,j)=gelc(k,j)+ghalf
2604 c          enddo
2605 c 9/28/08 AL Gradient compotents will be summed only at the end
2606           do k=1,3
2607             gelc_long(k,j)=gelc(k,j)+ggg(k)
2608             gelc_long(k,i)=gelc(k,i)-ggg(k)
2609           enddo
2610 *
2611 * Loop over residues i+1 thru j-1.
2612 *
2613 cgrad          do k=i+1,j-1
2614 cgrad            do l=1,3
2615 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2616 cgrad            enddo
2617 cgrad          enddo
2618 c 9/28/08 AL Gradient compotents will be summed only at the end
2619           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2620           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2621           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2622           do k=1,3
2623             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2624             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2625           enddo
2626           endif ! calc_grad
2627 #endif
2628 *
2629 * Angular part
2630 *
2631           if (calc_grad) then
2632           ecosa=2.0D0*fac3*fac1+fac4
2633           fac4=-3.0D0*fac4
2634           fac3=-6.0D0*fac3
2635           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2636           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2637           do k=1,3
2638             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2639             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2640           enddo
2641 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2642 cd   &          (dcosg(k),k=1,3)
2643           do k=1,3
2644             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2645      &      fac_shield(i)**2*fac_shield(j)**2
2646           enddo
2647 c          do k=1,3
2648 c            ghalf=0.5D0*ggg(k)
2649 c            gelc(k,i)=gelc(k,i)+ghalf
2650 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2651 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2652 c            gelc(k,j)=gelc(k,j)+ghalf
2653 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2654 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2655 c          enddo
2656 cgrad          do k=i+1,j-1
2657 cgrad            do l=1,3
2658 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2659 cgrad            enddo
2660 cgrad          enddo
2661 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2662           do k=1,3
2663             gelc(k,i)=gelc(k,i)
2664      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2665      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2666      &           *fac_shield(i)**2*fac_shield(j)**2
2667             gelc(k,j)=gelc(k,j)
2668      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2669      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2670      &           *fac_shield(i)**2*fac_shield(j)**2
2671             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2672             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2673           enddo
2674 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2675
2676 C MARYSIA
2677 c          endif !sscale
2678           endif ! calc_grad
2679           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2680      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2681      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2682 C
2683 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2684 C   energy of a peptide unit is assumed in the form of a second-order
2685 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2686 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2687 C   are computed for EVERY pair of non-contiguous peptide groups.
2688 C
2689
2690           if (j.lt.nres-1) then
2691             j1=j+1
2692             j2=j-1
2693           else
2694             j1=j-1
2695             j2=j-2
2696           endif
2697           kkk=0
2698           lll=0
2699           do k=1,2
2700             do l=1,2
2701               kkk=kkk+1
2702               muij(kkk)=mu(k,i)*mu(l,j)
2703 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2704 #ifdef NEWCORR
2705              if (calc_grad) then
2706              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2707 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2708              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2709              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2710 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2711              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2712              endif
2713 #endif
2714             enddo
2715           enddo
2716 #ifdef DEBUG
2717           write (iout,*) 'EELEC: i',i,' j',j
2718           write (iout,*) 'j',j,' j1',j1,' j2',j2
2719           write(iout,*) 'muij',muij
2720           write (iout,*) "uy",uy(:,i)
2721           write (iout,*) "uz",uz(:,j)
2722           write (iout,*) "erij",erij
2723 #endif
2724           ury=scalar(uy(1,i),erij)
2725           urz=scalar(uz(1,i),erij)
2726           vry=scalar(uy(1,j),erij)
2727           vrz=scalar(uz(1,j),erij)
2728           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2729           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2730           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2731           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2732           fac=dsqrt(-ael6i)*r3ij
2733           a22=a22*fac
2734           a23=a23*fac
2735           a32=a32*fac
2736           a33=a33*fac
2737 cd          write (iout,'(4i5,4f10.5)')
2738 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2739 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2740 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2741 cd     &      uy(:,j),uz(:,j)
2742 cd          write (iout,'(4f10.5)')
2743 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2744 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2745 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2746 cd           write (iout,'(9f10.5/)')
2747 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2748 C Derivatives of the elements of A in virtual-bond vectors
2749           if (calc_grad) then
2750           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2751           do k=1,3
2752             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2753             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2754             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2755             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2756             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2757             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2758             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2759             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2760             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2761             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2762             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2763             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2764           enddo
2765 C Compute radial contributions to the gradient
2766           facr=-3.0d0*rrmij
2767           a22der=a22*facr
2768           a23der=a23*facr
2769           a32der=a32*facr
2770           a33der=a33*facr
2771           agg(1,1)=a22der*xj
2772           agg(2,1)=a22der*yj
2773           agg(3,1)=a22der*zj
2774           agg(1,2)=a23der*xj
2775           agg(2,2)=a23der*yj
2776           agg(3,2)=a23der*zj
2777           agg(1,3)=a32der*xj
2778           agg(2,3)=a32der*yj
2779           agg(3,3)=a32der*zj
2780           agg(1,4)=a33der*xj
2781           agg(2,4)=a33der*yj
2782           agg(3,4)=a33der*zj
2783 C Add the contributions coming from er
2784           fac3=-3.0d0*fac
2785           do k=1,3
2786             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2787             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2788             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2789             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2790           enddo
2791           do k=1,3
2792 C Derivatives in DC(i)
2793 cgrad            ghalf1=0.5d0*agg(k,1)
2794 cgrad            ghalf2=0.5d0*agg(k,2)
2795 cgrad            ghalf3=0.5d0*agg(k,3)
2796 cgrad            ghalf4=0.5d0*agg(k,4)
2797             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2798      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2799             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2800      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2801             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2802      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2803             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2804      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2805 C Derivatives in DC(i+1)
2806             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2807      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2808             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2809      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2810             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2811      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2812             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2813      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2814 C Derivatives in DC(j)
2815             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2816      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2817             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2818      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2819             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2820      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2821             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2822      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2823 C Derivatives in DC(j+1) or DC(nres-1)
2824             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2825      &      -3.0d0*vryg(k,3)*ury)
2826             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2827      &      -3.0d0*vrzg(k,3)*ury)
2828             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2829      &      -3.0d0*vryg(k,3)*urz)
2830             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2831      &      -3.0d0*vrzg(k,3)*urz)
2832 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2833 cgrad              do l=1,4
2834 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2835 cgrad              enddo
2836 cgrad            endif
2837           enddo
2838           endif ! calc_grad
2839           acipa(1,1)=a22
2840           acipa(1,2)=a23
2841           acipa(2,1)=a32
2842           acipa(2,2)=a33
2843           a22=-a22
2844           a23=-a23
2845           if (calc_grad) then
2846           do l=1,2
2847             do k=1,3
2848               agg(k,l)=-agg(k,l)
2849               aggi(k,l)=-aggi(k,l)
2850               aggi1(k,l)=-aggi1(k,l)
2851               aggj(k,l)=-aggj(k,l)
2852               aggj1(k,l)=-aggj1(k,l)
2853             enddo
2854           enddo
2855           endif ! calc_grad
2856           if (j.lt.nres-1) then
2857             a22=-a22
2858             a32=-a32
2859             do l=1,3,2
2860               do k=1,3
2861                 agg(k,l)=-agg(k,l)
2862                 aggi(k,l)=-aggi(k,l)
2863                 aggi1(k,l)=-aggi1(k,l)
2864                 aggj(k,l)=-aggj(k,l)
2865                 aggj1(k,l)=-aggj1(k,l)
2866               enddo
2867             enddo
2868           else
2869             a22=-a22
2870             a23=-a23
2871             a32=-a32
2872             a33=-a33
2873             do l=1,4
2874               do k=1,3
2875                 agg(k,l)=-agg(k,l)
2876                 aggi(k,l)=-aggi(k,l)
2877                 aggi1(k,l)=-aggi1(k,l)
2878                 aggj(k,l)=-aggj(k,l)
2879                 aggj1(k,l)=-aggj1(k,l)
2880               enddo
2881             enddo
2882           endif
2883           ENDIF ! WCORR
2884           IF (wel_loc.gt.0.0d0) THEN
2885 C Contribution to the local-electrostatic energy coming from the i-j pair
2886           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2887      &     +a33*muij(4)
2888 #ifdef DEBUG
2889           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2890      &     " a33",a33
2891           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2892      &     " wel_loc",wel_loc
2893 #endif
2894           if (shield_mode.eq.0) then
2895            fac_shield(i)=1.0
2896            fac_shield(j)=1.0
2897 C          else
2898 C           fac_shield(i)=0.4
2899 C           fac_shield(j)=0.6
2900           endif
2901           eel_loc_ij=eel_loc_ij
2902      &    *fac_shield(i)*fac_shield(j)*sss
2903           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2904      &            'eelloc',i,j,eel_loc_ij
2905 c           if (eel_loc_ij.ne.0)
2906 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2907 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2908
2909           eel_loc=eel_loc+eel_loc_ij*sss
2910 C Now derivative over eel_loc
2911           if (calc_grad) then
2912           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2913      &  (shield_mode.gt.0)) then
2914 C          print *,i,j
2915
2916           do ilist=1,ishield_list(i)
2917            iresshield=shield_list(ilist,i)
2918            do k=1,3
2919            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2920      &                                          /fac_shield(i)
2921 C     &      *2.0
2922            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2923      &              rlocshield
2924      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2925             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2926      &      +rlocshield
2927            enddo
2928           enddo
2929           do ilist=1,ishield_list(j)
2930            iresshield=shield_list(ilist,j)
2931            do k=1,3
2932            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2933      &                                       /fac_shield(j)
2934 C     &     *2.0
2935            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2936      &              rlocshield
2937      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2938            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2939      &             +rlocshield
2940
2941            enddo
2942           enddo
2943
2944           do k=1,3
2945             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2946      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2947             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2948      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2949             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2950      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2951             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2952      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2953            enddo
2954            endif
2955
2956
2957 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
2958 c     &                     ' eel_loc_ij',eel_loc_ij
2959 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2960 C Calculate patrial derivative for theta angle
2961 #ifdef NEWCORR
2962          geel_loc_ij=(a22*gmuij1(1)
2963      &     +a23*gmuij1(2)
2964      &     +a32*gmuij1(3)
2965      &     +a33*gmuij1(4))
2966      &    *fac_shield(i)*fac_shield(j)*sss
2967 c         write(iout,*) "derivative over thatai"
2968 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
2969 c     &   a33*gmuij1(4)
2970          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
2971      &      geel_loc_ij*wel_loc
2972 c         write(iout,*) "derivative over thatai-1"
2973 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
2974 c     &   a33*gmuij2(4)
2975          geel_loc_ij=
2976      &     a22*gmuij2(1)
2977      &     +a23*gmuij2(2)
2978      &     +a32*gmuij2(3)
2979      &     +a33*gmuij2(4)
2980          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
2981      &      geel_loc_ij*wel_loc
2982      &    *fac_shield(i)*fac_shield(j)*sss
2983
2984 c  Derivative over j residue
2985          geel_loc_ji=a22*gmuji1(1)
2986      &     +a23*gmuji1(2)
2987      &     +a32*gmuji1(3)
2988      &     +a33*gmuji1(4)
2989 c         write(iout,*) "derivative over thataj"
2990 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
2991 c     &   a33*gmuji1(4)
2992
2993         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
2994      &      geel_loc_ji*wel_loc
2995      &    *fac_shield(i)*fac_shield(j)
2996
2997          geel_loc_ji=
2998      &     +a22*gmuji2(1)
2999      &     +a23*gmuji2(2)
3000      &     +a32*gmuji2(3)
3001      &     +a33*gmuji2(4)
3002 c         write(iout,*) "derivative over thataj-1"
3003 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3004 c     &   a33*gmuji2(4)
3005          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3006      &      geel_loc_ji*wel_loc
3007      &    *fac_shield(i)*fac_shield(j)*sss
3008 #endif
3009 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3010
3011 C Partial derivatives in virtual-bond dihedral angles gamma
3012           if (i.gt.1)
3013      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3014      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3015      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3016      &    *fac_shield(i)*fac_shield(j)
3017
3018           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3019      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3020      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3021      &    *fac_shield(i)*fac_shield(j)
3022 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3023           aux=eel_loc_ij/sss*sssgrad*rmij
3024           ggg(1)=aux*xj
3025           ggg(2)=aux*yj
3026           ggg(3)=aux*zj
3027           do l=1,3
3028             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3029      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3030      &    *fac_shield(i)*fac_shield(j)*sss
3031             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3032             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3033 cgrad            ghalf=0.5d0*ggg(l)
3034 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3035 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3036           enddo
3037 cgrad          do k=i+1,j2
3038 cgrad            do l=1,3
3039 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3040 cgrad            enddo
3041 cgrad          enddo
3042 C Remaining derivatives of eello
3043           do l=1,3
3044             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3045      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3046      &    *fac_shield(i)*fac_shield(j)
3047
3048             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3049      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3050      &    *fac_shield(i)*fac_shield(j)
3051
3052             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3053      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3054      &    *fac_shield(i)*fac_shield(j)
3055
3056             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3057      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3058      &    *fac_shield(i)*fac_shield(j)
3059
3060           enddo
3061           endif ! calc_grad
3062           ENDIF
3063
3064
3065 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3066 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3067 #ifdef FOURBODY
3068           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3069      &       .and. num_conti.le.maxconts) then
3070 c            write (iout,*) i,j," entered corr"
3071 C
3072 C Calculate the contact function. The ith column of the array JCONT will
3073 C contain the numbers of atoms that make contacts with the atom I (of numbers
3074 C greater than I). The arrays FACONT and GACONT will contain the values of
3075 C the contact function and its derivative.
3076 c           r0ij=1.02D0*rpp(iteli,itelj)
3077 c           r0ij=1.11D0*rpp(iteli,itelj)
3078             r0ij=2.20D0*rpp(iteli,itelj)
3079 c           r0ij=1.55D0*rpp(iteli,itelj)
3080             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3081             if (fcont.gt.0.0D0) then
3082               num_conti=num_conti+1
3083               if (num_conti.gt.maxconts) then
3084                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3085      &                         ' will skip next contacts for this conf.'
3086               else
3087                 jcont_hb(num_conti,i)=j
3088 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3089 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3090                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3091      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3092 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3093 C  terms.
3094                 d_cont(num_conti,i)=rij
3095 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3096 C     --- Electrostatic-interaction matrix ---
3097                 a_chuj(1,1,num_conti,i)=a22
3098                 a_chuj(1,2,num_conti,i)=a23
3099                 a_chuj(2,1,num_conti,i)=a32
3100                 a_chuj(2,2,num_conti,i)=a33
3101 C     --- Gradient of rij
3102                 if (calc_grad) then
3103                 do kkk=1,3
3104                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3105                 enddo
3106                 kkll=0
3107                 do k=1,2
3108                   do l=1,2
3109                     kkll=kkll+1
3110                     do m=1,3
3111                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3112                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3113                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3114                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3115                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3116                     enddo
3117                   enddo
3118                 enddo
3119                 endif ! calc_grad
3120                 ENDIF
3121                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3122 C Calculate contact energies
3123                 cosa4=4.0D0*cosa
3124                 wij=cosa-3.0D0*cosb*cosg
3125                 cosbg1=cosb+cosg
3126                 cosbg2=cosb-cosg
3127 c               fac3=dsqrt(-ael6i)/r0ij**3
3128                 fac3=dsqrt(-ael6i)*r3ij
3129 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3130                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3131                 if (ees0tmp.gt.0) then
3132                   ees0pij=dsqrt(ees0tmp)
3133                 else
3134                   ees0pij=0
3135                 endif
3136 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3137                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3138                 if (ees0tmp.gt.0) then
3139                   ees0mij=dsqrt(ees0tmp)
3140                 else
3141                   ees0mij=0
3142                 endif
3143 c               ees0mij=0.0D0
3144                 if (shield_mode.eq.0) then
3145                 fac_shield(i)=1.0d0
3146                 fac_shield(j)=1.0d0
3147                 else
3148                 ees0plist(num_conti,i)=j
3149 C                fac_shield(i)=0.4d0
3150 C                fac_shield(j)=0.6d0
3151                 endif
3152                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3153      &          *fac_shield(i)*fac_shield(j)
3154                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3155      &          *fac_shield(i)*fac_shield(j)
3156 C Diagnostics. Comment out or remove after debugging!
3157 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3158 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3159 c               ees0m(num_conti,i)=0.0D0
3160 C End diagnostics.
3161 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3162 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3163 C Angular derivatives of the contact function
3164
3165                 ees0pij1=fac3/ees0pij
3166                 ees0mij1=fac3/ees0mij
3167                 fac3p=-3.0D0*fac3*rrmij
3168                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3169                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3170 c               ees0mij1=0.0D0
3171                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3172                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3173                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3174                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3175                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3176                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3177                 ecosap=ecosa1+ecosa2
3178                 ecosbp=ecosb1+ecosb2
3179                 ecosgp=ecosg1+ecosg2
3180                 ecosam=ecosa1-ecosa2
3181                 ecosbm=ecosb1-ecosb2
3182                 ecosgm=ecosg1-ecosg2
3183 C Diagnostics
3184 c               ecosap=ecosa1
3185 c               ecosbp=ecosb1
3186 c               ecosgp=ecosg1
3187 c               ecosam=0.0D0
3188 c               ecosbm=0.0D0
3189 c               ecosgm=0.0D0
3190 C End diagnostics
3191                 facont_hb(num_conti,i)=fcont
3192
3193                 if (calc_grad) then
3194                 fprimcont=fprimcont/rij
3195 cd              facont_hb(num_conti,i)=1.0D0
3196 C Following line is for diagnostics.
3197 cd              fprimcont=0.0D0
3198                 do k=1,3
3199                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3200                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3201                 enddo
3202                 do k=1,3
3203                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3204                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3205                 enddo
3206                 gggp(1)=gggp(1)+ees0pijp*xj
3207      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3208                 gggp(2)=gggp(2)+ees0pijp*yj
3209      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3210                 gggp(3)=gggp(3)+ees0pijp*zj
3211      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3212                 gggm(1)=gggm(1)+ees0mijp*xj
3213      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3214                 gggm(2)=gggm(2)+ees0mijp*yj
3215      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3216                 gggm(3)=gggm(3)+ees0mijp*zj
3217      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3218 C Derivatives due to the contact function
3219                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3220                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3221                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3222                 do k=1,3
3223 c
3224 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3225 c          following the change of gradient-summation algorithm.
3226 c
3227 cgrad                  ghalfp=0.5D0*gggp(k)
3228 cgrad                  ghalfm=0.5D0*gggm(k)
3229                   gacontp_hb1(k,num_conti,i)=!ghalfp
3230      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3231      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3232      &          *fac_shield(i)*fac_shield(j)*sss
3233
3234                   gacontp_hb2(k,num_conti,i)=!ghalfp
3235      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3236      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3237      &          *fac_shield(i)*fac_shield(j)*sss
3238
3239                   gacontp_hb3(k,num_conti,i)=gggp(k)
3240      &          *fac_shield(i)*fac_shield(j)*sss
3241
3242                   gacontm_hb1(k,num_conti,i)=!ghalfm
3243      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3244      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3245      &          *fac_shield(i)*fac_shield(j)*sss
3246
3247                   gacontm_hb2(k,num_conti,i)=!ghalfm
3248      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3249      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3250      &          *fac_shield(i)*fac_shield(j)*sss
3251
3252                   gacontm_hb3(k,num_conti,i)=gggm(k)
3253      &          *fac_shield(i)*fac_shield(j)
3254 *sss
3255                 enddo
3256 C Diagnostics. Comment out or remove after debugging!
3257 cdiag           do k=1,3
3258 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3259 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3260 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3261 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3262 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3263 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3264 cdiag           enddo
3265
3266                  endif ! calc_grad
3267
3268               ENDIF ! wcorr
3269               endif  ! num_conti.le.maxconts
3270             endif  ! fcont.gt.0
3271           endif    ! j.gt.i+1
3272 #endif
3273           if (calc_grad) then
3274           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3275             do k=1,4
3276               do l=1,3
3277                 ghalf=0.5d0*agg(l,k)
3278                 aggi(l,k)=aggi(l,k)+ghalf
3279                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3280                 aggj(l,k)=aggj(l,k)+ghalf
3281               enddo
3282             enddo
3283             if (j.eq.nres-1 .and. i.lt.j-2) then
3284               do k=1,4
3285                 do l=1,3
3286                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3287                 enddo
3288               enddo
3289             endif
3290           endif
3291           endif ! calc_grad
3292 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3293       return
3294       end
3295 C-----------------------------------------------------------------------------
3296       subroutine eturn3(i,eello_turn3)
3297 C Third- and fourth-order contributions from turns
3298       implicit real*8 (a-h,o-z)
3299       include 'DIMENSIONS'
3300       include 'COMMON.IOUNITS'
3301       include 'COMMON.GEO'
3302       include 'COMMON.VAR'
3303       include 'COMMON.LOCAL'
3304       include 'COMMON.CHAIN'
3305       include 'COMMON.DERIV'
3306       include 'COMMON.INTERACT'
3307       include 'COMMON.CORRMAT'
3308       include 'COMMON.TORSION'
3309       include 'COMMON.VECTORS'
3310       include 'COMMON.FFIELD'
3311       include 'COMMON.CONTROL'
3312       include 'COMMON.SHIELD'
3313       dimension ggg(3)
3314       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3315      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3316      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3317      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3318      &  auxgmat2(2,2),auxgmatt2(2,2)
3319       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3320      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3321       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3322      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3323      &    num_conti,j1,j2
3324       j=i+2
3325 c      write (iout,*) "eturn3",i,j,j1,j2
3326       a_temp(1,1)=a22
3327       a_temp(1,2)=a23
3328       a_temp(2,1)=a32
3329       a_temp(2,2)=a33
3330 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3331 C
3332 C               Third-order contributions
3333 C
3334 C                 (i+2)o----(i+3)
3335 C                      | |
3336 C                      | |
3337 C                 (i+1)o----i
3338 C
3339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3340 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3341         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3342 c auxalary matices for theta gradient
3343 c auxalary matrix for i+1 and constant i+2
3344         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3345 c auxalary matrix for i+2 and constant i+1
3346         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3347         call transpose2(auxmat(1,1),auxmat1(1,1))
3348         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3349         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3350         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3351         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3352         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3353         if (shield_mode.eq.0) then
3354         fac_shield(i)=1.0
3355         fac_shield(j)=1.0
3356 C        else
3357 C        fac_shield(i)=0.4
3358 C        fac_shield(j)=0.6
3359         endif
3360         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3361      &  *fac_shield(i)*fac_shield(j)
3362         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3363      &  *fac_shield(i)*fac_shield(j)
3364         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3365      &    eello_t3
3366         if (calc_grad) then
3367 C#ifdef NEWCORR
3368 C Derivatives in theta
3369         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3370      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3371      &   *fac_shield(i)*fac_shield(j)
3372         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3373      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3374      &   *fac_shield(i)*fac_shield(j)
3375 C#endif
3376
3377 C Derivatives in shield mode
3378           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3379      &  (shield_mode.gt.0)) then
3380 C          print *,i,j
3381
3382           do ilist=1,ishield_list(i)
3383            iresshield=shield_list(ilist,i)
3384            do k=1,3
3385            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3386 C     &      *2.0
3387            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3388      &              rlocshield
3389      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3390             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3391      &      +rlocshield
3392            enddo
3393           enddo
3394           do ilist=1,ishield_list(j)
3395            iresshield=shield_list(ilist,j)
3396            do k=1,3
3397            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3398 C     &     *2.0
3399            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3400      &              rlocshield
3401      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3402            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3403      &             +rlocshield
3404
3405            enddo
3406           enddo
3407
3408           do k=1,3
3409             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3410      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3411             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3412      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3413             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3414      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3415             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3416      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3417            enddo
3418            endif
3419
3420 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3421 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3422 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3423 cd     &    ' eello_turn3_num',4*eello_turn3_num
3424 C Derivatives in gamma(i)
3425         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3426         call transpose2(auxmat2(1,1),auxmat3(1,1))
3427         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3428         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3429      &   *fac_shield(i)*fac_shield(j)
3430 C Derivatives in gamma(i+1)
3431         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3432         call transpose2(auxmat2(1,1),auxmat3(1,1))
3433         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3434         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3435      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3436      &   *fac_shield(i)*fac_shield(j)
3437 C Cartesian derivatives
3438         do l=1,3
3439 c            ghalf1=0.5d0*agg(l,1)
3440 c            ghalf2=0.5d0*agg(l,2)
3441 c            ghalf3=0.5d0*agg(l,3)
3442 c            ghalf4=0.5d0*agg(l,4)
3443           a_temp(1,1)=aggi(l,1)!+ghalf1
3444           a_temp(1,2)=aggi(l,2)!+ghalf2
3445           a_temp(2,1)=aggi(l,3)!+ghalf3
3446           a_temp(2,2)=aggi(l,4)!+ghalf4
3447           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3448           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3449      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3450      &   *fac_shield(i)*fac_shield(j)
3451
3452           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3453           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3454           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3455           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3456           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3457           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3458      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3459      &   *fac_shield(i)*fac_shield(j)
3460           a_temp(1,1)=aggj(l,1)!+ghalf1
3461           a_temp(1,2)=aggj(l,2)!+ghalf2
3462           a_temp(2,1)=aggj(l,3)!+ghalf3
3463           a_temp(2,2)=aggj(l,4)!+ghalf4
3464           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3465           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3466      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3467      &   *fac_shield(i)*fac_shield(j)
3468           a_temp(1,1)=aggj1(l,1)
3469           a_temp(1,2)=aggj1(l,2)
3470           a_temp(2,1)=aggj1(l,3)
3471           a_temp(2,2)=aggj1(l,4)
3472           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3473           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3474      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3475      &   *fac_shield(i)*fac_shield(j)
3476         enddo
3477
3478         endif ! calc_grad
3479
3480       return
3481       end
3482 C-------------------------------------------------------------------------------
3483       subroutine eturn4(i,eello_turn4)
3484 C Third- and fourth-order contributions from turns
3485       implicit real*8 (a-h,o-z)
3486       include 'DIMENSIONS'
3487       include 'COMMON.IOUNITS'
3488       include 'COMMON.GEO'
3489       include 'COMMON.VAR'
3490       include 'COMMON.LOCAL'
3491       include 'COMMON.CHAIN'
3492       include 'COMMON.DERIV'
3493       include 'COMMON.INTERACT'
3494       include 'COMMON.CORRMAT'
3495       include 'COMMON.TORSION'
3496       include 'COMMON.VECTORS'
3497       include 'COMMON.FFIELD'
3498       include 'COMMON.CONTROL'
3499       include 'COMMON.SHIELD'
3500       dimension ggg(3)
3501       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3502      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3503      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3504      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3505      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3506      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3507      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3508       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3509      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3510       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3511      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3512      &    num_conti,j1,j2
3513       j=i+3
3514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3515 C
3516 C               Fourth-order contributions
3517 C
3518 C                 (i+3)o----(i+4)
3519 C                     /  |
3520 C               (i+2)o   |
3521 C                     \  |
3522 C                 (i+1)o----i
3523 C
3524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3525 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3526 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3527 c        write(iout,*)"WCHODZE W PROGRAM"
3528         a_temp(1,1)=a22
3529         a_temp(1,2)=a23
3530         a_temp(2,1)=a32
3531         a_temp(2,2)=a33
3532         iti1=itype2loc(itype(i+1))
3533         iti2=itype2loc(itype(i+2))
3534         iti3=itype2loc(itype(i+3))
3535 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3536         call transpose2(EUg(1,1,i+1),e1t(1,1))
3537         call transpose2(Eug(1,1,i+2),e2t(1,1))
3538         call transpose2(Eug(1,1,i+3),e3t(1,1))
3539 C Ematrix derivative in theta
3540         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3541         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3542         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3543         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3544 c       eta1 in derivative theta
3545         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3546         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3547 c       auxgvec is derivative of Ub2 so i+3 theta
3548         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3549 c       auxalary matrix of E i+1
3550         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3551 c        s1=0.0
3552 c        gs1=0.0
3553         s1=scalar2(b1(1,i+2),auxvec(1))
3554 c derivative of theta i+2 with constant i+3
3555         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3556 c derivative of theta i+2 with constant i+2
3557         gs32=scalar2(b1(1,i+2),auxgvec(1))
3558 c derivative of E matix in theta of i+1
3559         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3560
3561         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3562 c       ea31 in derivative theta
3563         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3564         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3565 c auxilary matrix auxgvec of Ub2 with constant E matirx
3566         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3567 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3568         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3569
3570 c        s2=0.0
3571 c        gs2=0.0
3572         s2=scalar2(b1(1,i+1),auxvec(1))
3573 c derivative of theta i+1 with constant i+3
3574         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3575 c derivative of theta i+2 with constant i+1
3576         gs21=scalar2(b1(1,i+1),auxgvec(1))
3577 c derivative of theta i+3 with constant i+1
3578         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3579 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3580 c     &  gtb1(1,i+1)
3581         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3582 c two derivatives over diffetent matrices
3583 c gtae3e2 is derivative over i+3
3584         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3585 c ae3gte2 is derivative over i+2
3586         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3587         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3588 c three possible derivative over theta E matices
3589 c i+1
3590         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3591 c i+2
3592         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3593 c i+3
3594         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3595         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3596
3597         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3598         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3599         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3600         if (shield_mode.eq.0) then
3601         fac_shield(i)=1.0
3602         fac_shield(j)=1.0
3603 C        else
3604 C        fac_shield(i)=0.6
3605 C        fac_shield(j)=0.4
3606         endif
3607         eello_turn4=eello_turn4-(s1+s2+s3)
3608      &  *fac_shield(i)*fac_shield(j)
3609         eello_t4=-(s1+s2+s3)
3610      &  *fac_shield(i)*fac_shield(j)
3611 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3612         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3613      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3614 C Now derivative over shield:
3615           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3616      &  (shield_mode.gt.0)) then
3617 C          print *,i,j
3618
3619           do ilist=1,ishield_list(i)
3620            iresshield=shield_list(ilist,i)
3621            do k=1,3
3622            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3623 C     &      *2.0
3624            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3625      &              rlocshield
3626      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3627             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3628      &      +rlocshield
3629            enddo
3630           enddo
3631           do ilist=1,ishield_list(j)
3632            iresshield=shield_list(ilist,j)
3633            do k=1,3
3634            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3635 C     &     *2.0
3636            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3637      &              rlocshield
3638      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3639            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3640      &             +rlocshield
3641
3642            enddo
3643           enddo
3644
3645           do k=1,3
3646             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3647      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3648             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3649      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3650             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3651      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3652             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3653      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3654            enddo
3655            endif
3656 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3657 cd     &    ' eello_turn4_num',8*eello_turn4_num
3658 #ifdef NEWCORR
3659         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3660      &                  -(gs13+gsE13+gsEE1)*wturn4
3661      &  *fac_shield(i)*fac_shield(j)
3662         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3663      &                    -(gs23+gs21+gsEE2)*wturn4
3664      &  *fac_shield(i)*fac_shield(j)
3665
3666         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3667      &                    -(gs32+gsE31+gsEE3)*wturn4
3668      &  *fac_shield(i)*fac_shield(j)
3669
3670 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3671 c     &   gs2
3672 #endif
3673         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3674      &      'eturn4',i,j,-(s1+s2+s3)
3675 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3676 c     &    ' eello_turn4_num',8*eello_turn4_num
3677 C Derivatives in gamma(i)
3678         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3679         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3680         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3681         s1=scalar2(b1(1,i+2),auxvec(1))
3682         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3683         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3684         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3685      &  *fac_shield(i)*fac_shield(j)
3686 C Derivatives in gamma(i+1)
3687         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3688         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3689         s2=scalar2(b1(1,i+1),auxvec(1))
3690         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3691         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3692         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3693         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3694      &  *fac_shield(i)*fac_shield(j)
3695 C Derivatives in gamma(i+2)
3696         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3697         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3698         s1=scalar2(b1(1,i+2),auxvec(1))
3699         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3700         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3701         s2=scalar2(b1(1,i+1),auxvec(1))
3702         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3703         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3704         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3705         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3706      &  *fac_shield(i)*fac_shield(j)
3707         if (calc_grad) then
3708 C Cartesian derivatives
3709 C Derivatives of this turn contributions in DC(i+2)
3710         if (j.lt.nres-1) then
3711           do l=1,3
3712             a_temp(1,1)=agg(l,1)
3713             a_temp(1,2)=agg(l,2)
3714             a_temp(2,1)=agg(l,3)
3715             a_temp(2,2)=agg(l,4)
3716             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3717             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3718             s1=scalar2(b1(1,i+2),auxvec(1))
3719             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3720             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3721             s2=scalar2(b1(1,i+1),auxvec(1))
3722             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3723             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3724             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3725             ggg(l)=-(s1+s2+s3)
3726             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3727      &  *fac_shield(i)*fac_shield(j)
3728           enddo
3729         endif
3730 C Remaining derivatives of this turn contribution
3731         do l=1,3
3732           a_temp(1,1)=aggi(l,1)
3733           a_temp(1,2)=aggi(l,2)
3734           a_temp(2,1)=aggi(l,3)
3735           a_temp(2,2)=aggi(l,4)
3736           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3737           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3738           s1=scalar2(b1(1,i+2),auxvec(1))
3739           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3740           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3741           s2=scalar2(b1(1,i+1),auxvec(1))
3742           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3743           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3744           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3745           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3746      &  *fac_shield(i)*fac_shield(j)
3747           a_temp(1,1)=aggi1(l,1)
3748           a_temp(1,2)=aggi1(l,2)
3749           a_temp(2,1)=aggi1(l,3)
3750           a_temp(2,2)=aggi1(l,4)
3751           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3752           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3753           s1=scalar2(b1(1,i+2),auxvec(1))
3754           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3755           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3756           s2=scalar2(b1(1,i+1),auxvec(1))
3757           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3758           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3759           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3760           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3761      &  *fac_shield(i)*fac_shield(j)
3762           a_temp(1,1)=aggj(l,1)
3763           a_temp(1,2)=aggj(l,2)
3764           a_temp(2,1)=aggj(l,3)
3765           a_temp(2,2)=aggj(l,4)
3766           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3767           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3768           s1=scalar2(b1(1,i+2),auxvec(1))
3769           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3770           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3771           s2=scalar2(b1(1,i+1),auxvec(1))
3772           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3773           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3774           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3775           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3776      &  *fac_shield(i)*fac_shield(j)
3777           a_temp(1,1)=aggj1(l,1)
3778           a_temp(1,2)=aggj1(l,2)
3779           a_temp(2,1)=aggj1(l,3)
3780           a_temp(2,2)=aggj1(l,4)
3781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3783           s1=scalar2(b1(1,i+2),auxvec(1))
3784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3786           s2=scalar2(b1(1,i+1),auxvec(1))
3787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3791           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3792      &  *fac_shield(i)*fac_shield(j)
3793         enddo
3794
3795         endif ! calc_grad
3796
3797       return
3798       end
3799 C-----------------------------------------------------------------------------
3800       subroutine vecpr(u,v,w)
3801       implicit real*8(a-h,o-z)
3802       dimension u(3),v(3),w(3)
3803       w(1)=u(2)*v(3)-u(3)*v(2)
3804       w(2)=-u(1)*v(3)+u(3)*v(1)
3805       w(3)=u(1)*v(2)-u(2)*v(1)
3806       return
3807       end
3808 C-----------------------------------------------------------------------------
3809       subroutine unormderiv(u,ugrad,unorm,ungrad)
3810 C This subroutine computes the derivatives of a normalized vector u, given
3811 C the derivatives computed without normalization conditions, ugrad. Returns
3812 C ungrad.
3813       implicit none
3814       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3815       double precision vec(3)
3816       double precision scalar
3817       integer i,j
3818 c      write (2,*) 'ugrad',ugrad
3819 c      write (2,*) 'u',u
3820       do i=1,3
3821         vec(i)=scalar(ugrad(1,i),u(1))
3822       enddo
3823 c      write (2,*) 'vec',vec
3824       do i=1,3
3825         do j=1,3
3826           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3827         enddo
3828       enddo
3829 c      write (2,*) 'ungrad',ungrad
3830       return
3831       end
3832 C-----------------------------------------------------------------------------
3833       subroutine escp(evdw2,evdw2_14)
3834 C
3835 C This subroutine calculates the excluded-volume interaction energy between
3836 C peptide-group centers and side chains and its gradient in virtual-bond and
3837 C side-chain vectors.
3838 C
3839       implicit real*8 (a-h,o-z)
3840       include 'DIMENSIONS'
3841       include 'COMMON.GEO'
3842       include 'COMMON.VAR'
3843       include 'COMMON.LOCAL'
3844       include 'COMMON.CHAIN'
3845       include 'COMMON.DERIV'
3846       include 'COMMON.INTERACT'
3847       include 'COMMON.FFIELD'
3848       include 'COMMON.IOUNITS'
3849       dimension ggg(3)
3850       evdw2=0.0D0
3851       evdw2_14=0.0d0
3852 cd    print '(a)','Enter ESCP'
3853 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3854 c     &  ' scal14',scal14
3855       do i=iatscp_s,iatscp_e
3856         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3857         iteli=itel(i)
3858 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3859 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3860         if (iteli.eq.0) goto 1225
3861         xi=0.5D0*(c(1,i)+c(1,i+1))
3862         yi=0.5D0*(c(2,i)+c(2,i+1))
3863         zi=0.5D0*(c(3,i)+c(3,i+1))
3864 C Returning the ith atom to box
3865         call to_box(xi,yi,zi)
3866         do iint=1,nscp_gr(i)
3867
3868         do j=iscpstart(i,iint),iscpend(i,iint)
3869           itypj=iabs(itype(j))
3870           if (itypj.eq.ntyp1) cycle
3871 C Uncomment following three lines for SC-p interactions
3872 c         xj=c(1,nres+j)-xi
3873 c         yj=c(2,nres+j)-yi
3874 c         zj=c(3,nres+j)-zi
3875 C Uncomment following three lines for Ca-p interactions
3876           xj=c(1,j)
3877           yj=c(2,j)
3878           zj=c(3,j)
3879 C returning the jth atom to box
3880           call to_box(xj,yj,zj)
3881           xj=boxshift(xj-xi,boxxsize)
3882           yj=boxshift(yj-yi,boxysize)
3883           zj=boxshift(zj-zi,boxzsize)
3884           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3885 C sss is scaling function for smoothing the cutoff gradient otherwise
3886 C the gradient would not be continuouse
3887           sss=sscale(1.0d0/(dsqrt(rrij)))
3888           if (sss.le.0.0d0) cycle
3889           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3890           fac=rrij**expon2
3891           e1=fac*fac*aad(itypj,iteli)
3892           e2=fac*bad(itypj,iteli)
3893           if (iabs(j-i) .le. 2) then
3894             e1=scal14*e1
3895             e2=scal14*e2
3896             evdw2_14=evdw2_14+(e1+e2)*sss
3897           endif
3898           evdwij=e1+e2
3899 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3900 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3901 c     &       bad(itypj,iteli)
3902           evdw2=evdw2+evdwij*sss
3903           if (calc_grad) then
3904 C
3905 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3906 C
3907           fac=-(evdwij+e1)*rrij*sss
3908           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3909           ggg(1)=xj*fac
3910           ggg(2)=yj*fac
3911           ggg(3)=zj*fac
3912           if (j.lt.i) then
3913 cd          write (iout,*) 'j<i'
3914 C Uncomment following three lines for SC-p interactions
3915 c           do k=1,3
3916 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3917 c           enddo
3918           else
3919 cd          write (iout,*) 'j>i'
3920             do k=1,3
3921               ggg(k)=-ggg(k)
3922 C Uncomment following line for SC-p interactions
3923 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3924             enddo
3925           endif
3926           do k=1,3
3927             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3928           enddo
3929           kstart=min0(i+1,j)
3930           kend=max0(i-1,j-1)
3931 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3932 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3933           do k=kstart,kend
3934             do l=1,3
3935               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3936             enddo
3937           enddo
3938           endif ! calc_grad
3939         enddo
3940         enddo ! iint
3941  1225   continue
3942       enddo ! i
3943       do i=1,nct
3944         do j=1,3
3945           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3946           gradx_scp(j,i)=expon*gradx_scp(j,i)
3947         enddo
3948       enddo
3949 C******************************************************************************
3950 C
3951 C                              N O T E !!!
3952 C
3953 C To save time the factor EXPON has been extracted from ALL components
3954 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3955 C use!
3956 C
3957 C******************************************************************************
3958       return
3959       end
3960 C--------------------------------------------------------------------------
3961       subroutine edis(ehpb)
3962 C
3963 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3964 C
3965       implicit real*8 (a-h,o-z)
3966       include 'DIMENSIONS'
3967       include 'COMMON.SBRIDGE'
3968       include 'COMMON.CHAIN'
3969       include 'COMMON.DERIV'
3970       include 'COMMON.VAR'
3971       include 'COMMON.INTERACT'
3972       include 'COMMON.CONTROL'
3973       include 'COMMON.IOUNITS'
3974       dimension ggg(3),ggg_peak(3,1000)
3975       ehpb=0.0D0
3976       ggg=0.0d0
3977 c 8/21/18 AL: added explicit restraints on reference coords
3978 c      write (iout,*) "restr_on_coord",restr_on_coord
3979       if (restr_on_coord) then
3980
3981       do i=nnt,nct
3982         ecoor=0.0d0
3983         if (itype(i).eq.ntyp1) cycle
3984         do j=1,3
3985           ecoor=ecoor+(c(j,i)-cref(j,i))**2
3986           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
3987         enddo
3988         if (itype(i).ne.10) then
3989           do j=1,3
3990             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
3991             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
3992           enddo
3993         endif
3994         if (energy_dec) write (iout,*)
3995      &     "i",i," bfac",bfac(i)," ecoor",ecoor
3996         ehpb=ehpb+0.5d0*bfac(i)*ecoor
3997       enddo
3998
3999       endif
4000 C      write (iout,*) ,"link_end",link_end,constr_dist
4001 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4002 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4003 c     &  " constr_dist",constr_dist
4004       if (link_end.eq.0.and.link_end_peak.eq.0) return
4005       do i=link_start_peak,link_end_peak
4006         ehpb_peak=0.0d0
4007 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4008 c     &   ipeak(1,i),ipeak(2,i)
4009         do ip=ipeak(1,i),ipeak(2,i)
4010           ii=ihpb_peak(ip)
4011           jj=jhpb_peak(ip)
4012           dd=dist(ii,jj)
4013           iip=ip-ipeak(1,i)+1
4014 C iii and jjj point to the residues for which the distance is assigned.
4015 c          if (ii.gt.nres) then
4016 c            iii=ii-nres
4017 c            jjj=jj-nres
4018 c          else
4019 c            iii=ii
4020 c            jjj=jj
4021 c          endif
4022           if (ii.gt.nres) then
4023             iii=ii-nres
4024           else
4025             iii=ii
4026           endif
4027           if (jj.gt.nres) then
4028             jjj=jj-nres
4029           else
4030             jjj=jj
4031           endif
4032           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4033           aux=dexp(-scal_peak*aux)
4034           ehpb_peak=ehpb_peak+aux
4035           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4036      &      forcon_peak(ip))*aux/dd
4037           do j=1,3
4038             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4039           enddo
4040           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4041      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4042      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4043         enddo
4044 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4045         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4046         do ip=ipeak(1,i),ipeak(2,i)
4047           iip=ip-ipeak(1,i)+1
4048           do j=1,3
4049             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4050           enddo
4051           ii=ihpb_peak(ip)
4052           jj=jhpb_peak(ip)
4053 C iii and jjj point to the residues for which the distance is assigned.
4054 c          if (ii.gt.nres) then
4055 c            iii=ii-nres
4056 c            jjj=jj-nres
4057 c          else
4058 c            iii=ii
4059 c            jjj=jj
4060 c          endif
4061           if (ii.gt.nres) then
4062             iii=ii-nres
4063           else
4064             iii=ii
4065           endif
4066           if (jj.gt.nres) then
4067             jjj=jj-nres
4068           else
4069             jjj=jj
4070           endif
4071           if (iii.lt.ii) then
4072             do j=1,3
4073               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4074             enddo
4075           endif
4076           if (jjj.lt.jj) then
4077             do j=1,3
4078               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4079             enddo
4080           endif
4081           do k=1,3
4082             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4083             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4084           enddo
4085         enddo
4086       enddo
4087       do i=link_start,link_end
4088 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4089 C CA-CA distance used in regularization of structure.
4090         ii=ihpb(i)
4091         jj=jhpb(i)
4092 C iii and jjj point to the residues for which the distance is assigned.
4093 c        if (ii.gt.nres) then
4094 c          iii=ii-nres
4095 c          jjj=jj-nres
4096 c        else
4097 c          iii=ii
4098 c          jjj=jj
4099 c        endif
4100         if (ii.gt.nres) then
4101           iii=ii-nres
4102         else
4103           iii=ii
4104         endif
4105         if (jj.gt.nres) then
4106           jjj=jj-nres
4107         else
4108           jjj=jj
4109         endif
4110 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4111 c     &    dhpb(i),dhpb1(i),forcon(i)
4112 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4113 C    distance and angle dependent SS bond potential.
4114 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4115 C     & iabs(itype(jjj)).eq.1) then
4116 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4117 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4118         if (.not.dyn_ss .and. i.le.nss) then
4119 C 15/02/13 CC dynamic SSbond - additional check
4120           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4121      &        iabs(itype(jjj)).eq.1) then
4122            call ssbond_ene(iii,jjj,eij)
4123            ehpb=ehpb+2*eij
4124          endif
4125 cd          write (iout,*) "eij",eij
4126 cd   &   ' waga=',waga,' fac=',fac
4127 !        else if (ii.gt.nres .and. jj.gt.nres) then
4128         else
4129 C Calculate the distance between the two points and its difference from the
4130 C target distance.
4131           dd=dist(ii,jj)
4132           if (irestr_type(i).eq.11) then
4133             ehpb=ehpb+fordepth(i)!**4.0d0
4134      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4135             fac=fordepth(i)!**4.0d0
4136      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4137             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4138      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4139      &        ehpb,irestr_type(i)
4140           else if (irestr_type(i).eq.10) then
4141 c AL 6//19/2018 cross-link restraints
4142             xdis = 0.5d0*(dd/forcon(i))**2
4143             expdis = dexp(-xdis)
4144 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4145             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4146 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4147 c     &          " wboltzd",wboltzd
4148             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4149 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4150             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4151      &           *expdis/(aux*forcon(i)**2)
4152             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4153      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4154      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4155           else if (irestr_type(i).eq.2) then
4156 c Quartic restraints
4157             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4158             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4159      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4160      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4161             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4162           else
4163 c Quadratic restraints
4164             rdis=dd-dhpb(i)
4165 C Get the force constant corresponding to this distance.
4166             waga=forcon(i)
4167 C Calculate the contribution to energy.
4168             ehpb=ehpb+0.5d0*waga*rdis*rdis
4169             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4170      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4171      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4172 C
4173 C Evaluate gradient.
4174 C
4175             fac=waga*rdis/dd
4176           endif
4177 c Calculate Cartesian gradient
4178           do j=1,3
4179             ggg(j)=fac*(c(j,jj)-c(j,ii))
4180           enddo
4181 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4182 C If this is a SC-SC distance, we need to calculate the contributions to the
4183 C Cartesian gradient in the SC vectors (ghpbx).
4184           if (iii.lt.ii) then
4185             do j=1,3
4186               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4187             enddo
4188           endif
4189           if (jjj.lt.jj) then
4190             do j=1,3
4191               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4192             enddo
4193           endif
4194           do k=1,3
4195             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4196             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4197           enddo
4198         endif
4199       enddo
4200       return
4201       end
4202 C--------------------------------------------------------------------------
4203       subroutine ssbond_ene(i,j,eij)
4204 C
4205 C Calculate the distance and angle dependent SS-bond potential energy
4206 C using a free-energy function derived based on RHF/6-31G** ab initio
4207 C calculations of diethyl disulfide.
4208 C
4209 C A. Liwo and U. Kozlowska, 11/24/03
4210 C
4211       implicit real*8 (a-h,o-z)
4212       include 'DIMENSIONS'
4213       include 'COMMON.SBRIDGE'
4214       include 'COMMON.CHAIN'
4215       include 'COMMON.DERIV'
4216       include 'COMMON.LOCAL'
4217       include 'COMMON.INTERACT'
4218       include 'COMMON.VAR'
4219       include 'COMMON.IOUNITS'
4220       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4221       itypi=iabs(itype(i))
4222       xi=c(1,nres+i)
4223       yi=c(2,nres+i)
4224       zi=c(3,nres+i)
4225       dxi=dc_norm(1,nres+i)
4226       dyi=dc_norm(2,nres+i)
4227       dzi=dc_norm(3,nres+i)
4228       dsci_inv=dsc_inv(itypi)
4229       itypj=iabs(itype(j))
4230       dscj_inv=dsc_inv(itypj)
4231       xj=c(1,nres+j)-xi
4232       yj=c(2,nres+j)-yi
4233       zj=c(3,nres+j)-zi
4234       dxj=dc_norm(1,nres+j)
4235       dyj=dc_norm(2,nres+j)
4236       dzj=dc_norm(3,nres+j)
4237       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4238       rij=dsqrt(rrij)
4239       erij(1)=xj*rij
4240       erij(2)=yj*rij
4241       erij(3)=zj*rij
4242       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4243       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4244       om12=dxi*dxj+dyi*dyj+dzi*dzj
4245       do k=1,3
4246         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4247         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4248       enddo
4249       rij=1.0d0/rij
4250       deltad=rij-d0cm
4251       deltat1=1.0d0-om1
4252       deltat2=1.0d0+om2
4253       deltat12=om2-om1+2.0d0
4254       cosphi=om12-om1*om2
4255       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4256      &  +akct*deltad*deltat12
4257      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4258 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4259 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4260 c     &  " deltat12",deltat12," eij",eij
4261       ed=2*akcm*deltad+akct*deltat12
4262       pom1=akct*deltad
4263       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4264       eom1=-2*akth*deltat1-pom1-om2*pom2
4265       eom2= 2*akth*deltat2+pom1-om1*pom2
4266       eom12=pom2
4267       do k=1,3
4268         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4269       enddo
4270       do k=1,3
4271         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4272      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4273         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4274      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4275       enddo
4276 C
4277 C Calculate the components of the gradient in DC and X
4278 C
4279       do k=i,j-1
4280         do l=1,3
4281           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4282         enddo
4283       enddo
4284       return
4285       end
4286 C--------------------------------------------------------------------------
4287       subroutine ebond(estr)
4288 c
4289 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4290 c
4291       implicit real*8 (a-h,o-z)
4292       include 'DIMENSIONS'
4293       include 'COMMON.LOCAL'
4294       include 'COMMON.GEO'
4295       include 'COMMON.INTERACT'
4296       include 'COMMON.DERIV'
4297       include 'COMMON.VAR'
4298       include 'COMMON.CHAIN'
4299       include 'COMMON.IOUNITS'
4300       include 'COMMON.NAMES'
4301       include 'COMMON.FFIELD'
4302       include 'COMMON.CONTROL'
4303       double precision u(3),ud(3)
4304       estr=0.0d0
4305       estr1=0.0d0
4306 c      write (iout,*) "distchainmax",distchainmax
4307       do i=nnt+1,nct
4308 #ifdef FIVEDIAG
4309         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4310         diff = vbld(i)-vbldp0
4311 #else
4312         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4313 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4314 C          do j=1,3
4315 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4316 C     &      *dc(j,i-1)/vbld(i)
4317 C          enddo
4318 C          if (energy_dec) write(iout,*)
4319 C     &       "estr1",i,vbld(i),distchainmax,
4320 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4321 C        else
4322          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4323         diff = vbld(i)-vbldpDUM
4324 C         write(iout,*) i,diff
4325          else
4326           diff = vbld(i)-vbldp0
4327 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4328          endif
4329 #endif
4330         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4331      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4332           estr=estr+diff*diff
4333           do j=1,3
4334             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4335           enddo
4336 C        endif
4337 C        write (iout,'(a7,i5,4f7.3)')
4338 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4339       enddo
4340       estr=0.5d0*AKP*estr+estr1
4341 c
4342 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4343 c
4344       do i=nnt,nct
4345         iti=iabs(itype(i))
4346         if (iti.ne.10 .and. iti.ne.ntyp1) then
4347           nbi=nbondterm(iti)
4348           if (nbi.eq.1) then
4349             diff=vbld(i+nres)-vbldsc0(1,iti)
4350             if (energy_dec) write (iout,*)
4351      &      i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4352      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4353             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4354             do j=1,3
4355               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4356             enddo
4357           else
4358             do j=1,nbi
4359               diff=vbld(i+nres)-vbldsc0(j,iti)
4360               ud(j)=aksc(j,iti)*diff
4361               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4362             enddo
4363             uprod=u(1)
4364             do j=2,nbi
4365               uprod=uprod*u(j)
4366             enddo
4367             usum=0.0d0
4368             usumsqder=0.0d0
4369             do j=1,nbi
4370               uprod1=1.0d0
4371               uprod2=1.0d0
4372               do k=1,nbi
4373                 if (k.ne.j) then
4374                   uprod1=uprod1*u(k)
4375                   uprod2=uprod2*u(k)*u(k)
4376                 endif
4377               enddo
4378               usum=usum+uprod1
4379               usumsqder=usumsqder+ud(j)*uprod2
4380             enddo
4381 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4382 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4383             estr=estr+uprod/usum
4384             do j=1,3
4385              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4386             enddo
4387           endif
4388         endif
4389       enddo
4390       return
4391       end
4392 #ifdef CRYST_THETA
4393 C--------------------------------------------------------------------------
4394       subroutine ebend(etheta,ethetacnstr)
4395 C
4396 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4397 C angles gamma and its derivatives in consecutive thetas and gammas.
4398 C
4399       implicit real*8 (a-h,o-z)
4400       include 'DIMENSIONS'
4401       include 'COMMON.LOCAL'
4402       include 'COMMON.GEO'
4403       include 'COMMON.INTERACT'
4404       include 'COMMON.DERIV'
4405       include 'COMMON.VAR'
4406       include 'COMMON.CHAIN'
4407       include 'COMMON.IOUNITS'
4408       include 'COMMON.NAMES'
4409       include 'COMMON.FFIELD'
4410       include 'COMMON.TORCNSTR'
4411       common /calcthet/ term1,term2,termm,diffak,ratak,
4412      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4413      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4414       double precision y(2),z(2)
4415       delta=0.02d0*pi
4416 c      time11=dexp(-2*time)
4417 c      time12=1.0d0
4418       etheta=0.0D0
4419 c      write (iout,*) "nres",nres
4420 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4421 c      write (iout,*) ithet_start,ithet_end
4422       do i=ithet_start,ithet_end
4423 C        if (itype(i-1).eq.ntyp1) cycle
4424         if (i.le.2) cycle
4425         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4426      &  .or.itype(i).eq.ntyp1) cycle
4427 C Zero the energy function and its derivative at 0 or pi.
4428         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4429         it=itype(i-1)
4430         ichir1=isign(1,itype(i-2))
4431         ichir2=isign(1,itype(i))
4432          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4433          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4434          if (itype(i-1).eq.10) then
4435           itype1=isign(10,itype(i-2))
4436           ichir11=isign(1,itype(i-2))
4437           ichir12=isign(1,itype(i-2))
4438           itype2=isign(10,itype(i))
4439           ichir21=isign(1,itype(i))
4440           ichir22=isign(1,itype(i))
4441          endif
4442          if (i.eq.3) then
4443           y(1)=0.0D0
4444           y(2)=0.0D0
4445           else
4446
4447         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4448 #ifdef OSF
4449           phii=phi(i)
4450 c          icrc=0
4451 c          call proc_proc(phii,icrc)
4452           if (icrc.eq.1) phii=150.0
4453 #else
4454           phii=phi(i)
4455 #endif
4456           y(1)=dcos(phii)
4457           y(2)=dsin(phii)
4458         else
4459           y(1)=0.0D0
4460           y(2)=0.0D0
4461         endif
4462         endif
4463         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4464 #ifdef OSF
4465           phii1=phi(i+1)
4466 c          icrc=0
4467 c          call proc_proc(phii1,icrc)
4468           if (icrc.eq.1) phii1=150.0
4469           phii1=pinorm(phii1)
4470           z(1)=cos(phii1)
4471 #else
4472           phii1=phi(i+1)
4473           z(1)=dcos(phii1)
4474 #endif
4475           z(2)=dsin(phii1)
4476         else
4477           z(1)=0.0D0
4478           z(2)=0.0D0
4479         endif
4480 C Calculate the "mean" value of theta from the part of the distribution
4481 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4482 C In following comments this theta will be referred to as t_c.
4483         thet_pred_mean=0.0d0
4484         do k=1,2
4485             athetk=athet(k,it,ichir1,ichir2)
4486             bthetk=bthet(k,it,ichir1,ichir2)
4487           if (it.eq.10) then
4488              athetk=athet(k,itype1,ichir11,ichir12)
4489              bthetk=bthet(k,itype2,ichir21,ichir22)
4490           endif
4491           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4492         enddo
4493 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4494         dthett=thet_pred_mean*ssd
4495         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4496 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4497 C Derivatives of the "mean" values in gamma1 and gamma2.
4498         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4499      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4500          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4501      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4502          if (it.eq.10) then
4503       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4504      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4505         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4506      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4507          endif
4508         if (theta(i).gt.pi-delta) then
4509           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4510      &         E_tc0)
4511           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4512           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4513           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4514      &        E_theta)
4515           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4516      &        E_tc)
4517         else if (theta(i).lt.delta) then
4518           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4519           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4520           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4521      &        E_theta)
4522           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4523           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4524      &        E_tc)
4525         else
4526           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4527      &        E_theta,E_tc)
4528         endif
4529         etheta=etheta+ethetai
4530 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4531 c     &      'ebend',i,ethetai,theta(i),itype(i)
4532 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4533 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4534         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4535         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4536         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4537 c 1215   continue
4538       enddo
4539       ethetacnstr=0.0d0
4540 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4541       do i=1,ntheta_constr
4542         itheta=itheta_constr(i)
4543         thetiii=theta(itheta)
4544         difi=pinorm(thetiii-theta_constr0(i))
4545         if (difi.gt.theta_drange(i)) then
4546           difi=difi-theta_drange(i)
4547           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4548           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4549      &    +for_thet_constr(i)*difi**3
4550         else if (difi.lt.-drange(i)) then
4551           difi=difi+drange(i)
4552           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4553           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4554      &    +for_thet_constr(i)*difi**3
4555         else
4556           difi=0.0
4557         endif
4558 C       if (energy_dec) then
4559 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4560 C     &    i,itheta,rad2deg*thetiii,
4561 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4562 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4563 C     &    gloc(itheta+nphi-2,icg)
4564 C        endif
4565       enddo
4566 C Ufff.... We've done all this!!!
4567       return
4568       end
4569 C---------------------------------------------------------------------------
4570       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4571      &     E_tc)
4572       implicit real*8 (a-h,o-z)
4573       include 'DIMENSIONS'
4574       include 'COMMON.LOCAL'
4575       include 'COMMON.IOUNITS'
4576       common /calcthet/ term1,term2,termm,diffak,ratak,
4577      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4578      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4579 C Calculate the contributions to both Gaussian lobes.
4580 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4581 C The "polynomial part" of the "standard deviation" of this part of
4582 C the distribution.
4583         sig=polthet(3,it)
4584         do j=2,0,-1
4585           sig=sig*thet_pred_mean+polthet(j,it)
4586         enddo
4587 C Derivative of the "interior part" of the "standard deviation of the"
4588 C gamma-dependent Gaussian lobe in t_c.
4589         sigtc=3*polthet(3,it)
4590         do j=2,1,-1
4591           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4592         enddo
4593         sigtc=sig*sigtc
4594 C Set the parameters of both Gaussian lobes of the distribution.
4595 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4596         fac=sig*sig+sigc0(it)
4597         sigcsq=fac+fac
4598         sigc=1.0D0/sigcsq
4599 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4600         sigsqtc=-4.0D0*sigcsq*sigtc
4601 c       print *,i,sig,sigtc,sigsqtc
4602 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4603         sigtc=-sigtc/(fac*fac)
4604 C Following variable is sigma(t_c)**(-2)
4605         sigcsq=sigcsq*sigcsq
4606         sig0i=sig0(it)
4607         sig0inv=1.0D0/sig0i**2
4608         delthec=thetai-thet_pred_mean
4609         delthe0=thetai-theta0i
4610         term1=-0.5D0*sigcsq*delthec*delthec
4611         term2=-0.5D0*sig0inv*delthe0*delthe0
4612 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4613 C NaNs in taking the logarithm. We extract the largest exponent which is added
4614 C to the energy (this being the log of the distribution) at the end of energy
4615 C term evaluation for this virtual-bond angle.
4616         if (term1.gt.term2) then
4617           termm=term1
4618           term2=dexp(term2-termm)
4619           term1=1.0d0
4620         else
4621           termm=term2
4622           term1=dexp(term1-termm)
4623           term2=1.0d0
4624         endif
4625 C The ratio between the gamma-independent and gamma-dependent lobes of
4626 C the distribution is a Gaussian function of thet_pred_mean too.
4627         diffak=gthet(2,it)-thet_pred_mean
4628         ratak=diffak/gthet(3,it)**2
4629         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4630 C Let's differentiate it in thet_pred_mean NOW.
4631         aktc=ak*ratak
4632 C Now put together the distribution terms to make complete distribution.
4633         termexp=term1+ak*term2
4634         termpre=sigc+ak*sig0i
4635 C Contribution of the bending energy from this theta is just the -log of
4636 C the sum of the contributions from the two lobes and the pre-exponential
4637 C factor. Simple enough, isn't it?
4638         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4639 C NOW the derivatives!!!
4640 C 6/6/97 Take into account the deformation.
4641         E_theta=(delthec*sigcsq*term1
4642      &       +ak*delthe0*sig0inv*term2)/termexp
4643         E_tc=((sigtc+aktc*sig0i)/termpre
4644      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4645      &       aktc*term2)/termexp)
4646       return
4647       end
4648 c-----------------------------------------------------------------------------
4649       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4650       implicit real*8 (a-h,o-z)
4651       include 'DIMENSIONS'
4652       include 'COMMON.LOCAL'
4653       include 'COMMON.IOUNITS'
4654       common /calcthet/ term1,term2,termm,diffak,ratak,
4655      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4656      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4657       delthec=thetai-thet_pred_mean
4658       delthe0=thetai-theta0i
4659 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4660       t3 = thetai-thet_pred_mean
4661       t6 = t3**2
4662       t9 = term1
4663       t12 = t3*sigcsq
4664       t14 = t12+t6*sigsqtc
4665       t16 = 1.0d0
4666       t21 = thetai-theta0i
4667       t23 = t21**2
4668       t26 = term2
4669       t27 = t21*t26
4670       t32 = termexp
4671       t40 = t32**2
4672       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4673      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4674      & *(-t12*t9-ak*sig0inv*t27)
4675       return
4676       end
4677 #else
4678 C--------------------------------------------------------------------------
4679       subroutine ebend(etheta)
4680 C
4681 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4682 C angles gamma and its derivatives in consecutive thetas and gammas.
4683 C ab initio-derived potentials from
4684 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4685 C
4686       implicit real*8 (a-h,o-z)
4687       include 'DIMENSIONS'
4688       include 'COMMON.LOCAL'
4689       include 'COMMON.GEO'
4690       include 'COMMON.INTERACT'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.VAR'
4693       include 'COMMON.CHAIN'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.NAMES'
4696       include 'COMMON.FFIELD'
4697       include 'COMMON.CONTROL'
4698       include 'COMMON.TORCNSTR'
4699       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4700      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4701      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4702      & sinph1ph2(maxdouble,maxdouble)
4703       logical lprn /.false./, lprn1 /.false./
4704       etheta=0.0D0
4705 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4706       do i=ithet_start,ithet_end
4707 C         if (i.eq.2) cycle
4708 C        if (itype(i-1).eq.ntyp1) cycle
4709         if (i.le.2) cycle
4710         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4711      &  .or.itype(i).eq.ntyp1) cycle
4712         if (iabs(itype(i+1)).eq.20) iblock=2
4713         if (iabs(itype(i+1)).ne.20) iblock=1
4714         dethetai=0.0d0
4715         dephii=0.0d0
4716         dephii1=0.0d0
4717         theti2=0.5d0*theta(i)
4718         ityp2=ithetyp((itype(i-1)))
4719         do k=1,nntheterm
4720           coskt(k)=dcos(k*theti2)
4721           sinkt(k)=dsin(k*theti2)
4722         enddo
4723 cu        if (i.eq.3) then
4724 cu          phii=0.0d0
4725 cu          ityp1=nthetyp+1
4726 cu          do k=1,nsingle
4727 cu            cosph1(k)=0.0d0
4728 cu            sinph1(k)=0.0d0
4729 cu          enddo
4730 cu        else
4731         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4732 #ifdef OSF
4733           phii=phi(i)
4734           if (phii.ne.phii) phii=150.0
4735 #else
4736           phii=phi(i)
4737 #endif
4738           ityp1=ithetyp((itype(i-2)))
4739           do k=1,nsingle
4740             cosph1(k)=dcos(k*phii)
4741             sinph1(k)=dsin(k*phii)
4742           enddo
4743         else
4744           phii=0.0d0
4745 c          ityp1=nthetyp+1
4746           do k=1,nsingle
4747             ityp1=ithetyp((itype(i-2)))
4748             cosph1(k)=0.0d0
4749             sinph1(k)=0.0d0
4750           enddo
4751         endif
4752         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4753 #ifdef OSF
4754           phii1=phi(i+1)
4755           if (phii1.ne.phii1) phii1=150.0
4756           phii1=pinorm(phii1)
4757 #else
4758           phii1=phi(i+1)
4759 #endif
4760           ityp3=ithetyp((itype(i)))
4761           do k=1,nsingle
4762             cosph2(k)=dcos(k*phii1)
4763             sinph2(k)=dsin(k*phii1)
4764           enddo
4765         else
4766           phii1=0.0d0
4767 c          ityp3=nthetyp+1
4768           ityp3=ithetyp((itype(i)))
4769           do k=1,nsingle
4770             cosph2(k)=0.0d0
4771             sinph2(k)=0.0d0
4772           enddo
4773         endif
4774 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4775 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4776 c        call flush(iout)
4777         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4778         do k=1,ndouble
4779           do l=1,k-1
4780             ccl=cosph1(l)*cosph2(k-l)
4781             ssl=sinph1(l)*sinph2(k-l)
4782             scl=sinph1(l)*cosph2(k-l)
4783             csl=cosph1(l)*sinph2(k-l)
4784             cosph1ph2(l,k)=ccl-ssl
4785             cosph1ph2(k,l)=ccl+ssl
4786             sinph1ph2(l,k)=scl+csl
4787             sinph1ph2(k,l)=scl-csl
4788           enddo
4789         enddo
4790         if (lprn) then
4791         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4792      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4793         write (iout,*) "coskt and sinkt"
4794         do k=1,nntheterm
4795           write (iout,*) k,coskt(k),sinkt(k)
4796         enddo
4797         endif
4798         do k=1,ntheterm
4799           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4800           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4801      &      *coskt(k)
4802           if (lprn)
4803      &    write (iout,*) "k",k,"
4804      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4805      &     " ethetai",ethetai
4806         enddo
4807         if (lprn) then
4808         write (iout,*) "cosph and sinph"
4809         do k=1,nsingle
4810           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4811         enddo
4812         write (iout,*) "cosph1ph2 and sinph2ph2"
4813         do k=2,ndouble
4814           do l=1,k-1
4815             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4816      &         sinph1ph2(l,k),sinph1ph2(k,l)
4817           enddo
4818         enddo
4819         write(iout,*) "ethetai",ethetai
4820         endif
4821         do m=1,ntheterm2
4822           do k=1,nsingle
4823             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4824      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4825      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4826      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4827             ethetai=ethetai+sinkt(m)*aux
4828             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4829             dephii=dephii+k*sinkt(m)*(
4830      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4831      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4832             dephii1=dephii1+k*sinkt(m)*(
4833      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4834      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4835             if (lprn)
4836      &      write (iout,*) "m",m," k",k," bbthet",
4837      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4838      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4839      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4840      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4841           enddo
4842         enddo
4843         if (lprn)
4844      &  write(iout,*) "ethetai",ethetai
4845         do m=1,ntheterm3
4846           do k=2,ndouble
4847             do l=1,k-1
4848               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4849      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4850      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4851      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4852               ethetai=ethetai+sinkt(m)*aux
4853               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4854               dephii=dephii+l*sinkt(m)*(
4855      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4856      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4857      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4858      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4859               dephii1=dephii1+(k-l)*sinkt(m)*(
4860      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4861      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4862      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4863      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4864               if (lprn) then
4865               write (iout,*) "m",m," k",k," l",l," ffthet",
4866      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4867      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4868      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4869      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4870      &            " ethetai",ethetai
4871               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4872      &            cosph1ph2(k,l)*sinkt(m),
4873      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4874               endif
4875             enddo
4876           enddo
4877         enddo
4878 10      continue
4879         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4880      &   i,theta(i)*rad2deg,phii*rad2deg,
4881      &   phii1*rad2deg,ethetai
4882         etheta=etheta+ethetai
4883         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4884         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4885 c        gloc(nphi+i-2,icg)=wang*dethetai
4886         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4887       enddo
4888       return
4889       end
4890 #endif
4891 #ifdef CRYST_SC
4892 c-----------------------------------------------------------------------------
4893       subroutine esc(escloc)
4894 C Calculate the local energy of a side chain and its derivatives in the
4895 C corresponding virtual-bond valence angles THETA and the spherical angles
4896 C ALPHA and OMEGA.
4897       implicit real*8 (a-h,o-z)
4898       include 'DIMENSIONS'
4899       include 'COMMON.GEO'
4900       include 'COMMON.LOCAL'
4901       include 'COMMON.VAR'
4902       include 'COMMON.INTERACT'
4903       include 'COMMON.DERIV'
4904       include 'COMMON.CHAIN'
4905       include 'COMMON.IOUNITS'
4906       include 'COMMON.NAMES'
4907       include 'COMMON.FFIELD'
4908       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4909      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4910       common /sccalc/ time11,time12,time112,theti,it,nlobit
4911       delta=0.02d0*pi
4912       escloc=0.0D0
4913 C      write (iout,*) 'ESC'
4914       do i=loc_start,loc_end
4915         it=itype(i)
4916         if (it.eq.ntyp1) cycle
4917         if (it.eq.10) goto 1
4918         nlobit=nlob(iabs(it))
4919 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4920 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4921         theti=theta(i+1)-pipol
4922         x(1)=dtan(theti)
4923         x(2)=alph(i)
4924         x(3)=omeg(i)
4925 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4926
4927         if (x(2).gt.pi-delta) then
4928           xtemp(1)=x(1)
4929           xtemp(2)=pi-delta
4930           xtemp(3)=x(3)
4931           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4932           xtemp(2)=pi
4933           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4934           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4935      &        escloci,dersc(2))
4936           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4937      &        ddersc0(1),dersc(1))
4938           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4939      &        ddersc0(3),dersc(3))
4940           xtemp(2)=pi-delta
4941           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4942           xtemp(2)=pi
4943           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4944           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4945      &            dersc0(2),esclocbi,dersc02)
4946           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4947      &            dersc12,dersc01)
4948           call splinthet(x(2),0.5d0*delta,ss,ssd)
4949           dersc0(1)=dersc01
4950           dersc0(2)=dersc02
4951           dersc0(3)=0.0d0
4952           do k=1,3
4953             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4954           enddo
4955           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4956           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4957      &             esclocbi,ss,ssd
4958           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4959 c         escloci=esclocbi
4960 c         write (iout,*) escloci
4961         else if (x(2).lt.delta) then
4962           xtemp(1)=x(1)
4963           xtemp(2)=delta
4964           xtemp(3)=x(3)
4965           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4966           xtemp(2)=0.0d0
4967           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4968           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4969      &        escloci,dersc(2))
4970           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4971      &        ddersc0(1),dersc(1))
4972           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4973      &        ddersc0(3),dersc(3))
4974           xtemp(2)=delta
4975           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4976           xtemp(2)=0.0d0
4977           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4978           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4979      &            dersc0(2),esclocbi,dersc02)
4980           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4981      &            dersc12,dersc01)
4982           dersc0(1)=dersc01
4983           dersc0(2)=dersc02
4984           dersc0(3)=0.0d0
4985           call splinthet(x(2),0.5d0*delta,ss,ssd)
4986           do k=1,3
4987             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4988           enddo
4989           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4990 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4991 c     &             esclocbi,ss,ssd
4992           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4993 C         write (iout,*) 'i=',i, escloci
4994         else
4995           call enesc(x,escloci,dersc,ddummy,.false.)
4996         endif
4997
4998         escloc=escloc+escloci
4999 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5000             write (iout,'(a6,i5,0pf7.3)')
5001      &     'escloc',i,escloci
5002
5003         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5004      &   wscloc*dersc(1)
5005         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5006         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5007     1   continue
5008       enddo
5009       return
5010       end
5011 C---------------------------------------------------------------------------
5012       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5013       implicit real*8 (a-h,o-z)
5014       include 'DIMENSIONS'
5015       include 'COMMON.GEO'
5016       include 'COMMON.LOCAL'
5017       include 'COMMON.IOUNITS'
5018       common /sccalc/ time11,time12,time112,theti,it,nlobit
5019       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5020       double precision contr(maxlob,-1:1)
5021       logical mixed
5022 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5023         escloc_i=0.0D0
5024         do j=1,3
5025           dersc(j)=0.0D0
5026           if (mixed) ddersc(j)=0.0d0
5027         enddo
5028         x3=x(3)
5029
5030 C Because of periodicity of the dependence of the SC energy in omega we have
5031 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5032 C To avoid underflows, first compute & store the exponents.
5033
5034         do iii=-1,1
5035
5036           x(3)=x3+iii*dwapi
5037
5038           do j=1,nlobit
5039             do k=1,3
5040               z(k)=x(k)-censc(k,j,it)
5041             enddo
5042             do k=1,3
5043               Axk=0.0D0
5044               do l=1,3
5045                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5046               enddo
5047               Ax(k,j,iii)=Axk
5048             enddo
5049             expfac=0.0D0
5050             do k=1,3
5051               expfac=expfac+Ax(k,j,iii)*z(k)
5052             enddo
5053             contr(j,iii)=expfac
5054           enddo ! j
5055
5056         enddo ! iii
5057
5058         x(3)=x3
5059 C As in the case of ebend, we want to avoid underflows in exponentiation and
5060 C subsequent NaNs and INFs in energy calculation.
5061 C Find the largest exponent
5062         emin=contr(1,-1)
5063         do iii=-1,1
5064           do j=1,nlobit
5065             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5066           enddo
5067         enddo
5068         emin=0.5D0*emin
5069 cd      print *,'it=',it,' emin=',emin
5070
5071 C Compute the contribution to SC energy and derivatives
5072         do iii=-1,1
5073
5074           do j=1,nlobit
5075             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5076 cd          print *,'j=',j,' expfac=',expfac
5077             escloc_i=escloc_i+expfac
5078             do k=1,3
5079               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5080             enddo
5081             if (mixed) then
5082               do k=1,3,2
5083                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5084      &            +gaussc(k,2,j,it))*expfac
5085               enddo
5086             endif
5087           enddo
5088
5089         enddo ! iii
5090
5091         dersc(1)=dersc(1)/cos(theti)**2
5092         ddersc(1)=ddersc(1)/cos(theti)**2
5093         ddersc(3)=ddersc(3)
5094
5095         escloci=-(dlog(escloc_i)-emin)
5096         do j=1,3
5097           dersc(j)=dersc(j)/escloc_i
5098         enddo
5099         if (mixed) then
5100           do j=1,3,2
5101             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5102           enddo
5103         endif
5104       return
5105       end
5106 C------------------------------------------------------------------------------
5107       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5108       implicit real*8 (a-h,o-z)
5109       include 'DIMENSIONS'
5110       include 'COMMON.GEO'
5111       include 'COMMON.LOCAL'
5112       include 'COMMON.IOUNITS'
5113       common /sccalc/ time11,time12,time112,theti,it,nlobit
5114       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5115       double precision contr(maxlob)
5116       logical mixed
5117
5118       escloc_i=0.0D0
5119
5120       do j=1,3
5121         dersc(j)=0.0D0
5122       enddo
5123
5124       do j=1,nlobit
5125         do k=1,2
5126           z(k)=x(k)-censc(k,j,it)
5127         enddo
5128         z(3)=dwapi
5129         do k=1,3
5130           Axk=0.0D0
5131           do l=1,3
5132             Axk=Axk+gaussc(l,k,j,it)*z(l)
5133           enddo
5134           Ax(k,j)=Axk
5135         enddo
5136         expfac=0.0D0
5137         do k=1,3
5138           expfac=expfac+Ax(k,j)*z(k)
5139         enddo
5140         contr(j)=expfac
5141       enddo ! j
5142
5143 C As in the case of ebend, we want to avoid underflows in exponentiation and
5144 C subsequent NaNs and INFs in energy calculation.
5145 C Find the largest exponent
5146       emin=contr(1)
5147       do j=1,nlobit
5148         if (emin.gt.contr(j)) emin=contr(j)
5149       enddo
5150       emin=0.5D0*emin
5151
5152 C Compute the contribution to SC energy and derivatives
5153
5154       dersc12=0.0d0
5155       do j=1,nlobit
5156         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5157         escloc_i=escloc_i+expfac
5158         do k=1,2
5159           dersc(k)=dersc(k)+Ax(k,j)*expfac
5160         enddo
5161         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5162      &            +gaussc(1,2,j,it))*expfac
5163         dersc(3)=0.0d0
5164       enddo
5165
5166       dersc(1)=dersc(1)/cos(theti)**2
5167       dersc12=dersc12/cos(theti)**2
5168       escloci=-(dlog(escloc_i)-emin)
5169       do j=1,2
5170         dersc(j)=dersc(j)/escloc_i
5171       enddo
5172       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5173       return
5174       end
5175 #else
5176 c----------------------------------------------------------------------------------
5177       subroutine esc(escloc)
5178 C Calculate the local energy of a side chain and its derivatives in the
5179 C corresponding virtual-bond valence angles THETA and the spherical angles
5180 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5181 C added by Urszula Kozlowska. 07/11/2007
5182 C
5183       implicit real*8 (a-h,o-z)
5184       include 'DIMENSIONS'
5185       include 'COMMON.GEO'
5186       include 'COMMON.LOCAL'
5187       include 'COMMON.VAR'
5188       include 'COMMON.SCROT'
5189       include 'COMMON.INTERACT'
5190       include 'COMMON.DERIV'
5191       include 'COMMON.CHAIN'
5192       include 'COMMON.IOUNITS'
5193       include 'COMMON.NAMES'
5194       include 'COMMON.FFIELD'
5195       include 'COMMON.CONTROL'
5196       include 'COMMON.VECTORS'
5197       double precision x_prime(3),y_prime(3),z_prime(3)
5198      &    , sumene,dsc_i,dp2_i,x(65),
5199      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5200      &    de_dxx,de_dyy,de_dzz,de_dt
5201       double precision s1_t,s1_6_t,s2_t,s2_6_t
5202       double precision
5203      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5204      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5205      & dt_dCi(3),dt_dCi1(3)
5206       common /sccalc/ time11,time12,time112,theti,it,nlobit
5207       delta=0.02d0*pi
5208       escloc=0.0D0
5209       do i=loc_start,loc_end
5210         if (itype(i).eq.ntyp1) cycle
5211         costtab(i+1) =dcos(theta(i+1))
5212         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5213         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5214         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5215         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5216         cosfac=dsqrt(cosfac2)
5217         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5218         sinfac=dsqrt(sinfac2)
5219         it=iabs(itype(i))
5220         if (it.eq.10) goto 1
5221 c
5222 C  Compute the axes of tghe local cartesian coordinates system; store in
5223 c   x_prime, y_prime and z_prime
5224 c
5225         do j=1,3
5226           x_prime(j) = 0.00
5227           y_prime(j) = 0.00
5228           z_prime(j) = 0.00
5229         enddo
5230 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5231 C     &   dc_norm(3,i+nres)
5232         do j = 1,3
5233           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5234           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5235         enddo
5236         do j = 1,3
5237           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5238         enddo
5239 c       write (2,*) "i",i
5240 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5241 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5242 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5243 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5244 c      & " xy",scalar(x_prime(1),y_prime(1)),
5245 c      & " xz",scalar(x_prime(1),z_prime(1)),
5246 c      & " yy",scalar(y_prime(1),y_prime(1)),
5247 c      & " yz",scalar(y_prime(1),z_prime(1)),
5248 c      & " zz",scalar(z_prime(1),z_prime(1))
5249 c
5250 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5251 C to local coordinate system. Store in xx, yy, zz.
5252 c
5253         xx=0.0d0
5254         yy=0.0d0
5255         zz=0.0d0
5256         do j = 1,3
5257           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5258           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5259           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5260         enddo
5261
5262         xxtab(i)=xx
5263         yytab(i)=yy
5264         zztab(i)=zz
5265 C
5266 C Compute the energy of the ith side cbain
5267 C
5268 c        write (2,*) "xx",xx," yy",yy," zz",zz
5269         it=iabs(itype(i))
5270         do j = 1,65
5271           x(j) = sc_parmin(j,it)
5272         enddo
5273 #ifdef CHECK_COORD
5274 Cc diagnostics - remove later
5275         xx1 = dcos(alph(2))
5276         yy1 = dsin(alph(2))*dcos(omeg(2))
5277         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5278         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5279      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5280      &    xx1,yy1,zz1
5281 C,"  --- ", xx_w,yy_w,zz_w
5282 c end diagnostics
5283 #endif
5284         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5285      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5286      &   + x(10)*yy*zz
5287         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5288      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5289      & + x(20)*yy*zz
5290         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5291      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5292      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5293      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5294      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5295      &  +x(40)*xx*yy*zz
5296         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5297      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5298      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5299      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5300      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5301      &  +x(60)*xx*yy*zz
5302         dsc_i   = 0.743d0+x(61)
5303         dp2_i   = 1.9d0+x(62)
5304         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5305      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5306         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5307      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5308         s1=(1+x(63))/(0.1d0 + dscp1)
5309         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5310         s2=(1+x(65))/(0.1d0 + dscp2)
5311         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5312         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5313      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5314 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5315 c     &   sumene4,
5316 c     &   dscp1,dscp2,sumene
5317 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5318         escloc = escloc + sumene
5319 c        write (2,*) "escloc",escloc
5320 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5321 c     &  zz,xx,yy
5322         if (.not. calc_grad) goto 1
5323 #ifdef DEBUG
5324 C
5325 C This section to check the numerical derivatives of the energy of ith side
5326 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5327 C #define DEBUG in the code to turn it on.
5328 C
5329         write (2,*) "sumene               =",sumene
5330         aincr=1.0d-7
5331         xxsave=xx
5332         xx=xx+aincr
5333         write (2,*) xx,yy,zz
5334         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5335         de_dxx_num=(sumenep-sumene)/aincr
5336         xx=xxsave
5337         write (2,*) "xx+ sumene from enesc=",sumenep
5338         yysave=yy
5339         yy=yy+aincr
5340         write (2,*) xx,yy,zz
5341         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5342         de_dyy_num=(sumenep-sumene)/aincr
5343         yy=yysave
5344         write (2,*) "yy+ sumene from enesc=",sumenep
5345         zzsave=zz
5346         zz=zz+aincr
5347         write (2,*) xx,yy,zz
5348         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5349         de_dzz_num=(sumenep-sumene)/aincr
5350         zz=zzsave
5351         write (2,*) "zz+ sumene from enesc=",sumenep
5352         costsave=cost2tab(i+1)
5353         sintsave=sint2tab(i+1)
5354         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5355         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5356         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5357         de_dt_num=(sumenep-sumene)/aincr
5358         write (2,*) " t+ sumene from enesc=",sumenep
5359         cost2tab(i+1)=costsave
5360         sint2tab(i+1)=sintsave
5361 C End of diagnostics section.
5362 #endif
5363 C
5364 C Compute the gradient of esc
5365 C
5366         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5367         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5368         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5369         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5370         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5371         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5372         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5373         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5374         pom1=(sumene3*sint2tab(i+1)+sumene1)
5375      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5376         pom2=(sumene4*cost2tab(i+1)+sumene2)
5377      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5378         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5379         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5380      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5381      &  +x(40)*yy*zz
5382         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5383         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5384      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5385      &  +x(60)*yy*zz
5386         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5387      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5388      &        +(pom1+pom2)*pom_dx
5389 #ifdef DEBUG
5390         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5391 #endif
5392 C
5393         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5394         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5395      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5396      &  +x(40)*xx*zz
5397         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5398         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5399      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5400      &  +x(59)*zz**2 +x(60)*xx*zz
5401         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5402      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5403      &        +(pom1-pom2)*pom_dy
5404 #ifdef DEBUG
5405         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5406 #endif
5407 C
5408         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5409      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5410      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5411      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5412      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5413      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5414      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5415      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5416 #ifdef DEBUG
5417         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5418 #endif
5419 C
5420         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5421      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5422      &  +pom1*pom_dt1+pom2*pom_dt2
5423 #ifdef DEBUG
5424         write(2,*), "de_dt = ", de_dt,de_dt_num
5425 #endif
5426 c
5427 C
5428        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5429        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5430        cosfac2xx=cosfac2*xx
5431        sinfac2yy=sinfac2*yy
5432        do k = 1,3
5433          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5434      &      vbld_inv(i+1)
5435          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5436      &      vbld_inv(i)
5437          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5438          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5439 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5440 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5441 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5442 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5443          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5444          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5445          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5446          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5447          dZZ_Ci1(k)=0.0d0
5448          dZZ_Ci(k)=0.0d0
5449          do j=1,3
5450            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5451      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5452            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5453      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5454          enddo
5455
5456          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5457          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5458          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5459 c
5460          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5461          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5462        enddo
5463
5464        do k=1,3
5465          dXX_Ctab(k,i)=dXX_Ci(k)
5466          dXX_C1tab(k,i)=dXX_Ci1(k)
5467          dYY_Ctab(k,i)=dYY_Ci(k)
5468          dYY_C1tab(k,i)=dYY_Ci1(k)
5469          dZZ_Ctab(k,i)=dZZ_Ci(k)
5470          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5471          dXX_XYZtab(k,i)=dXX_XYZ(k)
5472          dYY_XYZtab(k,i)=dYY_XYZ(k)
5473          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5474        enddo
5475
5476        do k = 1,3
5477 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5478 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5479 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5480 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5481 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5482 c     &    dt_dci(k)
5483 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5484 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5485          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5486      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5487          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5488      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5489          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5490      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5491        enddo
5492 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5493 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5494
5495 C to check gradient call subroutine check_grad
5496
5497     1 continue
5498       enddo
5499       return
5500       end
5501 #endif
5502 c------------------------------------------------------------------------------
5503       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5504 C
5505 C This procedure calculates two-body contact function g(rij) and its derivative:
5506 C
5507 C           eps0ij                                     !       x < -1
5508 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5509 C            0                                         !       x > 1
5510 C
5511 C where x=(rij-r0ij)/delta
5512 C
5513 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5514 C
5515       implicit none
5516       double precision rij,r0ij,eps0ij,fcont,fprimcont
5517       double precision x,x2,x4,delta
5518 c     delta=0.02D0*r0ij
5519 c      delta=0.2D0*r0ij
5520       x=(rij-r0ij)/delta
5521       if (x.lt.-1.0D0) then
5522         fcont=eps0ij
5523         fprimcont=0.0D0
5524       else if (x.le.1.0D0) then
5525         x2=x*x
5526         x4=x2*x2
5527         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5528         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5529       else
5530         fcont=0.0D0
5531         fprimcont=0.0D0
5532       endif
5533       return
5534       end
5535 c------------------------------------------------------------------------------
5536       subroutine splinthet(theti,delta,ss,ssder)
5537       implicit real*8 (a-h,o-z)
5538       include 'DIMENSIONS'
5539       include 'COMMON.VAR'
5540       include 'COMMON.GEO'
5541       thetup=pi-delta
5542       thetlow=delta
5543       if (theti.gt.pipol) then
5544         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5545       else
5546         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5547         ssder=-ssder
5548       endif
5549       return
5550       end
5551 c------------------------------------------------------------------------------
5552       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5553       implicit none
5554       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5555       double precision ksi,ksi2,ksi3,a1,a2,a3
5556       a1=fprim0*delta/(f1-f0)
5557       a2=3.0d0-2.0d0*a1
5558       a3=a1-2.0d0
5559       ksi=(x-x0)/delta
5560       ksi2=ksi*ksi
5561       ksi3=ksi2*ksi
5562       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5563       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5564       return
5565       end
5566 c------------------------------------------------------------------------------
5567       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5568       implicit none
5569       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5570       double precision ksi,ksi2,ksi3,a1,a2,a3
5571       ksi=(x-x0)/delta
5572       ksi2=ksi*ksi
5573       ksi3=ksi2*ksi
5574       a1=fprim0x*delta
5575       a2=3*(f1x-f0x)-2*fprim0x*delta
5576       a3=fprim0x*delta-2*(f1x-f0x)
5577       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5578       return
5579       end
5580 C-----------------------------------------------------------------------------
5581 #ifdef CRYST_TOR
5582 C-----------------------------------------------------------------------------
5583       subroutine etor(etors,fact)
5584       implicit real*8 (a-h,o-z)
5585       include 'DIMENSIONS'
5586       include 'COMMON.VAR'
5587       include 'COMMON.GEO'
5588       include 'COMMON.LOCAL'
5589       include 'COMMON.TORSION'
5590       include 'COMMON.INTERACT'
5591       include 'COMMON.DERIV'
5592       include 'COMMON.CHAIN'
5593       include 'COMMON.NAMES'
5594       include 'COMMON.IOUNITS'
5595       include 'COMMON.FFIELD'
5596       include 'COMMON.TORCNSTR'
5597       logical lprn
5598 C Set lprn=.true. for debugging
5599       lprn=.false.
5600 c      lprn=.true.
5601       etors=0.0D0
5602       do i=iphi_start,iphi_end
5603         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5604      &      .or. itype(i).eq.ntyp1) cycle
5605         itori=itortyp(itype(i-2))
5606         itori1=itortyp(itype(i-1))
5607         phii=phi(i)
5608         gloci=0.0D0
5609 C Proline-Proline pair is a special case...
5610         if (itori.eq.3 .and. itori1.eq.3) then
5611           if (phii.gt.-dwapi3) then
5612             cosphi=dcos(3*phii)
5613             fac=1.0D0/(1.0D0-cosphi)
5614             etorsi=v1(1,3,3)*fac
5615             etorsi=etorsi+etorsi
5616             etors=etors+etorsi-v1(1,3,3)
5617             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5618           endif
5619           do j=1,3
5620             v1ij=v1(j+1,itori,itori1)
5621             v2ij=v2(j+1,itori,itori1)
5622             cosphi=dcos(j*phii)
5623             sinphi=dsin(j*phii)
5624             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5625             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5626           enddo
5627         else
5628           do j=1,nterm_old
5629             v1ij=v1(j,itori,itori1)
5630             v2ij=v2(j,itori,itori1)
5631             cosphi=dcos(j*phii)
5632             sinphi=dsin(j*phii)
5633             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5634             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5635           enddo
5636         endif
5637         if (lprn)
5638      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5639      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5640      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5641         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5642 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5643       enddo
5644       return
5645       end
5646 c------------------------------------------------------------------------------
5647 #else
5648       subroutine etor(etors,fact)
5649       implicit real*8 (a-h,o-z)
5650       include 'DIMENSIONS'
5651       include 'COMMON.VAR'
5652       include 'COMMON.GEO'
5653       include 'COMMON.LOCAL'
5654       include 'COMMON.TORSION'
5655       include 'COMMON.INTERACT'
5656       include 'COMMON.DERIV'
5657       include 'COMMON.CHAIN'
5658       include 'COMMON.NAMES'
5659       include 'COMMON.IOUNITS'
5660       include 'COMMON.FFIELD'
5661       include 'COMMON.TORCNSTR'
5662       logical lprn
5663 C Set lprn=.true. for debugging
5664       lprn=.false.
5665 c      lprn=.true.
5666       etors=0.0D0
5667       do i=iphi_start,iphi_end
5668         if (i.le.2) cycle
5669         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5670      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5671 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5672 C     &       .or. itype(i).eq.ntyp1) cycle
5673         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5674          if (iabs(itype(i)).eq.20) then
5675          iblock=2
5676          else
5677          iblock=1
5678          endif
5679         itori=itortyp(itype(i-2))
5680         itori1=itortyp(itype(i-1))
5681         phii=phi(i)
5682         gloci=0.0D0
5683 C Regular cosine and sine terms
5684         do j=1,nterm(itori,itori1,iblock)
5685           v1ij=v1(j,itori,itori1,iblock)
5686           v2ij=v2(j,itori,itori1,iblock)
5687           cosphi=dcos(j*phii)
5688           sinphi=dsin(j*phii)
5689           etors=etors+v1ij*cosphi+v2ij*sinphi
5690           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5691         enddo
5692 C Lorentz terms
5693 C                         v1
5694 C  E = SUM ----------------------------------- - v1
5695 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5696 C
5697         cosphi=dcos(0.5d0*phii)
5698         sinphi=dsin(0.5d0*phii)
5699         do j=1,nlor(itori,itori1,iblock)
5700           vl1ij=vlor1(j,itori,itori1)
5701           vl2ij=vlor2(j,itori,itori1)
5702           vl3ij=vlor3(j,itori,itori1)
5703           pom=vl2ij*cosphi+vl3ij*sinphi
5704           pom1=1.0d0/(pom*pom+1.0d0)
5705           etors=etors+vl1ij*pom1
5706 c          if (energy_dec) etors_ii=etors_ii+
5707 c     &                vl1ij*pom1
5708           pom=-pom*pom1*pom1
5709           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5710         enddo
5711 C Subtract the constant term
5712         etors=etors-v0(itori,itori1,iblock)
5713         if (lprn)
5714      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5715      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5716      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5717         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5718 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5719  1215   continue
5720       enddo
5721       return
5722       end
5723 c----------------------------------------------------------------------------
5724       subroutine etor_d(etors_d,fact2)
5725 C 6/23/01 Compute double torsional energy
5726       implicit real*8 (a-h,o-z)
5727       include 'DIMENSIONS'
5728       include 'COMMON.VAR'
5729       include 'COMMON.GEO'
5730       include 'COMMON.LOCAL'
5731       include 'COMMON.TORSION'
5732       include 'COMMON.INTERACT'
5733       include 'COMMON.DERIV'
5734       include 'COMMON.CHAIN'
5735       include 'COMMON.NAMES'
5736       include 'COMMON.IOUNITS'
5737       include 'COMMON.FFIELD'
5738       include 'COMMON.TORCNSTR'
5739       logical lprn
5740 C Set lprn=.true. for debugging
5741       lprn=.false.
5742 c     lprn=.true.
5743       etors_d=0.0D0
5744       do i=iphi_start,iphi_end-1
5745         if (i.le.3) cycle
5746 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5747 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5748          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5749      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5750      &  (itype(i+1).eq.ntyp1)) cycle
5751         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5752      &     goto 1215
5753         itori=itortyp(itype(i-2))
5754         itori1=itortyp(itype(i-1))
5755         itori2=itortyp(itype(i))
5756         phii=phi(i)
5757         phii1=phi(i+1)
5758         gloci1=0.0D0
5759         gloci2=0.0D0
5760         iblock=1
5761         if (iabs(itype(i+1)).eq.20) iblock=2
5762 C Regular cosine and sine terms
5763         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5764           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5765           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5766           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5767           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5768           cosphi1=dcos(j*phii)
5769           sinphi1=dsin(j*phii)
5770           cosphi2=dcos(j*phii1)
5771           sinphi2=dsin(j*phii1)
5772           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5773      &     v2cij*cosphi2+v2sij*sinphi2
5774           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5775           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5776         enddo
5777         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5778           do l=1,k-1
5779             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5780             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5781             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5782             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5783             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5784             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5785             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5786             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5787             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5788      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5789             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5790      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5791             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5792      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5793           enddo
5794         enddo
5795         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5796         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5797  1215   continue
5798       enddo
5799       return
5800       end
5801 #endif
5802 c---------------------------------------------------------------------------
5803 C The rigorous attempt to derive energy function
5804       subroutine etor_kcc(etors,fact)
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.VAR'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.TORSION'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.CHAIN'
5814       include 'COMMON.NAMES'
5815       include 'COMMON.IOUNITS'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.TORCNSTR'
5818       include 'COMMON.CONTROL'
5819       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5820       logical lprn
5821 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5822 C Set lprn=.true. for debugging
5823       lprn=energy_dec
5824 c     lprn=.true.
5825 C      print *,"wchodze kcc"
5826       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5827       etors=0.0D0
5828       do i=iphi_start,iphi_end
5829 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5830 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5831 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5832 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5833         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5834      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5835         itori=itortyp(itype(i-2))
5836         itori1=itortyp(itype(i-1))
5837         phii=phi(i)
5838         glocig=0.0D0
5839         glocit1=0.0d0
5840         glocit2=0.0d0
5841 C to avoid multiple devision by 2
5842 c        theti22=0.5d0*theta(i)
5843 C theta 12 is the theta_1 /2
5844 C theta 22 is theta_2 /2
5845 c        theti12=0.5d0*theta(i-1)
5846 C and appropriate sinus function
5847         sinthet1=dsin(theta(i-1))
5848         sinthet2=dsin(theta(i))
5849         costhet1=dcos(theta(i-1))
5850         costhet2=dcos(theta(i))
5851 C to speed up lets store its mutliplication
5852         sint1t2=sinthet2*sinthet1
5853         sint1t2n=1.0d0
5854 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5855 C +d_n*sin(n*gamma)) *
5856 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5857 C we have two sum 1) Non-Chebyshev which is with n and gamma
5858         nval=nterm_kcc_Tb(itori,itori1)
5859         c1(0)=0.0d0
5860         c2(0)=0.0d0
5861         c1(1)=1.0d0
5862         c2(1)=1.0d0
5863         do j=2,nval
5864           c1(j)=c1(j-1)*costhet1
5865           c2(j)=c2(j-1)*costhet2
5866         enddo
5867         etori=0.0d0
5868         do j=1,nterm_kcc(itori,itori1)
5869           cosphi=dcos(j*phii)
5870           sinphi=dsin(j*phii)
5871           sint1t2n1=sint1t2n
5872           sint1t2n=sint1t2n*sint1t2
5873           sumvalc=0.0d0
5874           gradvalct1=0.0d0
5875           gradvalct2=0.0d0
5876           do k=1,nval
5877             do l=1,nval
5878               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5879               gradvalct1=gradvalct1+
5880      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5881               gradvalct2=gradvalct2+
5882      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5883             enddo
5884           enddo
5885           gradvalct1=-gradvalct1*sinthet1
5886           gradvalct2=-gradvalct2*sinthet2
5887           sumvals=0.0d0
5888           gradvalst1=0.0d0
5889           gradvalst2=0.0d0
5890           do k=1,nval
5891             do l=1,nval
5892               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5893               gradvalst1=gradvalst1+
5894      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5895               gradvalst2=gradvalst2+
5896      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5897             enddo
5898           enddo
5899           gradvalst1=-gradvalst1*sinthet1
5900           gradvalst2=-gradvalst2*sinthet2
5901           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5902 C glocig is the gradient local i site in gamma
5903           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5904 C now gradient over theta_1
5905           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5906      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5907           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5908      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5909         enddo ! j
5910         etors=etors+etori
5911 C derivative over gamma
5912         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5913 C derivative over theta1
5914         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5915 C now derivative over theta2
5916         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5917         if (lprn)
5918      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5919      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5920       enddo
5921       return
5922       end
5923 c---------------------------------------------------------------------------------------------
5924       subroutine etor_constr(edihcnstr)
5925       implicit real*8 (a-h,o-z)
5926       include 'DIMENSIONS'
5927       include 'COMMON.VAR'
5928       include 'COMMON.GEO'
5929       include 'COMMON.LOCAL'
5930       include 'COMMON.TORSION'
5931       include 'COMMON.INTERACT'
5932       include 'COMMON.DERIV'
5933       include 'COMMON.CHAIN'
5934       include 'COMMON.NAMES'
5935       include 'COMMON.IOUNITS'
5936       include 'COMMON.FFIELD'
5937       include 'COMMON.TORCNSTR'
5938       include 'COMMON.CONTROL'
5939 ! 6/20/98 - dihedral angle constraints
5940       edihcnstr=0.0d0
5941 c      do i=1,ndih_constr
5942 c      write (iout,*) "idihconstr_start",idihconstr_start,
5943 c     &  " idihconstr_end",idihconstr_end
5944       if (raw_psipred) then
5945         do i=idihconstr_start,idihconstr_end
5946           itori=idih_constr(i)
5947           phii=phi(itori)
5948           gaudih_i=vpsipred(1,i)
5949           gauder_i=0.0d0
5950           do j=1,2
5951             s = sdihed(j,i)
5952             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
5953             dexpcos_i=dexp(-cos_i*cos_i)
5954             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
5955             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
5956      &            *cos_i*dexpcos_i/s**2
5957           enddo
5958           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
5959           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
5960           if (energy_dec)
5961      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
5962      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
5963      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
5964      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
5965      &     -wdihc*dlog(gaudih_i)
5966         enddo
5967       else
5968         do i=idihconstr_start,idihconstr_end
5969           itori=idih_constr(i)
5970           phii=phi(itori)
5971           difi=pinorm(phii-phi0(i))
5972           if (difi.gt.drange(i)) then
5973             difi=difi-drange(i)
5974             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5975             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5976           else if (difi.lt.-drange(i)) then
5977             difi=difi+drange(i)
5978             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5979             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5980           else
5981             difi=0.0
5982           endif
5983         enddo
5984       endif
5985       return
5986       end
5987 c----------------------------------------------------------------------------
5988 C The rigorous attempt to derive energy function
5989       subroutine ebend_kcc(etheta)
5990
5991       implicit real*8 (a-h,o-z)
5992       include 'DIMENSIONS'
5993       include 'COMMON.VAR'
5994       include 'COMMON.GEO'
5995       include 'COMMON.LOCAL'
5996       include 'COMMON.TORSION'
5997       include 'COMMON.INTERACT'
5998       include 'COMMON.DERIV'
5999       include 'COMMON.CHAIN'
6000       include 'COMMON.NAMES'
6001       include 'COMMON.IOUNITS'
6002       include 'COMMON.FFIELD'
6003       include 'COMMON.TORCNSTR'
6004       include 'COMMON.CONTROL'
6005       logical lprn
6006       double precision thybt1(maxang_kcc)
6007 C Set lprn=.true. for debugging
6008       lprn=energy_dec
6009 c     lprn=.true.
6010 C      print *,"wchodze kcc"
6011       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6012       etheta=0.0D0
6013       do i=ithet_start,ithet_end
6014 c        print *,i,itype(i-1),itype(i),itype(i-2)
6015         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6016      &  .or.itype(i).eq.ntyp1) cycle
6017         iti=iabs(itortyp(itype(i-1)))
6018         sinthet=dsin(theta(i))
6019         costhet=dcos(theta(i))
6020         do j=1,nbend_kcc_Tb(iti)
6021           thybt1(j)=v1bend_chyb(j,iti)
6022         enddo
6023         sumth1thyb=v1bend_chyb(0,iti)+
6024      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6025         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6026      &    sumth1thyb
6027         ihelp=nbend_kcc_Tb(iti)-1
6028         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6029         etheta=etheta+sumth1thyb
6030 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6031         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6032       enddo
6033       return
6034       end
6035 c-------------------------------------------------------------------------------------
6036       subroutine etheta_constr(ethetacnstr)
6037
6038       implicit real*8 (a-h,o-z)
6039       include 'DIMENSIONS'
6040       include 'COMMON.VAR'
6041       include 'COMMON.GEO'
6042       include 'COMMON.LOCAL'
6043       include 'COMMON.TORSION'
6044       include 'COMMON.INTERACT'
6045       include 'COMMON.DERIV'
6046       include 'COMMON.CHAIN'
6047       include 'COMMON.NAMES'
6048       include 'COMMON.IOUNITS'
6049       include 'COMMON.FFIELD'
6050       include 'COMMON.TORCNSTR'
6051       include 'COMMON.CONTROL'
6052       ethetacnstr=0.0d0
6053 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6054       do i=ithetaconstr_start,ithetaconstr_end
6055         itheta=itheta_constr(i)
6056         thetiii=theta(itheta)
6057         difi=pinorm(thetiii-theta_constr0(i))
6058         if (difi.gt.theta_drange(i)) then
6059           difi=difi-theta_drange(i)
6060           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6061           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6062      &    +for_thet_constr(i)*difi**3
6063         else if (difi.lt.-drange(i)) then
6064           difi=difi+drange(i)
6065           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6066           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6067      &    +for_thet_constr(i)*difi**3
6068         else
6069           difi=0.0
6070         endif
6071        if (energy_dec) then
6072         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6073      &    i,itheta,rad2deg*thetiii,
6074      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6075      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6076      &    gloc(itheta+nphi-2,icg)
6077         endif
6078       enddo
6079       return
6080       end
6081 c------------------------------------------------------------------------------
6082 c------------------------------------------------------------------------------
6083       subroutine eback_sc_corr(esccor)
6084 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6085 c        conformational states; temporarily implemented as differences
6086 c        between UNRES torsional potentials (dependent on three types of
6087 c        residues) and the torsional potentials dependent on all 20 types
6088 c        of residues computed from AM1 energy surfaces of terminally-blocked
6089 c        amino-acid residues.
6090       implicit real*8 (a-h,o-z)
6091       include 'DIMENSIONS'
6092       include 'COMMON.VAR'
6093       include 'COMMON.GEO'
6094       include 'COMMON.LOCAL'
6095       include 'COMMON.TORSION'
6096       include 'COMMON.SCCOR'
6097       include 'COMMON.INTERACT'
6098       include 'COMMON.DERIV'
6099       include 'COMMON.CHAIN'
6100       include 'COMMON.NAMES'
6101       include 'COMMON.IOUNITS'
6102       include 'COMMON.FFIELD'
6103       include 'COMMON.CONTROL'
6104       logical lprn
6105 C Set lprn=.true. for debugging
6106       lprn=.false.
6107 c      lprn=.true.
6108 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6109       esccor=0.0D0
6110       do i=itau_start,itau_end
6111         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6112         esccor_ii=0.0D0
6113         isccori=isccortyp(itype(i-2))
6114         isccori1=isccortyp(itype(i-1))
6115         phii=phi(i)
6116         do intertyp=1,3 !intertyp
6117 cc Added 09 May 2012 (Adasko)
6118 cc  Intertyp means interaction type of backbone mainchain correlation:
6119 c   1 = SC...Ca...Ca...Ca
6120 c   2 = Ca...Ca...Ca...SC
6121 c   3 = SC...Ca...Ca...SCi
6122         gloci=0.0D0
6123         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6124      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6125      &      (itype(i-1).eq.ntyp1)))
6126      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6127      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6128      &     .or.(itype(i).eq.ntyp1)))
6129      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6130      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6131      &      (itype(i-3).eq.ntyp1)))) cycle
6132         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6133         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6134      & cycle
6135        do j=1,nterm_sccor(isccori,isccori1)
6136           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6137           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6138           cosphi=dcos(j*tauangle(intertyp,i))
6139           sinphi=dsin(j*tauangle(intertyp,i))
6140            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6141            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6142          enddo
6143 C      write (iout,*)"EBACK_SC_COR",esccor,i
6144 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6145 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6146 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6147         if (lprn)
6148      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6149      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6150      &  (v1sccor(j,1,itori,itori1),j=1,6)
6151      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6152 c        gsccor_loc(i-3)=gloci
6153        enddo !intertyp
6154       enddo
6155       return
6156       end
6157 #ifdef FOURBODY
6158 c------------------------------------------------------------------------------
6159       subroutine multibody(ecorr)
6160 C This subroutine calculates multi-body contributions to energy following
6161 C the idea of Skolnick et al. If side chains I and J make a contact and
6162 C at the same time side chains I+1 and J+1 make a contact, an extra
6163 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6164       implicit real*8 (a-h,o-z)
6165       include 'DIMENSIONS'
6166       include 'COMMON.IOUNITS'
6167       include 'COMMON.DERIV'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.CONTACTS'
6170       include 'COMMON.CONTMAT'
6171       include 'COMMON.CORRMAT'
6172       double precision gx(3),gx1(3)
6173       logical lprn
6174
6175 C Set lprn=.true. for debugging
6176       lprn=.false.
6177
6178       if (lprn) then
6179         write (iout,'(a)') 'Contact function values:'
6180         do i=nnt,nct-2
6181           write (iout,'(i2,20(1x,i2,f10.5))')
6182      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6183         enddo
6184       endif
6185       ecorr=0.0D0
6186       do i=nnt,nct
6187         do j=1,3
6188           gradcorr(j,i)=0.0D0
6189           gradxorr(j,i)=0.0D0
6190         enddo
6191       enddo
6192       do i=nnt,nct-2
6193
6194         DO ISHIFT = 3,4
6195
6196         i1=i+ishift
6197         num_conti=num_cont(i)
6198         num_conti1=num_cont(i1)
6199         do jj=1,num_conti
6200           j=jcont(jj,i)
6201           do kk=1,num_conti1
6202             j1=jcont(kk,i1)
6203             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6204 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6205 cd   &                   ' ishift=',ishift
6206 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6207 C The system gains extra energy.
6208               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6209             endif   ! j1==j+-ishift
6210           enddo     ! kk
6211         enddo       ! jj
6212
6213         ENDDO ! ISHIFT
6214
6215       enddo         ! i
6216       return
6217       end
6218 c------------------------------------------------------------------------------
6219       double precision function esccorr(i,j,k,l,jj,kk)
6220       implicit real*8 (a-h,o-z)
6221       include 'DIMENSIONS'
6222       include 'COMMON.IOUNITS'
6223       include 'COMMON.DERIV'
6224       include 'COMMON.INTERACT'
6225       include 'COMMON.CONTACTS'
6226       include 'COMMON.CONTMAT'
6227       include 'COMMON.CORRMAT'
6228       double precision gx(3),gx1(3)
6229       logical lprn
6230       lprn=.false.
6231       eij=facont(jj,i)
6232       ekl=facont(kk,k)
6233 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6234 C Calculate the multi-body contribution to energy.
6235 C Calculate multi-body contributions to the gradient.
6236 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6237 cd   & k,l,(gacont(m,kk,k),m=1,3)
6238       do m=1,3
6239         gx(m) =ekl*gacont(m,jj,i)
6240         gx1(m)=eij*gacont(m,kk,k)
6241         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6242         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6243         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6244         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6245       enddo
6246       do m=i,j-1
6247         do ll=1,3
6248           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6249         enddo
6250       enddo
6251       do m=k,l-1
6252         do ll=1,3
6253           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6254         enddo
6255       enddo
6256       esccorr=-eij*ekl
6257       return
6258       end
6259 c------------------------------------------------------------------------------
6260       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6261 C This subroutine calculates multi-body contributions to hydrogen-bonding
6262       implicit real*8 (a-h,o-z)
6263       include 'DIMENSIONS'
6264       include 'COMMON.IOUNITS'
6265       include 'COMMON.FFIELD'
6266       include 'COMMON.DERIV'
6267       include 'COMMON.INTERACT'
6268       include 'COMMON.CONTACTS'
6269       include 'COMMON.CONTMAT'
6270       include 'COMMON.CORRMAT'
6271       double precision gx(3),gx1(3)
6272       logical lprn,ldone
6273
6274 C Set lprn=.true. for debugging
6275       lprn=.false.
6276       if (lprn) then
6277         write (iout,'(a)') 'Contact function values:'
6278         do i=nnt,nct-2
6279           write (iout,'(2i3,50(1x,i2,f5.2))')
6280      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6281      &    j=1,num_cont_hb(i))
6282         enddo
6283       endif
6284       ecorr=0.0D0
6285 C Remove the loop below after debugging !!!
6286       do i=nnt,nct
6287         do j=1,3
6288           gradcorr(j,i)=0.0D0
6289           gradxorr(j,i)=0.0D0
6290         enddo
6291       enddo
6292 C Calculate the local-electrostatic correlation terms
6293       do i=iatel_s,iatel_e+1
6294         i1=i+1
6295         num_conti=num_cont_hb(i)
6296         num_conti1=num_cont_hb(i+1)
6297         do jj=1,num_conti
6298           j=jcont_hb(jj,i)
6299           do kk=1,num_conti1
6300             j1=jcont_hb(kk,i1)
6301 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6302 c     &         ' jj=',jj,' kk=',kk
6303             if (j1.eq.j+1 .or. j1.eq.j-1) then
6304 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6305 C The system gains extra energy.
6306               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6307               n_corr=n_corr+1
6308             else if (j1.eq.j) then
6309 C Contacts I-J and I-(J+1) occur simultaneously.
6310 C The system loses extra energy.
6311 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6312             endif
6313           enddo ! kk
6314           do kk=1,num_conti
6315             j1=jcont_hb(kk,i)
6316 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6317 c    &         ' jj=',jj,' kk=',kk
6318             if (j1.eq.j+1) then
6319 C Contacts I-J and (I+1)-J occur simultaneously.
6320 C The system loses extra energy.
6321 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6322             endif ! j1==j+1
6323           enddo ! kk
6324         enddo ! jj
6325       enddo ! i
6326       return
6327       end
6328 c------------------------------------------------------------------------------
6329       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6330      &  n_corr1)
6331 C This subroutine calculates multi-body contributions to hydrogen-bonding
6332       implicit real*8 (a-h,o-z)
6333       include 'DIMENSIONS'
6334       include 'COMMON.IOUNITS'
6335 #ifdef MPI
6336       include "mpif.h"
6337 #endif
6338       include 'COMMON.FFIELD'
6339       include 'COMMON.DERIV'
6340       include 'COMMON.LOCAL'
6341       include 'COMMON.INTERACT'
6342       include 'COMMON.CONTACTS'
6343       include 'COMMON.CONTMAT'
6344       include 'COMMON.CORRMAT'
6345       include 'COMMON.CHAIN'
6346       include 'COMMON.CONTROL'
6347       include 'COMMON.SHIELD'
6348       double precision gx(3),gx1(3)
6349       integer num_cont_hb_old(maxres)
6350       logical lprn,ldone
6351       double precision eello4,eello5,eelo6,eello_turn6
6352       external eello4,eello5,eello6,eello_turn6
6353 C Set lprn=.true. for debugging
6354       lprn=.false.
6355       eturn6=0.0d0
6356       if (lprn) then
6357         write (iout,'(a)') 'Contact function values:'
6358         do i=nnt,nct-2
6359           write (iout,'(2i3,50(1x,i2,5f6.3))')
6360      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6361      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6362         enddo
6363       endif
6364       ecorr=0.0D0
6365       ecorr5=0.0d0
6366       ecorr6=0.0d0
6367 C Remove the loop below after debugging !!!
6368       do i=nnt,nct
6369         do j=1,3
6370           gradcorr(j,i)=0.0D0
6371           gradxorr(j,i)=0.0D0
6372         enddo
6373       enddo
6374 C Calculate the dipole-dipole interaction energies
6375       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6376       do i=iatel_s,iatel_e+1
6377         num_conti=num_cont_hb(i)
6378         do jj=1,num_conti
6379           j=jcont_hb(jj,i)
6380 #ifdef MOMENT
6381           call dipole(i,j,jj)
6382 #endif
6383         enddo
6384       enddo
6385       endif
6386 C Calculate the local-electrostatic correlation terms
6387 c                write (iout,*) "gradcorr5 in eello5 before loop"
6388 c                do iii=1,nres
6389 c                  write (iout,'(i5,3f10.5)')
6390 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6391 c                enddo
6392       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6393 c        write (iout,*) "corr loop i",i
6394         i1=i+1
6395         num_conti=num_cont_hb(i)
6396         num_conti1=num_cont_hb(i+1)
6397         do jj=1,num_conti
6398           j=jcont_hb(jj,i)
6399           jp=iabs(j)
6400           do kk=1,num_conti1
6401             j1=jcont_hb(kk,i1)
6402             jp1=iabs(j1)
6403 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6404 c     &         ' jj=',jj,' kk=',kk
6405 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6406             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6407      &          .or. j.lt.0 .and. j1.gt.0) .and.
6408      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6409 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6410 C The system gains extra energy.
6411               n_corr=n_corr+1
6412               sqd1=dsqrt(d_cont(jj,i))
6413               sqd2=dsqrt(d_cont(kk,i1))
6414               sred_geom = sqd1*sqd2
6415               IF (sred_geom.lt.cutoff_corr) THEN
6416                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6417      &            ekont,fprimcont)
6418 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6419 cd     &         ' jj=',jj,' kk=',kk
6420                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6421                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6422                 do l=1,3
6423                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6424                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6425                 enddo
6426                 n_corr1=n_corr1+1
6427 cd               write (iout,*) 'sred_geom=',sred_geom,
6428 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6429 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6430 cd               write (iout,*) "g_contij",g_contij
6431 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6432 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6433                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6434                 if (wcorr4.gt.0.0d0)
6435      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6436 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6437                   if (energy_dec.and.wcorr4.gt.0.0d0)
6438      1                 write (iout,'(a6,4i5,0pf7.3)')
6439      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6440 c                write (iout,*) "gradcorr5 before eello5"
6441 c                do iii=1,nres
6442 c                  write (iout,'(i5,3f10.5)')
6443 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6444 c                enddo
6445                 if (wcorr5.gt.0.0d0)
6446      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6447 c                write (iout,*) "gradcorr5 after eello5"
6448 c                do iii=1,nres
6449 c                  write (iout,'(i5,3f10.5)')
6450 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6451 c                enddo
6452                   if (energy_dec.and.wcorr5.gt.0.0d0)
6453      1                 write (iout,'(a6,4i5,0pf7.3)')
6454      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6455 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6456 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6457                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6458      &               .or. wturn6.eq.0.0d0))then
6459 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6460                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6461                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6462      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6463 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6464 cd     &            'ecorr6=',ecorr6
6465 cd                write (iout,'(4e15.5)') sred_geom,
6466 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6467 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6468 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6469                 else if (wturn6.gt.0.0d0
6470      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6471 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6472                   eturn6=eturn6+eello_turn6(i,jj,kk)
6473                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6474      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6475 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6476                 endif
6477               ENDIF
6478 1111          continue
6479             endif
6480           enddo ! kk
6481         enddo ! jj
6482       enddo ! i
6483       do i=1,nres
6484         num_cont_hb(i)=num_cont_hb_old(i)
6485       enddo
6486 c                write (iout,*) "gradcorr5 in eello5"
6487 c                do iii=1,nres
6488 c                  write (iout,'(i5,3f10.5)')
6489 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6490 c                enddo
6491       return
6492       end
6493 c------------------------------------------------------------------------------
6494       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6495       implicit real*8 (a-h,o-z)
6496       include 'DIMENSIONS'
6497       include 'COMMON.IOUNITS'
6498       include 'COMMON.DERIV'
6499       include 'COMMON.INTERACT'
6500       include 'COMMON.CONTACTS'
6501       include 'COMMON.CONTMAT'
6502       include 'COMMON.CORRMAT'
6503       include 'COMMON.SHIELD'
6504       include 'COMMON.CONTROL'
6505       double precision gx(3),gx1(3)
6506       logical lprn
6507       lprn=.false.
6508 C      print *,"wchodze",fac_shield(i),shield_mode
6509       eij=facont_hb(jj,i)
6510       ekl=facont_hb(kk,k)
6511       ees0pij=ees0p(jj,i)
6512       ees0pkl=ees0p(kk,k)
6513       ees0mij=ees0m(jj,i)
6514       ees0mkl=ees0m(kk,k)
6515       ekont=eij*ekl
6516       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6517 C*
6518 C     & fac_shield(i)**2*fac_shield(j)**2
6519 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6520 C Following 4 lines for diagnostics.
6521 cd    ees0pkl=0.0D0
6522 cd    ees0pij=1.0D0
6523 cd    ees0mkl=0.0D0
6524 cd    ees0mij=1.0D0
6525 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6526 c     & 'Contacts ',i,j,
6527 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6528 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6529 c     & 'gradcorr_long'
6530 C Calculate the multi-body contribution to energy.
6531 C      ecorr=ecorr+ekont*ees
6532 C Calculate multi-body contributions to the gradient.
6533       coeffpees0pij=coeffp*ees0pij
6534       coeffmees0mij=coeffm*ees0mij
6535       coeffpees0pkl=coeffp*ees0pkl
6536       coeffmees0mkl=coeffm*ees0mkl
6537       do ll=1,3
6538 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6539         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6540      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6541      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6542         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6543      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6544      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6545 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6546         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6547      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6548      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6549         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6550      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6551      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6552         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6553      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6554      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6555         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6556         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6557         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6558      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6559      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6560         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6561         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6562 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6563       enddo
6564 c      write (iout,*)
6565 cgrad      do m=i+1,j-1
6566 cgrad        do ll=1,3
6567 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6568 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6569 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6570 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6571 cgrad        enddo
6572 cgrad      enddo
6573 cgrad      do m=k+1,l-1
6574 cgrad        do ll=1,3
6575 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6576 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6577 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6578 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6579 cgrad        enddo
6580 cgrad      enddo
6581 c      write (iout,*) "ehbcorr",ekont*ees
6582 C      print *,ekont,ees,i,k
6583       ehbcorr=ekont*ees
6584 C now gradient over shielding
6585 C      return
6586       if (shield_mode.gt.0) then
6587        j=ees0plist(jj,i)
6588        l=ees0plist(kk,k)
6589 C        print *,i,j,fac_shield(i),fac_shield(j),
6590 C     &fac_shield(k),fac_shield(l)
6591         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6592      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6593           do ilist=1,ishield_list(i)
6594            iresshield=shield_list(ilist,i)
6595            do m=1,3
6596            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6597 C     &      *2.0
6598            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6599      &              rlocshield
6600      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6601             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6602      &+rlocshield
6603            enddo
6604           enddo
6605           do ilist=1,ishield_list(j)
6606            iresshield=shield_list(ilist,j)
6607            do m=1,3
6608            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6609 C     &     *2.0
6610            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6611      &              rlocshield
6612      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6613            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6614      &     +rlocshield
6615            enddo
6616           enddo
6617
6618           do ilist=1,ishield_list(k)
6619            iresshield=shield_list(ilist,k)
6620            do m=1,3
6621            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6622 C     &     *2.0
6623            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6624      &              rlocshield
6625      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6626            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6627      &     +rlocshield
6628            enddo
6629           enddo
6630           do ilist=1,ishield_list(l)
6631            iresshield=shield_list(ilist,l)
6632            do m=1,3
6633            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6634 C     &     *2.0
6635            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6636      &              rlocshield
6637      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6638            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6639      &     +rlocshield
6640            enddo
6641           enddo
6642 C          print *,gshieldx(m,iresshield)
6643           do m=1,3
6644             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6645      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6646             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6647      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6648             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6649      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6650             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6651      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6652
6653             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6654      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6655             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6656      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6657             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6658      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6659             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6660      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6661
6662            enddo
6663       endif
6664       endif
6665       return
6666       end
6667 #ifdef MOMENT
6668 C---------------------------------------------------------------------------
6669       subroutine dipole(i,j,jj)
6670       implicit real*8 (a-h,o-z)
6671       include 'DIMENSIONS'
6672       include 'COMMON.IOUNITS'
6673       include 'COMMON.CHAIN'
6674       include 'COMMON.FFIELD'
6675       include 'COMMON.DERIV'
6676       include 'COMMON.INTERACT'
6677       include 'COMMON.CONTACTS'
6678       include 'COMMON.CONTMAT'
6679       include 'COMMON.CORRMAT'
6680       include 'COMMON.TORSION'
6681       include 'COMMON.VAR'
6682       include 'COMMON.GEO'
6683       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6684      &  auxmat(2,2)
6685       iti1 = itortyp(itype(i+1))
6686       if (j.lt.nres-1) then
6687         itj1 = itype2loc(itype(j+1))
6688       else
6689         itj1=nloctyp
6690       endif
6691       do iii=1,2
6692         dipi(iii,1)=Ub2(iii,i)
6693         dipderi(iii)=Ub2der(iii,i)
6694         dipi(iii,2)=b1(iii,i+1)
6695         dipj(iii,1)=Ub2(iii,j)
6696         dipderj(iii)=Ub2der(iii,j)
6697         dipj(iii,2)=b1(iii,j+1)
6698       enddo
6699       kkk=0
6700       do iii=1,2
6701         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6702         do jjj=1,2
6703           kkk=kkk+1
6704           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6705         enddo
6706       enddo
6707       do kkk=1,5
6708         do lll=1,3
6709           mmm=0
6710           do iii=1,2
6711             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6712      &        auxvec(1))
6713             do jjj=1,2
6714               mmm=mmm+1
6715               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6716             enddo
6717           enddo
6718         enddo
6719       enddo
6720       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6721       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6722       do iii=1,2
6723         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6724       enddo
6725       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6726       do iii=1,2
6727         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6728       enddo
6729       return
6730       end
6731 #endif
6732 C---------------------------------------------------------------------------
6733       subroutine calc_eello(i,j,k,l,jj,kk)
6734 C
6735 C This subroutine computes matrices and vectors needed to calculate
6736 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6737 C
6738       implicit real*8 (a-h,o-z)
6739       include 'DIMENSIONS'
6740       include 'COMMON.IOUNITS'
6741       include 'COMMON.CHAIN'
6742       include 'COMMON.DERIV'
6743       include 'COMMON.INTERACT'
6744       include 'COMMON.CONTACTS'
6745       include 'COMMON.CONTMAT'
6746       include 'COMMON.CORRMAT'
6747       include 'COMMON.TORSION'
6748       include 'COMMON.VAR'
6749       include 'COMMON.GEO'
6750       include 'COMMON.FFIELD'
6751       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6752      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6753       logical lprn
6754       common /kutas/ lprn
6755 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6756 cd     & ' jj=',jj,' kk=',kk
6757 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6758 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6759 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6760       do iii=1,2
6761         do jjj=1,2
6762           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6763           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6764         enddo
6765       enddo
6766       call transpose2(aa1(1,1),aa1t(1,1))
6767       call transpose2(aa2(1,1),aa2t(1,1))
6768       do kkk=1,5
6769         do lll=1,3
6770           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6771      &      aa1tder(1,1,lll,kkk))
6772           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6773      &      aa2tder(1,1,lll,kkk))
6774         enddo
6775       enddo
6776       if (l.eq.j+1) then
6777 C parallel orientation of the two CA-CA-CA frames.
6778         if (i.gt.1) then
6779           iti=itype2loc(itype(i))
6780         else
6781           iti=nloctyp
6782         endif
6783         itk1=itype2loc(itype(k+1))
6784         itj=itype2loc(itype(j))
6785         if (l.lt.nres-1) then
6786           itl1=itype2loc(itype(l+1))
6787         else
6788           itl1=nloctyp
6789         endif
6790 C A1 kernel(j+1) A2T
6791 cd        do iii=1,2
6792 cd          write (iout,'(3f10.5,5x,3f10.5)')
6793 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6794 cd        enddo
6795         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6796      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6797      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6798 C Following matrices are needed only for 6-th order cumulants
6799         IF (wcorr6.gt.0.0d0) THEN
6800         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6801      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6802      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6803         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6804      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6805      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6806      &   ADtEAderx(1,1,1,1,1,1))
6807         lprn=.false.
6808         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6809      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6810      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6811      &   ADtEA1derx(1,1,1,1,1,1))
6812         ENDIF
6813 C End 6-th order cumulants
6814 cd        lprn=.false.
6815 cd        if (lprn) then
6816 cd        write (2,*) 'In calc_eello6'
6817 cd        do iii=1,2
6818 cd          write (2,*) 'iii=',iii
6819 cd          do kkk=1,5
6820 cd            write (2,*) 'kkk=',kkk
6821 cd            do jjj=1,2
6822 cd              write (2,'(3(2f10.5),5x)')
6823 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6824 cd            enddo
6825 cd          enddo
6826 cd        enddo
6827 cd        endif
6828         call transpose2(EUgder(1,1,k),auxmat(1,1))
6829         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6830         call transpose2(EUg(1,1,k),auxmat(1,1))
6831         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6832         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6833         do iii=1,2
6834           do kkk=1,5
6835             do lll=1,3
6836               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6837      &          EAEAderx(1,1,lll,kkk,iii,1))
6838             enddo
6839           enddo
6840         enddo
6841 C A1T kernel(i+1) A2
6842         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6843      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6844      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6845 C Following matrices are needed only for 6-th order cumulants
6846         IF (wcorr6.gt.0.0d0) THEN
6847         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6848      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6849      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6850         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6851      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6852      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6853      &   ADtEAderx(1,1,1,1,1,2))
6854         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6855      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6856      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6857      &   ADtEA1derx(1,1,1,1,1,2))
6858         ENDIF
6859 C End 6-th order cumulants
6860         call transpose2(EUgder(1,1,l),auxmat(1,1))
6861         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6862         call transpose2(EUg(1,1,l),auxmat(1,1))
6863         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6864         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6865         do iii=1,2
6866           do kkk=1,5
6867             do lll=1,3
6868               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6869      &          EAEAderx(1,1,lll,kkk,iii,2))
6870             enddo
6871           enddo
6872         enddo
6873 C AEAb1 and AEAb2
6874 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6875 C They are needed only when the fifth- or the sixth-order cumulants are
6876 C indluded.
6877         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6878         call transpose2(AEA(1,1,1),auxmat(1,1))
6879         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6880         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6881         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6882         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6883         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6884         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6885         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6886         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6887         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6888         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6889         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6890         call transpose2(AEA(1,1,2),auxmat(1,1))
6891         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6892         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6893         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6894         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6895         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6896         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6897         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6898         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6899         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6900         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6901         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6902 C Calculate the Cartesian derivatives of the vectors.
6903         do iii=1,2
6904           do kkk=1,5
6905             do lll=1,3
6906               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6907               call matvec2(auxmat(1,1),b1(1,i),
6908      &          AEAb1derx(1,lll,kkk,iii,1,1))
6909               call matvec2(auxmat(1,1),Ub2(1,i),
6910      &          AEAb2derx(1,lll,kkk,iii,1,1))
6911               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6912      &          AEAb1derx(1,lll,kkk,iii,2,1))
6913               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6914      &          AEAb2derx(1,lll,kkk,iii,2,1))
6915               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6916               call matvec2(auxmat(1,1),b1(1,j),
6917      &          AEAb1derx(1,lll,kkk,iii,1,2))
6918               call matvec2(auxmat(1,1),Ub2(1,j),
6919      &          AEAb2derx(1,lll,kkk,iii,1,2))
6920               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6921      &          AEAb1derx(1,lll,kkk,iii,2,2))
6922               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6923      &          AEAb2derx(1,lll,kkk,iii,2,2))
6924             enddo
6925           enddo
6926         enddo
6927         ENDIF
6928 C End vectors
6929       else
6930 C Antiparallel orientation of the two CA-CA-CA frames.
6931         if (i.gt.1) then
6932           iti=itype2loc(itype(i))
6933         else
6934           iti=nloctyp
6935         endif
6936         itk1=itype2loc(itype(k+1))
6937         itl=itype2loc(itype(l))
6938         itj=itype2loc(itype(j))
6939         if (j.lt.nres-1) then
6940           itj1=itype2loc(itype(j+1))
6941         else
6942           itj1=nloctyp
6943         endif
6944 C A2 kernel(j-1)T A1T
6945         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6946      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6947      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6948 C Following matrices are needed only for 6-th order cumulants
6949         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6950      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6951         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6952      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6953      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6954         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6955      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6956      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6957      &   ADtEAderx(1,1,1,1,1,1))
6958         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6959      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6960      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6961      &   ADtEA1derx(1,1,1,1,1,1))
6962         ENDIF
6963 C End 6-th order cumulants
6964         call transpose2(EUgder(1,1,k),auxmat(1,1))
6965         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6966         call transpose2(EUg(1,1,k),auxmat(1,1))
6967         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6968         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6969         do iii=1,2
6970           do kkk=1,5
6971             do lll=1,3
6972               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6973      &          EAEAderx(1,1,lll,kkk,iii,1))
6974             enddo
6975           enddo
6976         enddo
6977 C A2T kernel(i+1)T A1
6978         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6979      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6980      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6981 C Following matrices are needed only for 6-th order cumulants
6982         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6983      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6984         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6985      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6986      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6987         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6988      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6989      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6990      &   ADtEAderx(1,1,1,1,1,2))
6991         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6992      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6993      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6994      &   ADtEA1derx(1,1,1,1,1,2))
6995         ENDIF
6996 C End 6-th order cumulants
6997         call transpose2(EUgder(1,1,j),auxmat(1,1))
6998         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6999         call transpose2(EUg(1,1,j),auxmat(1,1))
7000         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7001         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7002         do iii=1,2
7003           do kkk=1,5
7004             do lll=1,3
7005               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7006      &          EAEAderx(1,1,lll,kkk,iii,2))
7007             enddo
7008           enddo
7009         enddo
7010 C AEAb1 and AEAb2
7011 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7012 C They are needed only when the fifth- or the sixth-order cumulants are
7013 C indluded.
7014         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7015      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7016         call transpose2(AEA(1,1,1),auxmat(1,1))
7017         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7018         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7019         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7020         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7021         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7022         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7023         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7024         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7025         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7026         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7027         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7028         call transpose2(AEA(1,1,2),auxmat(1,1))
7029         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7030         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7031         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7032         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7033         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7034         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7035         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7036         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7037         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7038         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7039         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7040 C Calculate the Cartesian derivatives of the vectors.
7041         do iii=1,2
7042           do kkk=1,5
7043             do lll=1,3
7044               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7045               call matvec2(auxmat(1,1),b1(1,i),
7046      &          AEAb1derx(1,lll,kkk,iii,1,1))
7047               call matvec2(auxmat(1,1),Ub2(1,i),
7048      &          AEAb2derx(1,lll,kkk,iii,1,1))
7049               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7050      &          AEAb1derx(1,lll,kkk,iii,2,1))
7051               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7052      &          AEAb2derx(1,lll,kkk,iii,2,1))
7053               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7054               call matvec2(auxmat(1,1),b1(1,l),
7055      &          AEAb1derx(1,lll,kkk,iii,1,2))
7056               call matvec2(auxmat(1,1),Ub2(1,l),
7057      &          AEAb2derx(1,lll,kkk,iii,1,2))
7058               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7059      &          AEAb1derx(1,lll,kkk,iii,2,2))
7060               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7061      &          AEAb2derx(1,lll,kkk,iii,2,2))
7062             enddo
7063           enddo
7064         enddo
7065         ENDIF
7066 C End vectors
7067       endif
7068       return
7069       end
7070 C---------------------------------------------------------------------------
7071       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7072      &  KK,KKderg,AKA,AKAderg,AKAderx)
7073       implicit none
7074       integer nderg
7075       logical transp
7076       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7077      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7078      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7079       integer iii,kkk,lll
7080       integer jjj,mmm
7081       logical lprn
7082       common /kutas/ lprn
7083       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7084       do iii=1,nderg
7085         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7086      &    AKAderg(1,1,iii))
7087       enddo
7088 cd      if (lprn) write (2,*) 'In kernel'
7089       do kkk=1,5
7090 cd        if (lprn) write (2,*) 'kkk=',kkk
7091         do lll=1,3
7092           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7093      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7094 cd          if (lprn) then
7095 cd            write (2,*) 'lll=',lll
7096 cd            write (2,*) 'iii=1'
7097 cd            do jjj=1,2
7098 cd              write (2,'(3(2f10.5),5x)')
7099 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7100 cd            enddo
7101 cd          endif
7102           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7103      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7104 cd          if (lprn) then
7105 cd            write (2,*) 'lll=',lll
7106 cd            write (2,*) 'iii=2'
7107 cd            do jjj=1,2
7108 cd              write (2,'(3(2f10.5),5x)')
7109 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7110 cd            enddo
7111 cd          endif
7112         enddo
7113       enddo
7114       return
7115       end
7116 C---------------------------------------------------------------------------
7117       double precision function eello4(i,j,k,l,jj,kk)
7118       implicit real*8 (a-h,o-z)
7119       include 'DIMENSIONS'
7120       include 'COMMON.IOUNITS'
7121       include 'COMMON.CHAIN'
7122       include 'COMMON.DERIV'
7123       include 'COMMON.INTERACT'
7124       include 'COMMON.CONTACTS'
7125       include 'COMMON.CONTMAT'
7126       include 'COMMON.CORRMAT'
7127       include 'COMMON.TORSION'
7128       include 'COMMON.VAR'
7129       include 'COMMON.GEO'
7130       double precision pizda(2,2),ggg1(3),ggg2(3)
7131 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7132 cd        eello4=0.0d0
7133 cd        return
7134 cd      endif
7135 cd      print *,'eello4:',i,j,k,l,jj,kk
7136 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7137 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7138 cold      eij=facont_hb(jj,i)
7139 cold      ekl=facont_hb(kk,k)
7140 cold      ekont=eij*ekl
7141       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7142       if (calc_grad) then
7143 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7144       gcorr_loc(k-1)=gcorr_loc(k-1)
7145      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7146       if (l.eq.j+1) then
7147         gcorr_loc(l-1)=gcorr_loc(l-1)
7148      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7149       else
7150         gcorr_loc(j-1)=gcorr_loc(j-1)
7151      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7152       endif
7153       do iii=1,2
7154         do kkk=1,5
7155           do lll=1,3
7156             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7157      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7158 cd            derx(lll,kkk,iii)=0.0d0
7159           enddo
7160         enddo
7161       enddo
7162 cd      gcorr_loc(l-1)=0.0d0
7163 cd      gcorr_loc(j-1)=0.0d0
7164 cd      gcorr_loc(k-1)=0.0d0
7165 cd      eel4=1.0d0
7166 cd      write (iout,*)'Contacts have occurred for peptide groups',
7167 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7168 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7169       if (j.lt.nres-1) then
7170         j1=j+1
7171         j2=j-1
7172       else
7173         j1=j-1
7174         j2=j-2
7175       endif
7176       if (l.lt.nres-1) then
7177         l1=l+1
7178         l2=l-1
7179       else
7180         l1=l-1
7181         l2=l-2
7182       endif
7183       do ll=1,3
7184 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7185 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7186         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7187         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7188 cgrad        ghalf=0.5d0*ggg1(ll)
7189         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7190         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7191         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7192         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7193         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7194         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7195 cgrad        ghalf=0.5d0*ggg2(ll)
7196         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7197         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7198         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7199         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7200         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7201         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7202       enddo
7203 cgrad      do m=i+1,j-1
7204 cgrad        do ll=1,3
7205 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7206 cgrad        enddo
7207 cgrad      enddo
7208 cgrad      do m=k+1,l-1
7209 cgrad        do ll=1,3
7210 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7211 cgrad        enddo
7212 cgrad      enddo
7213 cgrad      do m=i+2,j2
7214 cgrad        do ll=1,3
7215 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7216 cgrad        enddo
7217 cgrad      enddo
7218 cgrad      do m=k+2,l2
7219 cgrad        do ll=1,3
7220 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7221 cgrad        enddo
7222 cgrad      enddo
7223 cd      do iii=1,nres-3
7224 cd        write (2,*) iii,gcorr_loc(iii)
7225 cd      enddo
7226       endif ! calc_grad
7227       eello4=ekont*eel4
7228 cd      write (2,*) 'ekont',ekont
7229 cd      write (iout,*) 'eello4',ekont*eel4
7230       return
7231       end
7232 C---------------------------------------------------------------------------
7233       double precision function eello5(i,j,k,l,jj,kk)
7234       implicit real*8 (a-h,o-z)
7235       include 'DIMENSIONS'
7236       include 'COMMON.IOUNITS'
7237       include 'COMMON.CHAIN'
7238       include 'COMMON.DERIV'
7239       include 'COMMON.INTERACT'
7240       include 'COMMON.CONTACTS'
7241       include 'COMMON.CONTMAT'
7242       include 'COMMON.CORRMAT'
7243       include 'COMMON.TORSION'
7244       include 'COMMON.VAR'
7245       include 'COMMON.GEO'
7246       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7247       double precision ggg1(3),ggg2(3)
7248 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7249 C                                                                              C
7250 C                            Parallel chains                                   C
7251 C                                                                              C
7252 C          o             o                   o             o                   C
7253 C         /l\           / \             \   / \           / \   /              C
7254 C        /   \         /   \             \ /   \         /   \ /               C
7255 C       j| o |l1       | o |              o| o |         | o |o                C
7256 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7257 C      \i/   \         /   \ /             /   \         /   \                 C
7258 C       o    k1             o                                                  C
7259 C         (I)          (II)                (III)          (IV)                 C
7260 C                                                                              C
7261 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7262 C                                                                              C
7263 C                            Antiparallel chains                               C
7264 C                                                                              C
7265 C          o             o                   o             o                   C
7266 C         /j\           / \             \   / \           / \   /              C
7267 C        /   \         /   \             \ /   \         /   \ /               C
7268 C      j1| o |l        | o |              o| o |         | o |o                C
7269 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7270 C      \i/   \         /   \ /             /   \         /   \                 C
7271 C       o     k1            o                                                  C
7272 C         (I)          (II)                (III)          (IV)                 C
7273 C                                                                              C
7274 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7275 C                                                                              C
7276 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7277 C                                                                              C
7278 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7279 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7280 cd        eello5=0.0d0
7281 cd        return
7282 cd      endif
7283 cd      write (iout,*)
7284 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7285 cd     &   ' and',k,l
7286       itk=itype2loc(itype(k))
7287       itl=itype2loc(itype(l))
7288       itj=itype2loc(itype(j))
7289       eello5_1=0.0d0
7290       eello5_2=0.0d0
7291       eello5_3=0.0d0
7292       eello5_4=0.0d0
7293 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7294 cd     &   eel5_3_num,eel5_4_num)
7295       do iii=1,2
7296         do kkk=1,5
7297           do lll=1,3
7298             derx(lll,kkk,iii)=0.0d0
7299           enddo
7300         enddo
7301       enddo
7302 cd      eij=facont_hb(jj,i)
7303 cd      ekl=facont_hb(kk,k)
7304 cd      ekont=eij*ekl
7305 cd      write (iout,*)'Contacts have occurred for peptide groups',
7306 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7307 cd      goto 1111
7308 C Contribution from the graph I.
7309 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7310 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7311       call transpose2(EUg(1,1,k),auxmat(1,1))
7312       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7313       vv(1)=pizda(1,1)-pizda(2,2)
7314       vv(2)=pizda(1,2)+pizda(2,1)
7315       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7316      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7317       if (calc_grad) then
7318 C Explicit gradient in virtual-dihedral angles.
7319       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7320      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7321      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7322       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7323       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7324       vv(1)=pizda(1,1)-pizda(2,2)
7325       vv(2)=pizda(1,2)+pizda(2,1)
7326       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7327      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7328      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7329       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7330       vv(1)=pizda(1,1)-pizda(2,2)
7331       vv(2)=pizda(1,2)+pizda(2,1)
7332       if (l.eq.j+1) then
7333         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7334      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7335      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7336       else
7337         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7338      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7339      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7340       endif
7341 C Cartesian gradient
7342       do iii=1,2
7343         do kkk=1,5
7344           do lll=1,3
7345             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7346      &        pizda(1,1))
7347             vv(1)=pizda(1,1)-pizda(2,2)
7348             vv(2)=pizda(1,2)+pizda(2,1)
7349             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7350      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7351      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7352           enddo
7353         enddo
7354       enddo
7355       endif ! calc_grad
7356 c      goto 1112
7357 c1111  continue
7358 C Contribution from graph II
7359       call transpose2(EE(1,1,k),auxmat(1,1))
7360       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7361       vv(1)=pizda(1,1)+pizda(2,2)
7362       vv(2)=pizda(2,1)-pizda(1,2)
7363       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7364      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7365       if (calc_grad) then
7366 C Explicit gradient in virtual-dihedral angles.
7367       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7368      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7369       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7370       vv(1)=pizda(1,1)+pizda(2,2)
7371       vv(2)=pizda(2,1)-pizda(1,2)
7372       if (l.eq.j+1) then
7373         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7374      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7375      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7376       else
7377         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7378      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7379      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7380       endif
7381 C Cartesian gradient
7382       do iii=1,2
7383         do kkk=1,5
7384           do lll=1,3
7385             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7386      &        pizda(1,1))
7387             vv(1)=pizda(1,1)+pizda(2,2)
7388             vv(2)=pizda(2,1)-pizda(1,2)
7389             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7390      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7391      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7392           enddo
7393         enddo
7394       enddo
7395       endif ! calc_grad
7396 cd      goto 1112
7397 cd1111  continue
7398       if (l.eq.j+1) then
7399 cd        goto 1110
7400 C Parallel orientation
7401 C Contribution from graph III
7402         call transpose2(EUg(1,1,l),auxmat(1,1))
7403         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7404         vv(1)=pizda(1,1)-pizda(2,2)
7405         vv(2)=pizda(1,2)+pizda(2,1)
7406         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7408         if (calc_grad) then
7409 C Explicit gradient in virtual-dihedral angles.
7410         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7411      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7412      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7413         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7414         vv(1)=pizda(1,1)-pizda(2,2)
7415         vv(2)=pizda(1,2)+pizda(2,1)
7416         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7417      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7418      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7419         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7420         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7421         vv(1)=pizda(1,1)-pizda(2,2)
7422         vv(2)=pizda(1,2)+pizda(2,1)
7423         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7424      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7425      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7426 C Cartesian gradient
7427         do iii=1,2
7428           do kkk=1,5
7429             do lll=1,3
7430               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7431      &          pizda(1,1))
7432               vv(1)=pizda(1,1)-pizda(2,2)
7433               vv(2)=pizda(1,2)+pizda(2,1)
7434               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7435      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7436      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7437             enddo
7438           enddo
7439         enddo
7440 cd        goto 1112
7441 C Contribution from graph IV
7442 cd1110    continue
7443         call transpose2(EE(1,1,l),auxmat(1,1))
7444         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7445         vv(1)=pizda(1,1)+pizda(2,2)
7446         vv(2)=pizda(2,1)-pizda(1,2)
7447         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7448      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7449 C Explicit gradient in virtual-dihedral angles.
7450         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7451      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7452         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7453         vv(1)=pizda(1,1)+pizda(2,2)
7454         vv(2)=pizda(2,1)-pizda(1,2)
7455         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7456      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7457      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7458 C Cartesian gradient
7459         do iii=1,2
7460           do kkk=1,5
7461             do lll=1,3
7462               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7463      &          pizda(1,1))
7464               vv(1)=pizda(1,1)+pizda(2,2)
7465               vv(2)=pizda(2,1)-pizda(1,2)
7466               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7467      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7468      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7469             enddo
7470           enddo
7471         enddo
7472         endif ! calc_grad
7473       else
7474 C Antiparallel orientation
7475 C Contribution from graph III
7476 c        goto 1110
7477         call transpose2(EUg(1,1,j),auxmat(1,1))
7478         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7479         vv(1)=pizda(1,1)-pizda(2,2)
7480         vv(2)=pizda(1,2)+pizda(2,1)
7481         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7483         if (calc_grad) then
7484 C Explicit gradient in virtual-dihedral angles.
7485         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7486      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7487      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7488         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7489         vv(1)=pizda(1,1)-pizda(2,2)
7490         vv(2)=pizda(1,2)+pizda(2,1)
7491         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7492      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7493      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7494         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7495         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7496         vv(1)=pizda(1,1)-pizda(2,2)
7497         vv(2)=pizda(1,2)+pizda(2,1)
7498         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7499      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7500      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7501 C Cartesian gradient
7502         do iii=1,2
7503           do kkk=1,5
7504             do lll=1,3
7505               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7506      &          pizda(1,1))
7507               vv(1)=pizda(1,1)-pizda(2,2)
7508               vv(2)=pizda(1,2)+pizda(2,1)
7509               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7510      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7511      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7512             enddo
7513           enddo
7514         enddo
7515         endif ! calc_grad
7516 cd        goto 1112
7517 C Contribution from graph IV
7518 1110    continue
7519         call transpose2(EE(1,1,j),auxmat(1,1))
7520         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7521         vv(1)=pizda(1,1)+pizda(2,2)
7522         vv(2)=pizda(2,1)-pizda(1,2)
7523         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7524      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7525         if (calc_grad) then
7526 C Explicit gradient in virtual-dihedral angles.
7527         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7528      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7529         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7530         vv(1)=pizda(1,1)+pizda(2,2)
7531         vv(2)=pizda(2,1)-pizda(1,2)
7532         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7533      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7534      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7535 C Cartesian gradient
7536         do iii=1,2
7537           do kkk=1,5
7538             do lll=1,3
7539               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7540      &          pizda(1,1))
7541               vv(1)=pizda(1,1)+pizda(2,2)
7542               vv(2)=pizda(2,1)-pizda(1,2)
7543               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7544      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7545      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7546             enddo
7547           enddo
7548         enddo
7549         endif ! calc_grad
7550       endif
7551 1112  continue
7552       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7553 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7554 cd        write (2,*) 'ijkl',i,j,k,l
7555 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7556 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7557 cd      endif
7558 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7559 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7560 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7561 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7562       if (calc_grad) then
7563       if (j.lt.nres-1) then
7564         j1=j+1
7565         j2=j-1
7566       else
7567         j1=j-1
7568         j2=j-2
7569       endif
7570       if (l.lt.nres-1) then
7571         l1=l+1
7572         l2=l-1
7573       else
7574         l1=l-1
7575         l2=l-2
7576       endif
7577 cd      eij=1.0d0
7578 cd      ekl=1.0d0
7579 cd      ekont=1.0d0
7580 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7581 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7582 C        summed up outside the subrouine as for the other subroutines
7583 C        handling long-range interactions. The old code is commented out
7584 C        with "cgrad" to keep track of changes.
7585       do ll=1,3
7586 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7587 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7588         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7589         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7590 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7591 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7592 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7593 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7594 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7595 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7596 c     &   gradcorr5ij,
7597 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7598 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7599 cgrad        ghalf=0.5d0*ggg1(ll)
7600 cd        ghalf=0.0d0
7601         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7602         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7603         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7604         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7605         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7606         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7607 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7608 cgrad        ghalf=0.5d0*ggg2(ll)
7609 cd        ghalf=0.0d0
7610         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7611         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7612         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7613         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7614         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7615         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7616       enddo
7617       endif ! calc_grad
7618 cd      goto 1112
7619 cgrad      do m=i+1,j-1
7620 cgrad        do ll=1,3
7621 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7622 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7623 cgrad        enddo
7624 cgrad      enddo
7625 cgrad      do m=k+1,l-1
7626 cgrad        do ll=1,3
7627 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7628 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7629 cgrad        enddo
7630 cgrad      enddo
7631 c1112  continue
7632 cgrad      do m=i+2,j2
7633 cgrad        do ll=1,3
7634 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7635 cgrad        enddo
7636 cgrad      enddo
7637 cgrad      do m=k+2,l2
7638 cgrad        do ll=1,3
7639 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7640 cgrad        enddo
7641 cgrad      enddo
7642 cd      do iii=1,nres-3
7643 cd        write (2,*) iii,g_corr5_loc(iii)
7644 cd      enddo
7645       eello5=ekont*eel5
7646 cd      write (2,*) 'ekont',ekont
7647 cd      write (iout,*) 'eello5',ekont*eel5
7648       return
7649       end
7650 c--------------------------------------------------------------------------
7651       double precision function eello6(i,j,k,l,jj,kk)
7652       implicit real*8 (a-h,o-z)
7653       include 'DIMENSIONS'
7654       include 'COMMON.IOUNITS'
7655       include 'COMMON.CHAIN'
7656       include 'COMMON.DERIV'
7657       include 'COMMON.INTERACT'
7658       include 'COMMON.CONTACTS'
7659       include 'COMMON.CONTMAT'
7660       include 'COMMON.CORRMAT'
7661       include 'COMMON.TORSION'
7662       include 'COMMON.VAR'
7663       include 'COMMON.GEO'
7664       include 'COMMON.FFIELD'
7665       double precision ggg1(3),ggg2(3)
7666 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7667 cd        eello6=0.0d0
7668 cd        return
7669 cd      endif
7670 cd      write (iout,*)
7671 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7672 cd     &   ' and',k,l
7673       eello6_1=0.0d0
7674       eello6_2=0.0d0
7675       eello6_3=0.0d0
7676       eello6_4=0.0d0
7677       eello6_5=0.0d0
7678       eello6_6=0.0d0
7679 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7680 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7681       do iii=1,2
7682         do kkk=1,5
7683           do lll=1,3
7684             derx(lll,kkk,iii)=0.0d0
7685           enddo
7686         enddo
7687       enddo
7688 cd      eij=facont_hb(jj,i)
7689 cd      ekl=facont_hb(kk,k)
7690 cd      ekont=eij*ekl
7691 cd      eij=1.0d0
7692 cd      ekl=1.0d0
7693 cd      ekont=1.0d0
7694       if (l.eq.j+1) then
7695         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7696         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7697         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7698         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7699         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7700         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7701       else
7702         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7703         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7704         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7705         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7706         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7707           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7708         else
7709           eello6_5=0.0d0
7710         endif
7711         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7712       endif
7713 C If turn contributions are considered, they will be handled separately.
7714       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7715 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7716 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7717 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7718 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7719 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7720 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7721 cd      goto 1112
7722       if (calc_grad) then
7723       if (j.lt.nres-1) then
7724         j1=j+1
7725         j2=j-1
7726       else
7727         j1=j-1
7728         j2=j-2
7729       endif
7730       if (l.lt.nres-1) then
7731         l1=l+1
7732         l2=l-1
7733       else
7734         l1=l-1
7735         l2=l-2
7736       endif
7737       do ll=1,3
7738 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7739 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7740 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7741 cgrad        ghalf=0.5d0*ggg1(ll)
7742 cd        ghalf=0.0d0
7743         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7744         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7745         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7746         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7747         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7748         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7749         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7750         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7751 cgrad        ghalf=0.5d0*ggg2(ll)
7752 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7753 cd        ghalf=0.0d0
7754         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7755         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7756         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7757         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7758         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7759         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7760       enddo
7761       endif ! calc_grad
7762 cd      goto 1112
7763 cgrad      do m=i+1,j-1
7764 cgrad        do ll=1,3
7765 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7766 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7767 cgrad        enddo
7768 cgrad      enddo
7769 cgrad      do m=k+1,l-1
7770 cgrad        do ll=1,3
7771 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7772 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7773 cgrad        enddo
7774 cgrad      enddo
7775 cgrad1112  continue
7776 cgrad      do m=i+2,j2
7777 cgrad        do ll=1,3
7778 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7779 cgrad        enddo
7780 cgrad      enddo
7781 cgrad      do m=k+2,l2
7782 cgrad        do ll=1,3
7783 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7784 cgrad        enddo
7785 cgrad      enddo
7786 cd      do iii=1,nres-3
7787 cd        write (2,*) iii,g_corr6_loc(iii)
7788 cd      enddo
7789       eello6=ekont*eel6
7790 cd      write (2,*) 'ekont',ekont
7791 cd      write (iout,*) 'eello6',ekont*eel6
7792       return
7793       end
7794 c--------------------------------------------------------------------------
7795       double precision function eello6_graph1(i,j,k,l,imat,swap)
7796       implicit real*8 (a-h,o-z)
7797       include 'DIMENSIONS'
7798       include 'COMMON.IOUNITS'
7799       include 'COMMON.CHAIN'
7800       include 'COMMON.DERIV'
7801       include 'COMMON.INTERACT'
7802       include 'COMMON.CONTACTS'
7803       include 'COMMON.CONTMAT'
7804       include 'COMMON.CORRMAT'
7805       include 'COMMON.TORSION'
7806       include 'COMMON.VAR'
7807       include 'COMMON.GEO'
7808       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7809       logical swap
7810       logical lprn
7811       common /kutas/ lprn
7812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7813 C                                                                              C
7814 C      Parallel       Antiparallel                                             C
7815 C                                                                              C
7816 C          o             o                                                     C
7817 C         /l\           /j\                                                    C
7818 C        /   \         /   \                                                   C
7819 C       /| o |         | o |\                                                  C
7820 C     \ j|/k\|  /   \  |/k\|l /                                                C
7821 C      \ /   \ /     \ /   \ /                                                 C
7822 C       o     o       o     o                                                  C
7823 C       i             i                                                        C
7824 C                                                                              C
7825 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7826       itk=itype2loc(itype(k))
7827       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7828       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7829       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7830       call transpose2(EUgC(1,1,k),auxmat(1,1))
7831       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7832       vv1(1)=pizda1(1,1)-pizda1(2,2)
7833       vv1(2)=pizda1(1,2)+pizda1(2,1)
7834       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7835       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7836       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7837       s5=scalar2(vv(1),Dtobr2(1,i))
7838 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7839       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7840       if (calc_grad) then
7841       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7842      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7843      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7844      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7845      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7846      & +scalar2(vv(1),Dtobr2der(1,i)))
7847       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7848       vv1(1)=pizda1(1,1)-pizda1(2,2)
7849       vv1(2)=pizda1(1,2)+pizda1(2,1)
7850       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7851       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7852       if (l.eq.j+1) then
7853         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7854      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7855      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7856      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7857      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7858       else
7859         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7860      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7861      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7862      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7863      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7864       endif
7865       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7866       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7867       vv1(1)=pizda1(1,1)-pizda1(2,2)
7868       vv1(2)=pizda1(1,2)+pizda1(2,1)
7869       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7870      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7871      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7872      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7873       do iii=1,2
7874         if (swap) then
7875           ind=3-iii
7876         else
7877           ind=iii
7878         endif
7879         do kkk=1,5
7880           do lll=1,3
7881             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7882             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7883             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7884             call transpose2(EUgC(1,1,k),auxmat(1,1))
7885             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7886      &        pizda1(1,1))
7887             vv1(1)=pizda1(1,1)-pizda1(2,2)
7888             vv1(2)=pizda1(1,2)+pizda1(2,1)
7889             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7890             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7891      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7892             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7893      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7894             s5=scalar2(vv(1),Dtobr2(1,i))
7895             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7896           enddo
7897         enddo
7898       enddo
7899       endif ! calc_grad
7900       return
7901       end
7902 c----------------------------------------------------------------------------
7903       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7904       implicit real*8 (a-h,o-z)
7905       include 'DIMENSIONS'
7906       include 'COMMON.IOUNITS'
7907       include 'COMMON.CHAIN'
7908       include 'COMMON.DERIV'
7909       include 'COMMON.INTERACT'
7910       include 'COMMON.CONTACTS'
7911       include 'COMMON.CONTMAT'
7912       include 'COMMON.CORRMAT'
7913       include 'COMMON.TORSION'
7914       include 'COMMON.VAR'
7915       include 'COMMON.GEO'
7916       logical swap
7917       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7918      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7919       logical lprn
7920       common /kutas/ lprn
7921 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7922 C                                                                              C
7923 C      Parallel       Antiparallel                                             C
7924 C                                                                              C
7925 C          o             o                                                     C
7926 C     \   /l\           /j\   /                                                C
7927 C      \ /   \         /   \ /                                                 C
7928 C       o| o |         | o |o                                                  C
7929 C     \ j|/k\|      \  |/k\|l                                                  C
7930 C      \ /   \       \ /   \                                                   C
7931 C       o             o                                                        C
7932 C       i             i                                                        C
7933 C                                                                              C
7934 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7935 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7936 C AL 7/4/01 s1 would occur in the sixth-order moment,
7937 C           but not in a cluster cumulant
7938 #ifdef MOMENT
7939       s1=dip(1,jj,i)*dip(1,kk,k)
7940 #endif
7941       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7942       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7943       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7944       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7945       call transpose2(EUg(1,1,k),auxmat(1,1))
7946       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7947       vv(1)=pizda(1,1)-pizda(2,2)
7948       vv(2)=pizda(1,2)+pizda(2,1)
7949       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7950 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7951 #ifdef MOMENT
7952       eello6_graph2=-(s1+s2+s3+s4)
7953 #else
7954       eello6_graph2=-(s2+s3+s4)
7955 #endif
7956 c      eello6_graph2=-s3
7957 C Derivatives in gamma(i-1)
7958       if (calc_grad) then
7959       if (i.gt.1) then
7960 #ifdef MOMENT
7961         s1=dipderg(1,jj,i)*dip(1,kk,k)
7962 #endif
7963         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7964         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7965         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7966         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7967 #ifdef MOMENT
7968         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7969 #else
7970         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7971 #endif
7972 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7973       endif
7974 C Derivatives in gamma(k-1)
7975 #ifdef MOMENT
7976       s1=dip(1,jj,i)*dipderg(1,kk,k)
7977 #endif
7978       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7979       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7980       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7981       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7982       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7983       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7984       vv(1)=pizda(1,1)-pizda(2,2)
7985       vv(2)=pizda(1,2)+pizda(2,1)
7986       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7987 #ifdef MOMENT
7988       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7989 #else
7990       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7991 #endif
7992 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7993 C Derivatives in gamma(j-1) or gamma(l-1)
7994       if (j.gt.1) then
7995 #ifdef MOMENT
7996         s1=dipderg(3,jj,i)*dip(1,kk,k)
7997 #endif
7998         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7999         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8000         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8001         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8002         vv(1)=pizda(1,1)-pizda(2,2)
8003         vv(2)=pizda(1,2)+pizda(2,1)
8004         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8005 #ifdef MOMENT
8006         if (swap) then
8007           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8008         else
8009           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8010         endif
8011 #endif
8012         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8013 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8014       endif
8015 C Derivatives in gamma(l-1) or gamma(j-1)
8016       if (l.gt.1) then
8017 #ifdef MOMENT
8018         s1=dip(1,jj,i)*dipderg(3,kk,k)
8019 #endif
8020         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8021         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8022         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8023         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8024         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8025         vv(1)=pizda(1,1)-pizda(2,2)
8026         vv(2)=pizda(1,2)+pizda(2,1)
8027         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8028 #ifdef MOMENT
8029         if (swap) then
8030           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8031         else
8032           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8033         endif
8034 #endif
8035         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8036 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8037       endif
8038 C Cartesian derivatives.
8039       if (lprn) then
8040         write (2,*) 'In eello6_graph2'
8041         do iii=1,2
8042           write (2,*) 'iii=',iii
8043           do kkk=1,5
8044             write (2,*) 'kkk=',kkk
8045             do jjj=1,2
8046               write (2,'(3(2f10.5),5x)')
8047      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8048             enddo
8049           enddo
8050         enddo
8051       endif
8052       do iii=1,2
8053         do kkk=1,5
8054           do lll=1,3
8055 #ifdef MOMENT
8056             if (iii.eq.1) then
8057               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8058             else
8059               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8060             endif
8061 #endif
8062             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8063      &        auxvec(1))
8064             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8065             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8066      &        auxvec(1))
8067             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8068             call transpose2(EUg(1,1,k),auxmat(1,1))
8069             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8070      &        pizda(1,1))
8071             vv(1)=pizda(1,1)-pizda(2,2)
8072             vv(2)=pizda(1,2)+pizda(2,1)
8073             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8074 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8075 #ifdef MOMENT
8076             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8077 #else
8078             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8079 #endif
8080             if (swap) then
8081               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8082             else
8083               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8084             endif
8085           enddo
8086         enddo
8087       enddo
8088       endif ! calc_grad
8089       return
8090       end
8091 c----------------------------------------------------------------------------
8092       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8093       implicit real*8 (a-h,o-z)
8094       include 'DIMENSIONS'
8095       include 'COMMON.IOUNITS'
8096       include 'COMMON.CHAIN'
8097       include 'COMMON.DERIV'
8098       include 'COMMON.INTERACT'
8099       include 'COMMON.CONTACTS'
8100       include 'COMMON.CONTMAT'
8101       include 'COMMON.CORRMAT'
8102       include 'COMMON.TORSION'
8103       include 'COMMON.VAR'
8104       include 'COMMON.GEO'
8105       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8106       logical swap
8107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8108 C                                                                              C
8109 C      Parallel       Antiparallel                                             C
8110 C                                                                              C
8111 C          o             o                                                     C
8112 C         /l\   /   \   /j\                                                    C
8113 C        /   \ /     \ /   \                                                   C
8114 C       /| o |o       o| o |\                                                  C
8115 C       j|/k\|  /      |/k\|l /                                                C
8116 C        /   \ /       /   \ /                                                 C
8117 C       /     o       /     o                                                  C
8118 C       i             i                                                        C
8119 C                                                                              C
8120 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8121 C
8122 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8123 C           energy moment and not to the cluster cumulant.
8124       iti=itortyp(itype(i))
8125       if (j.lt.nres-1) then
8126         itj1=itype2loc(itype(j+1))
8127       else
8128         itj1=nloctyp
8129       endif
8130       itk=itype2loc(itype(k))
8131       itk1=itype2loc(itype(k+1))
8132       if (l.lt.nres-1) then
8133         itl1=itype2loc(itype(l+1))
8134       else
8135         itl1=nloctyp
8136       endif
8137 #ifdef MOMENT
8138       s1=dip(4,jj,i)*dip(4,kk,k)
8139 #endif
8140       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8141       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8142       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8143       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8144       call transpose2(EE(1,1,k),auxmat(1,1))
8145       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8146       vv(1)=pizda(1,1)+pizda(2,2)
8147       vv(2)=pizda(2,1)-pizda(1,2)
8148       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8149 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8150 cd     & "sum",-(s2+s3+s4)
8151 #ifdef MOMENT
8152       eello6_graph3=-(s1+s2+s3+s4)
8153 #else
8154       eello6_graph3=-(s2+s3+s4)
8155 #endif
8156 c      eello6_graph3=-s4
8157 C Derivatives in gamma(k-1)
8158       if (calc_grad) then
8159       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8160       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8161       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8162       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8163 C Derivatives in gamma(l-1)
8164       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8165       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8166       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8167       vv(1)=pizda(1,1)+pizda(2,2)
8168       vv(2)=pizda(2,1)-pizda(1,2)
8169       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8170       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8171 C Cartesian derivatives.
8172       do iii=1,2
8173         do kkk=1,5
8174           do lll=1,3
8175 #ifdef MOMENT
8176             if (iii.eq.1) then
8177               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8178             else
8179               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8180             endif
8181 #endif
8182             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8183      &        auxvec(1))
8184             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8185             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8186      &        auxvec(1))
8187             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8188             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8189      &        pizda(1,1))
8190             vv(1)=pizda(1,1)+pizda(2,2)
8191             vv(2)=pizda(2,1)-pizda(1,2)
8192             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8193 #ifdef MOMENT
8194             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8195 #else
8196             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8197 #endif
8198             if (swap) then
8199               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8200             else
8201               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8202             endif
8203 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8204           enddo
8205         enddo
8206       enddo
8207       endif ! calc_grad
8208       return
8209       end
8210 c----------------------------------------------------------------------------
8211       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8212       implicit real*8 (a-h,o-z)
8213       include 'DIMENSIONS'
8214       include 'COMMON.IOUNITS'
8215       include 'COMMON.CHAIN'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.CONTMAT'
8220       include 'COMMON.CORRMAT'
8221       include 'COMMON.TORSION'
8222       include 'COMMON.VAR'
8223       include 'COMMON.GEO'
8224       include 'COMMON.FFIELD'
8225       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8226      & auxvec1(2),auxmat1(2,2)
8227       logical swap
8228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8229 C                                                                              C
8230 C      Parallel       Antiparallel                                             C
8231 C                                                                              C
8232 C          o             o                                                     C
8233 C         /l\   /   \   /j\                                                    C
8234 C        /   \ /     \ /   \                                                   C
8235 C       /| o |o       o| o |\                                                  C
8236 C     \ j|/k\|      \  |/k\|l                                                  C
8237 C      \ /   \       \ /   \                                                   C
8238 C       o     \       o     \                                                  C
8239 C       i             i                                                        C
8240 C                                                                              C
8241 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8242 C
8243 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8244 C           energy moment and not to the cluster cumulant.
8245 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8246       iti=itype2loc(itype(i))
8247       itj=itype2loc(itype(j))
8248       if (j.lt.nres-1) then
8249         itj1=itype2loc(itype(j+1))
8250       else
8251         itj1=nloctyp
8252       endif
8253       itk=itype2loc(itype(k))
8254       if (k.lt.nres-1) then
8255         itk1=itype2loc(itype(k+1))
8256       else
8257         itk1=nloctyp
8258       endif
8259       itl=itype2loc(itype(l))
8260       if (l.lt.nres-1) then
8261         itl1=itype2loc(itype(l+1))
8262       else
8263         itl1=nloctyp
8264       endif
8265 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8266 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8267 cd     & ' itl',itl,' itl1',itl1
8268 #ifdef MOMENT
8269       if (imat.eq.1) then
8270         s1=dip(3,jj,i)*dip(3,kk,k)
8271       else
8272         s1=dip(2,jj,j)*dip(2,kk,l)
8273       endif
8274 #endif
8275       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8276       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8277       if (j.eq.l+1) then
8278         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8279         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8280       else
8281         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8282         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8283       endif
8284       call transpose2(EUg(1,1,k),auxmat(1,1))
8285       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8286       vv(1)=pizda(1,1)-pizda(2,2)
8287       vv(2)=pizda(2,1)+pizda(1,2)
8288       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8289 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8290 #ifdef MOMENT
8291       eello6_graph4=-(s1+s2+s3+s4)
8292 #else
8293       eello6_graph4=-(s2+s3+s4)
8294 #endif
8295 C Derivatives in gamma(i-1)
8296       if (calc_grad) then
8297       if (i.gt.1) then
8298 #ifdef MOMENT
8299         if (imat.eq.1) then
8300           s1=dipderg(2,jj,i)*dip(3,kk,k)
8301         else
8302           s1=dipderg(4,jj,j)*dip(2,kk,l)
8303         endif
8304 #endif
8305         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8306         if (j.eq.l+1) then
8307           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8308           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8309         else
8310           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8311           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8312         endif
8313         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8314         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8315 cd          write (2,*) 'turn6 derivatives'
8316 #ifdef MOMENT
8317           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8318 #else
8319           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8320 #endif
8321         else
8322 #ifdef MOMENT
8323           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8324 #else
8325           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8326 #endif
8327         endif
8328       endif
8329 C Derivatives in gamma(k-1)
8330 #ifdef MOMENT
8331       if (imat.eq.1) then
8332         s1=dip(3,jj,i)*dipderg(2,kk,k)
8333       else
8334         s1=dip(2,jj,j)*dipderg(4,kk,l)
8335       endif
8336 #endif
8337       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8338       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8339       if (j.eq.l+1) then
8340         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8341         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8342       else
8343         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8344         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8345       endif
8346       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8347       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8348       vv(1)=pizda(1,1)-pizda(2,2)
8349       vv(2)=pizda(2,1)+pizda(1,2)
8350       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8351       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8352 #ifdef MOMENT
8353         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8354 #else
8355         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8356 #endif
8357       else
8358 #ifdef MOMENT
8359         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8360 #else
8361         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8362 #endif
8363       endif
8364 C Derivatives in gamma(j-1) or gamma(l-1)
8365       if (l.eq.j+1 .and. l.gt.1) then
8366         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8367         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8368         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8369         vv(1)=pizda(1,1)-pizda(2,2)
8370         vv(2)=pizda(2,1)+pizda(1,2)
8371         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8372         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8373       else if (j.gt.1) then
8374         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8375         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8376         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8377         vv(1)=pizda(1,1)-pizda(2,2)
8378         vv(2)=pizda(2,1)+pizda(1,2)
8379         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8380         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8381           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8382         else
8383           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8384         endif
8385       endif
8386 C Cartesian derivatives.
8387       do iii=1,2
8388         do kkk=1,5
8389           do lll=1,3
8390 #ifdef MOMENT
8391             if (iii.eq.1) then
8392               if (imat.eq.1) then
8393                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8394               else
8395                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8396               endif
8397             else
8398               if (imat.eq.1) then
8399                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8400               else
8401                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8402               endif
8403             endif
8404 #endif
8405             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8406      &        auxvec(1))
8407             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8408             if (j.eq.l+1) then
8409               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8410      &          b1(1,j+1),auxvec(1))
8411               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8412             else
8413               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8414      &          b1(1,l+1),auxvec(1))
8415               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8416             endif
8417             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8418      &        pizda(1,1))
8419             vv(1)=pizda(1,1)-pizda(2,2)
8420             vv(2)=pizda(2,1)+pizda(1,2)
8421             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8422             if (swap) then
8423               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8424 #ifdef MOMENT
8425                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8426      &             -(s1+s2+s4)
8427 #else
8428                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8429      &             -(s2+s4)
8430 #endif
8431                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8432               else
8433 #ifdef MOMENT
8434                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8435 #else
8436                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8437 #endif
8438                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8439               endif
8440             else
8441 #ifdef MOMENT
8442               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8443 #else
8444               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8445 #endif
8446               if (l.eq.j+1) then
8447                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8448               else
8449                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8450               endif
8451             endif
8452           enddo
8453         enddo
8454       enddo
8455       endif ! calc_grad
8456       return
8457       end
8458 c----------------------------------------------------------------------------
8459       double precision function eello_turn6(i,jj,kk)
8460       implicit real*8 (a-h,o-z)
8461       include 'DIMENSIONS'
8462       include 'COMMON.IOUNITS'
8463       include 'COMMON.CHAIN'
8464       include 'COMMON.DERIV'
8465       include 'COMMON.INTERACT'
8466       include 'COMMON.CONTACTS'
8467       include 'COMMON.CONTMAT'
8468       include 'COMMON.CORRMAT'
8469       include 'COMMON.TORSION'
8470       include 'COMMON.VAR'
8471       include 'COMMON.GEO'
8472       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8473      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8474      &  ggg1(3),ggg2(3)
8475       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8476      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8477 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8478 C           the respective energy moment and not to the cluster cumulant.
8479       s1=0.0d0
8480       s8=0.0d0
8481       s13=0.0d0
8482 c
8483       eello_turn6=0.0d0
8484       j=i+4
8485       k=i+1
8486       l=i+3
8487       iti=itype2loc(itype(i))
8488       itk=itype2loc(itype(k))
8489       itk1=itype2loc(itype(k+1))
8490       itl=itype2loc(itype(l))
8491       itj=itype2loc(itype(j))
8492 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8493 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8494 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8495 cd        eello6=0.0d0
8496 cd        return
8497 cd      endif
8498 cd      write (iout,*)
8499 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8500 cd     &   ' and',k,l
8501 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8502       do iii=1,2
8503         do kkk=1,5
8504           do lll=1,3
8505             derx_turn(lll,kkk,iii)=0.0d0
8506           enddo
8507         enddo
8508       enddo
8509 cd      eij=1.0d0
8510 cd      ekl=1.0d0
8511 cd      ekont=1.0d0
8512       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8513 cd      eello6_5=0.0d0
8514 cd      write (2,*) 'eello6_5',eello6_5
8515 #ifdef MOMENT
8516       call transpose2(AEA(1,1,1),auxmat(1,1))
8517       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8518       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8519       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8520 #endif
8521       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8522       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8523       s2 = scalar2(b1(1,k),vtemp1(1))
8524 #ifdef MOMENT
8525       call transpose2(AEA(1,1,2),atemp(1,1))
8526       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8527       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8528       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8529 #endif
8530       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8531       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8532       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8533 #ifdef MOMENT
8534       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8535       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8536       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8537       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8538       ss13 = scalar2(b1(1,k),vtemp4(1))
8539       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8540 #endif
8541 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8542 c      s1=0.0d0
8543 c      s2=0.0d0
8544 c      s8=0.0d0
8545 c      s12=0.0d0
8546 c      s13=0.0d0
8547       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8548 C Derivatives in gamma(i+2)
8549       if (calc_grad) then
8550       s1d =0.0d0
8551       s8d =0.0d0
8552 #ifdef MOMENT
8553       call transpose2(AEA(1,1,1),auxmatd(1,1))
8554       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8555       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8556       call transpose2(AEAderg(1,1,2),atempd(1,1))
8557       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8558       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8559 #endif
8560       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8561       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8562       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8563 c      s1d=0.0d0
8564 c      s2d=0.0d0
8565 c      s8d=0.0d0
8566 c      s12d=0.0d0
8567 c      s13d=0.0d0
8568       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8569 C Derivatives in gamma(i+3)
8570 #ifdef MOMENT
8571       call transpose2(AEA(1,1,1),auxmatd(1,1))
8572       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8573       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8574       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8575 #endif
8576       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8577       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8578       s2d = scalar2(b1(1,k),vtemp1d(1))
8579 #ifdef MOMENT
8580       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8581       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8582 #endif
8583       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8584 #ifdef MOMENT
8585       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8586       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8587       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8588 #endif
8589 c      s1d=0.0d0
8590 c      s2d=0.0d0
8591 c      s8d=0.0d0
8592 c      s12d=0.0d0
8593 c      s13d=0.0d0
8594 #ifdef MOMENT
8595       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8596      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8597 #else
8598       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8599      &               -0.5d0*ekont*(s2d+s12d)
8600 #endif
8601 C Derivatives in gamma(i+4)
8602       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8603       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8604       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8605 #ifdef MOMENT
8606       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8607       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8608       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8609 #endif
8610 c      s1d=0.0d0
8611 c      s2d=0.0d0
8612 c      s8d=0.0d0
8613 C      s12d=0.0d0
8614 c      s13d=0.0d0
8615 #ifdef MOMENT
8616       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8617 #else
8618       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8619 #endif
8620 C Derivatives in gamma(i+5)
8621 #ifdef MOMENT
8622       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8623       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8624       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8625 #endif
8626       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8627       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8628       s2d = scalar2(b1(1,k),vtemp1d(1))
8629 #ifdef MOMENT
8630       call transpose2(AEA(1,1,2),atempd(1,1))
8631       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8632       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8633 #endif
8634       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8635       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8636 #ifdef MOMENT
8637       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8638       ss13d = scalar2(b1(1,k),vtemp4d(1))
8639       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8640 #endif
8641 c      s1d=0.0d0
8642 c      s2d=0.0d0
8643 c      s8d=0.0d0
8644 c      s12d=0.0d0
8645 c      s13d=0.0d0
8646 #ifdef MOMENT
8647       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8648      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8649 #else
8650       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8651      &               -0.5d0*ekont*(s2d+s12d)
8652 #endif
8653 C Cartesian derivatives
8654       do iii=1,2
8655         do kkk=1,5
8656           do lll=1,3
8657 #ifdef MOMENT
8658             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8659             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8660             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8661 #endif
8662             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8663             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8664      &          vtemp1d(1))
8665             s2d = scalar2(b1(1,k),vtemp1d(1))
8666 #ifdef MOMENT
8667             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8668             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8669             s8d = -(atempd(1,1)+atempd(2,2))*
8670      &           scalar2(cc(1,1,l),vtemp2(1))
8671 #endif
8672             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8673      &           auxmatd(1,1))
8674             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8675             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8676 c      s1d=0.0d0
8677 c      s2d=0.0d0
8678 c      s8d=0.0d0
8679 c      s12d=0.0d0
8680 c      s13d=0.0d0
8681 #ifdef MOMENT
8682             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8683      &        - 0.5d0*(s1d+s2d)
8684 #else
8685             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8686      &        - 0.5d0*s2d
8687 #endif
8688 #ifdef MOMENT
8689             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8690      &        - 0.5d0*(s8d+s12d)
8691 #else
8692             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8693      &        - 0.5d0*s12d
8694 #endif
8695           enddo
8696         enddo
8697       enddo
8698 #ifdef MOMENT
8699       do kkk=1,5
8700         do lll=1,3
8701           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8702      &      achuj_tempd(1,1))
8703           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8704           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8705           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8706           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8707           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8708      &      vtemp4d(1))
8709           ss13d = scalar2(b1(1,k),vtemp4d(1))
8710           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8711           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8712         enddo
8713       enddo
8714 #endif
8715 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8716 cd     &  16*eel_turn6_num
8717 cd      goto 1112
8718       if (j.lt.nres-1) then
8719         j1=j+1
8720         j2=j-1
8721       else
8722         j1=j-1
8723         j2=j-2
8724       endif
8725       if (l.lt.nres-1) then
8726         l1=l+1
8727         l2=l-1
8728       else
8729         l1=l-1
8730         l2=l-2
8731       endif
8732       do ll=1,3
8733 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8734 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8735 cgrad        ghalf=0.5d0*ggg1(ll)
8736 cd        ghalf=0.0d0
8737         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8738         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8739         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8740      &    +ekont*derx_turn(ll,2,1)
8741         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8742         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8743      &    +ekont*derx_turn(ll,4,1)
8744         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8745         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8746         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8747 cgrad        ghalf=0.5d0*ggg2(ll)
8748 cd        ghalf=0.0d0
8749         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8750      &    +ekont*derx_turn(ll,2,2)
8751         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8752         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8753      &    +ekont*derx_turn(ll,4,2)
8754         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8755         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8756         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8757       enddo
8758 cd      goto 1112
8759 cgrad      do m=i+1,j-1
8760 cgrad        do ll=1,3
8761 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8762 cgrad        enddo
8763 cgrad      enddo
8764 cgrad      do m=k+1,l-1
8765 cgrad        do ll=1,3
8766 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8767 cgrad        enddo
8768 cgrad      enddo
8769 cgrad1112  continue
8770 cgrad      do m=i+2,j2
8771 cgrad        do ll=1,3
8772 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8773 cgrad        enddo
8774 cgrad      enddo
8775 cgrad      do m=k+2,l2
8776 cgrad        do ll=1,3
8777 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8778 cgrad        enddo
8779 cgrad      enddo
8780 cd      do iii=1,nres-3
8781 cd        write (2,*) iii,g_corr6_loc(iii)
8782 cd      enddo
8783       endif ! calc_grad
8784       eello_turn6=ekont*eel_turn6
8785 cd      write (2,*) 'ekont',ekont
8786 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8787       return
8788       end
8789 #endif
8790 crc-------------------------------------------------
8791 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8792       subroutine Eliptransfer(eliptran)
8793       implicit real*8 (a-h,o-z)
8794       include 'DIMENSIONS'
8795       include 'COMMON.GEO'
8796       include 'COMMON.VAR'
8797       include 'COMMON.LOCAL'
8798       include 'COMMON.CHAIN'
8799       include 'COMMON.DERIV'
8800       include 'COMMON.INTERACT'
8801       include 'COMMON.IOUNITS'
8802       include 'COMMON.CALC'
8803       include 'COMMON.CONTROL'
8804       include 'COMMON.SPLITELE'
8805       include 'COMMON.SBRIDGE'
8806 C this is done by Adasko
8807 C      print *,"wchodze"
8808 C structure of box:
8809 C      water
8810 C--bordliptop-- buffore starts
8811 C--bufliptop--- here true lipid starts
8812 C      lipid
8813 C--buflipbot--- lipid ends buffore starts
8814 C--bordlipbot--buffore ends
8815       eliptran=0.0
8816       do i=1,nres
8817 C       do i=1,1
8818         if (itype(i).eq.ntyp1) cycle
8819
8820         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8821         if (positi.le.0) positi=positi+boxzsize
8822 C        print *,i
8823 C first for peptide groups
8824 c for each residue check if it is in lipid or lipid water border area
8825        if ((positi.gt.bordlipbot)
8826      &.and.(positi.lt.bordliptop)) then
8827 C the energy transfer exist
8828         if (positi.lt.buflipbot) then
8829 C what fraction I am in
8830          fracinbuf=1.0d0-
8831      &        ((positi-bordlipbot)/lipbufthick)
8832 C lipbufthick is thickenes of lipid buffore
8833          sslip=sscalelip(fracinbuf)
8834          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8835          eliptran=eliptran+sslip*pepliptran
8836          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8837          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8838 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8839         elseif (positi.gt.bufliptop) then
8840          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8841          sslip=sscalelip(fracinbuf)
8842          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8843          eliptran=eliptran+sslip*pepliptran
8844          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8845          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8846 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8847 C          print *, "doing sscalefor top part"
8848 C         print *,i,sslip,fracinbuf,ssgradlip
8849         else
8850          eliptran=eliptran+pepliptran
8851 C         print *,"I am in true lipid"
8852         endif
8853 C       else
8854 C       eliptran=elpitran+0.0 ! I am in water
8855        endif
8856        enddo
8857 C       print *, "nic nie bylo w lipidzie?"
8858 C now multiply all by the peptide group transfer factor
8859 C       eliptran=eliptran*pepliptran
8860 C now the same for side chains
8861 CV       do i=1,1
8862        do i=1,nres
8863         if (itype(i).eq.ntyp1) cycle
8864         positi=(mod(c(3,i+nres),boxzsize))
8865         if (positi.le.0) positi=positi+boxzsize
8866 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8867 c for each residue check if it is in lipid or lipid water border area
8868 C       respos=mod(c(3,i+nres),boxzsize)
8869 C       print *,positi,bordlipbot,buflipbot
8870        if ((positi.gt.bordlipbot)
8871      & .and.(positi.lt.bordliptop)) then
8872 C the energy transfer exist
8873         if (positi.lt.buflipbot) then
8874          fracinbuf=1.0d0-
8875      &     ((positi-bordlipbot)/lipbufthick)
8876 C lipbufthick is thickenes of lipid buffore
8877          sslip=sscalelip(fracinbuf)
8878          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8879          eliptran=eliptran+sslip*liptranene(itype(i))
8880          gliptranx(3,i)=gliptranx(3,i)
8881      &+ssgradlip*liptranene(itype(i))
8882          gliptranc(3,i-1)= gliptranc(3,i-1)
8883      &+ssgradlip*liptranene(itype(i))
8884 C         print *,"doing sccale for lower part"
8885         elseif (positi.gt.bufliptop) then
8886          fracinbuf=1.0d0-
8887      &((bordliptop-positi)/lipbufthick)
8888          sslip=sscalelip(fracinbuf)
8889          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8890          eliptran=eliptran+sslip*liptranene(itype(i))
8891          gliptranx(3,i)=gliptranx(3,i)
8892      &+ssgradlip*liptranene(itype(i))
8893          gliptranc(3,i-1)= gliptranc(3,i-1)
8894      &+ssgradlip*liptranene(itype(i))
8895 C          print *, "doing sscalefor top part",sslip,fracinbuf
8896         else
8897          eliptran=eliptran+liptranene(itype(i))
8898 C         print *,"I am in true lipid"
8899         endif
8900         endif ! if in lipid or buffor
8901 C       else
8902 C       eliptran=elpitran+0.0 ! I am in water
8903        enddo
8904        return
8905        end
8906
8907
8908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8909
8910       SUBROUTINE MATVEC2(A1,V1,V2)
8911       implicit real*8 (a-h,o-z)
8912       include 'DIMENSIONS'
8913       DIMENSION A1(2,2),V1(2),V2(2)
8914 c      DO 1 I=1,2
8915 c        VI=0.0
8916 c        DO 3 K=1,2
8917 c    3     VI=VI+A1(I,K)*V1(K)
8918 c        Vaux(I)=VI
8919 c    1 CONTINUE
8920
8921       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8922       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8923
8924       v2(1)=vaux1
8925       v2(2)=vaux2
8926       END
8927 C---------------------------------------
8928       SUBROUTINE MATMAT2(A1,A2,A3)
8929       implicit real*8 (a-h,o-z)
8930       include 'DIMENSIONS'
8931       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8932 c      DIMENSION AI3(2,2)
8933 c        DO  J=1,2
8934 c          A3IJ=0.0
8935 c          DO K=1,2
8936 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8937 c          enddo
8938 c          A3(I,J)=A3IJ
8939 c       enddo
8940 c      enddo
8941
8942       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8943       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8944       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8945       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8946
8947       A3(1,1)=AI3_11
8948       A3(2,1)=AI3_21
8949       A3(1,2)=AI3_12
8950       A3(2,2)=AI3_22
8951       END
8952
8953 c-------------------------------------------------------------------------
8954       double precision function scalar2(u,v)
8955       implicit none
8956       double precision u(2),v(2)
8957       double precision sc
8958       integer i
8959       scalar2=u(1)*v(1)+u(2)*v(2)
8960       return
8961       end
8962
8963 C-----------------------------------------------------------------------------
8964
8965       subroutine transpose2(a,at)
8966       implicit none
8967       double precision a(2,2),at(2,2)
8968       at(1,1)=a(1,1)
8969       at(1,2)=a(2,1)
8970       at(2,1)=a(1,2)
8971       at(2,2)=a(2,2)
8972       return
8973       end
8974 c--------------------------------------------------------------------------
8975       subroutine transpose(n,a,at)
8976       implicit none
8977       integer n,i,j
8978       double precision a(n,n),at(n,n)
8979       do i=1,n
8980         do j=1,n
8981           at(j,i)=a(i,j)
8982         enddo
8983       enddo
8984       return
8985       end
8986 C---------------------------------------------------------------------------
8987       subroutine prodmat3(a1,a2,kk,transp,prod)
8988       implicit none
8989       integer i,j
8990       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8991       logical transp
8992 crc      double precision auxmat(2,2),prod_(2,2)
8993
8994       if (transp) then
8995 crc        call transpose2(kk(1,1),auxmat(1,1))
8996 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8997 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8998
8999            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9000      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9001            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9002      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9003            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9004      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9005            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9006      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9007
9008       else
9009 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9010 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9011
9012            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9013      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9014            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9015      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9016            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9017      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9018            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9019      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9020
9021       endif
9022 c      call transpose2(a2(1,1),a2t(1,1))
9023
9024 crc      print *,transp
9025 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9026 crc      print *,((prod(i,j),i=1,2),j=1,2)
9027
9028       return
9029       end
9030 C-----------------------------------------------------------------------------
9031       double precision function scalar(u,v)
9032       implicit none
9033       double precision u(3),v(3)
9034       double precision sc
9035       integer i
9036       sc=0.0d0
9037       do i=1,3
9038         sc=sc+u(i)*v(i)
9039       enddo
9040       scalar=sc
9041       return
9042       end
9043 C-----------------------------------------------------------------------
9044       double precision function sscale(r)
9045       double precision r,gamm
9046       include "COMMON.SPLITELE"
9047       if(r.lt.r_cut-rlamb) then
9048         sscale=1.0d0
9049       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9050         gamm=(r-(r_cut-rlamb))/rlamb
9051         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9052       else
9053         sscale=0d0
9054       endif
9055       return
9056       end
9057 C-----------------------------------------------------------------------
9058 C-----------------------------------------------------------------------
9059       double precision function sscagrad(r)
9060       double precision r,gamm
9061       include "COMMON.SPLITELE"
9062       if(r.lt.r_cut-rlamb) then
9063         sscagrad=0.0d0
9064       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9065         gamm=(r-(r_cut-rlamb))/rlamb
9066         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9067       else
9068         sscagrad=0.0d0
9069       endif
9070       return
9071       end
9072 C-----------------------------------------------------------------------
9073 C-----------------------------------------------------------------------
9074       double precision function sscalelip(r)
9075       double precision r,gamm
9076       include "COMMON.SPLITELE"
9077 C      if(r.lt.r_cut-rlamb) then
9078 C        sscale=1.0d0
9079 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9080 C        gamm=(r-(r_cut-rlamb))/rlamb
9081         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9082 C      else
9083 C        sscale=0d0
9084 C      endif
9085       return
9086       end
9087 C-----------------------------------------------------------------------
9088       double precision function sscagradlip(r)
9089       double precision r,gamm
9090       include "COMMON.SPLITELE"
9091 C     if(r.lt.r_cut-rlamb) then
9092 C        sscagrad=0.0d0
9093 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9094 C        gamm=(r-(r_cut-rlamb))/rlamb
9095         sscagradlip=r*(6*r-6.0d0)
9096 C      else
9097 C        sscagrad=0.0d0
9098 C      endif
9099       return
9100       end
9101
9102 C-----------------------------------------------------------------------
9103        subroutine set_shield_fac
9104       implicit real*8 (a-h,o-z)
9105       include 'DIMENSIONS'
9106       include 'COMMON.CHAIN'
9107       include 'COMMON.DERIV'
9108       include 'COMMON.IOUNITS'
9109       include 'COMMON.SHIELD'
9110       include 'COMMON.INTERACT'
9111 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9112       double precision div77_81/0.974996043d0/,
9113      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9114
9115 C the vector between center of side_chain and peptide group
9116        double precision pep_side(3),long,side_calf(3),
9117      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9118      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9119 C the line belowe needs to be changed for FGPROC>1
9120       do i=1,nres-1
9121       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9122       ishield_list(i)=0
9123 Cif there two consequtive dummy atoms there is no peptide group between them
9124 C the line below has to be changed for FGPROC>1
9125       VolumeTotal=0.0
9126       do k=1,nres
9127        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9128        dist_pep_side=0.0
9129        dist_side_calf=0.0
9130        do j=1,3
9131 C first lets set vector conecting the ithe side-chain with kth side-chain
9132       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9133 C      pep_side(j)=2.0d0
9134 C and vector conecting the side-chain with its proper calfa
9135       side_calf(j)=c(j,k+nres)-c(j,k)
9136 C      side_calf(j)=2.0d0
9137       pept_group(j)=c(j,i)-c(j,i+1)
9138 C lets have their lenght
9139       dist_pep_side=pep_side(j)**2+dist_pep_side
9140       dist_side_calf=dist_side_calf+side_calf(j)**2
9141       dist_pept_group=dist_pept_group+pept_group(j)**2
9142       enddo
9143        dist_pep_side=dsqrt(dist_pep_side)
9144        dist_pept_group=dsqrt(dist_pept_group)
9145        dist_side_calf=dsqrt(dist_side_calf)
9146       do j=1,3
9147         pep_side_norm(j)=pep_side(j)/dist_pep_side
9148         side_calf_norm(j)=dist_side_calf
9149       enddo
9150 C now sscale fraction
9151        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9152 C       print *,buff_shield,"buff"
9153 C now sscale
9154         if (sh_frac_dist.le.0.0) cycle
9155 C If we reach here it means that this side chain reaches the shielding sphere
9156 C Lets add him to the list for gradient
9157         ishield_list(i)=ishield_list(i)+1
9158 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9159 C this list is essential otherwise problem would be O3
9160         shield_list(ishield_list(i),i)=k
9161 C Lets have the sscale value
9162         if (sh_frac_dist.gt.1.0) then
9163          scale_fac_dist=1.0d0
9164          do j=1,3
9165          sh_frac_dist_grad(j)=0.0d0
9166          enddo
9167         else
9168          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9169      &                   *(2.0*sh_frac_dist-3.0d0)
9170          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9171      &                  /dist_pep_side/buff_shield*0.5
9172 C remember for the final gradient multiply sh_frac_dist_grad(j)
9173 C for side_chain by factor -2 !
9174          do j=1,3
9175          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9176 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9177 C     &                    sh_frac_dist_grad(j)
9178          enddo
9179         endif
9180 C        if ((i.eq.3).and.(k.eq.2)) then
9181 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9182 C     & ,"TU"
9183 C        endif
9184
9185 C this is what is now we have the distance scaling now volume...
9186       short=short_r_sidechain(itype(k))
9187       long=long_r_sidechain(itype(k))
9188       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9189 C now costhet_grad
9190 C       costhet=0.0d0
9191        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9192 C       costhet_fac=0.0d0
9193        do j=1,3
9194          costhet_grad(j)=costhet_fac*pep_side(j)
9195        enddo
9196 C remember for the final gradient multiply costhet_grad(j)
9197 C for side_chain by factor -2 !
9198 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9199 C pep_side0pept_group is vector multiplication
9200       pep_side0pept_group=0.0
9201       do j=1,3
9202       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9203       enddo
9204       cosalfa=(pep_side0pept_group/
9205      & (dist_pep_side*dist_side_calf))
9206       fac_alfa_sin=1.0-cosalfa**2
9207       fac_alfa_sin=dsqrt(fac_alfa_sin)
9208       rkprim=fac_alfa_sin*(long-short)+short
9209 C now costhet_grad
9210        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9211        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9212
9213        do j=1,3
9214          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9215      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9216      &*(long-short)/fac_alfa_sin*cosalfa/
9217      &((dist_pep_side*dist_side_calf))*
9218      &((side_calf(j))-cosalfa*
9219      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9220
9221         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9222      &*(long-short)/fac_alfa_sin*cosalfa
9223      &/((dist_pep_side*dist_side_calf))*
9224      &(pep_side(j)-
9225      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9226        enddo
9227
9228       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9229      &                    /VSolvSphere_div
9230      &                    *wshield
9231 C now the gradient...
9232 C grad_shield is gradient of Calfa for peptide groups
9233 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9234 C     &               costhet,cosphi
9235 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9236 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9237       do j=1,3
9238       grad_shield(j,i)=grad_shield(j,i)
9239 C gradient po skalowaniu
9240      &                +(sh_frac_dist_grad(j)
9241 C  gradient po costhet
9242      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9243      &-scale_fac_dist*(cosphi_grad_long(j))
9244      &/(1.0-cosphi) )*div77_81
9245      &*VofOverlap
9246 C grad_shield_side is Cbeta sidechain gradient
9247       grad_shield_side(j,ishield_list(i),i)=
9248      &        (sh_frac_dist_grad(j)*(-2.0d0)
9249      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9250      &       +scale_fac_dist*(cosphi_grad_long(j))
9251      &        *2.0d0/(1.0-cosphi))
9252      &        *div77_81*VofOverlap
9253
9254        grad_shield_loc(j,ishield_list(i),i)=
9255      &   scale_fac_dist*cosphi_grad_loc(j)
9256      &        *2.0d0/(1.0-cosphi)
9257      &        *div77_81*VofOverlap
9258       enddo
9259       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9260       enddo
9261       fac_shield(i)=VolumeTotal*div77_81+div4_81
9262 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9263       enddo
9264       return
9265       end
9266 C--------------------------------------------------------------------------
9267 C first for shielding is setting of function of side-chains
9268        subroutine set_shield_fac2
9269       implicit real*8 (a-h,o-z)
9270       include 'DIMENSIONS'
9271       include 'COMMON.CHAIN'
9272       include 'COMMON.DERIV'
9273       include 'COMMON.IOUNITS'
9274       include 'COMMON.SHIELD'
9275       include 'COMMON.INTERACT'
9276 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9277       double precision div77_81/0.974996043d0/,
9278      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9279
9280 C the vector between center of side_chain and peptide group
9281        double precision pep_side(3),long,side_calf(3),
9282      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9283      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9284 C the line belowe needs to be changed for FGPROC>1
9285       do i=1,nres-1
9286       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9287       ishield_list(i)=0
9288 Cif there two consequtive dummy atoms there is no peptide group between them
9289 C the line below has to be changed for FGPROC>1
9290       VolumeTotal=0.0
9291       do k=1,nres
9292        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9293        dist_pep_side=0.0
9294        dist_side_calf=0.0
9295        do j=1,3
9296 C first lets set vector conecting the ithe side-chain with kth side-chain
9297       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9298 C      pep_side(j)=2.0d0
9299 C and vector conecting the side-chain with its proper calfa
9300       side_calf(j)=c(j,k+nres)-c(j,k)
9301 C      side_calf(j)=2.0d0
9302       pept_group(j)=c(j,i)-c(j,i+1)
9303 C lets have their lenght
9304       dist_pep_side=pep_side(j)**2+dist_pep_side
9305       dist_side_calf=dist_side_calf+side_calf(j)**2
9306       dist_pept_group=dist_pept_group+pept_group(j)**2
9307       enddo
9308        dist_pep_side=dsqrt(dist_pep_side)
9309        dist_pept_group=dsqrt(dist_pept_group)
9310        dist_side_calf=dsqrt(dist_side_calf)
9311       do j=1,3
9312         pep_side_norm(j)=pep_side(j)/dist_pep_side
9313         side_calf_norm(j)=dist_side_calf
9314       enddo
9315 C now sscale fraction
9316        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9317 C       print *,buff_shield,"buff"
9318 C now sscale
9319         if (sh_frac_dist.le.0.0) cycle
9320 C If we reach here it means that this side chain reaches the shielding sphere
9321 C Lets add him to the list for gradient
9322         ishield_list(i)=ishield_list(i)+1
9323 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9324 C this list is essential otherwise problem would be O3
9325         shield_list(ishield_list(i),i)=k
9326 C Lets have the sscale value
9327         if (sh_frac_dist.gt.1.0) then
9328          scale_fac_dist=1.0d0
9329          do j=1,3
9330          sh_frac_dist_grad(j)=0.0d0
9331          enddo
9332         else
9333          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9334      &                   *(2.0d0*sh_frac_dist-3.0d0)
9335          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9336      &                  /dist_pep_side/buff_shield*0.5d0
9337 C remember for the final gradient multiply sh_frac_dist_grad(j)
9338 C for side_chain by factor -2 !
9339          do j=1,3
9340          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9341 C         sh_frac_dist_grad(j)=0.0d0
9342 C         scale_fac_dist=1.0d0
9343 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9344 C     &                    sh_frac_dist_grad(j)
9345          enddo
9346         endif
9347 C this is what is now we have the distance scaling now volume...
9348       short=short_r_sidechain(itype(k))
9349       long=long_r_sidechain(itype(k))
9350       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9351       sinthet=short/dist_pep_side*costhet
9352 C now costhet_grad
9353 C       costhet=0.6d0
9354 C       sinthet=0.8
9355        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9356 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9357 C     &             -short/dist_pep_side**2/costhet)
9358 C       costhet_fac=0.0d0
9359        do j=1,3
9360          costhet_grad(j)=costhet_fac*pep_side(j)
9361        enddo
9362 C remember for the final gradient multiply costhet_grad(j)
9363 C for side_chain by factor -2 !
9364 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9365 C pep_side0pept_group is vector multiplication
9366       pep_side0pept_group=0.0d0
9367       do j=1,3
9368       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9369       enddo
9370       cosalfa=(pep_side0pept_group/
9371      & (dist_pep_side*dist_side_calf))
9372       fac_alfa_sin=1.0d0-cosalfa**2
9373       fac_alfa_sin=dsqrt(fac_alfa_sin)
9374       rkprim=fac_alfa_sin*(long-short)+short
9375 C      rkprim=short
9376
9377 C now costhet_grad
9378        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9379 C       cosphi=0.6
9380        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9381        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9382      &      dist_pep_side**2)
9383 C       sinphi=0.8
9384        do j=1,3
9385          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9386      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9387      &*(long-short)/fac_alfa_sin*cosalfa/
9388      &((dist_pep_side*dist_side_calf))*
9389      &((side_calf(j))-cosalfa*
9390      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9391 C       cosphi_grad_long(j)=0.0d0
9392         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9393      &*(long-short)/fac_alfa_sin*cosalfa
9394      &/((dist_pep_side*dist_side_calf))*
9395      &(pep_side(j)-
9396      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9397 C       cosphi_grad_loc(j)=0.0d0
9398        enddo
9399 C      print *,sinphi,sinthet
9400       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9401      &                    /VSolvSphere_div
9402 C     &                    *wshield
9403 C now the gradient...
9404       do j=1,3
9405       grad_shield(j,i)=grad_shield(j,i)
9406 C gradient po skalowaniu
9407      &                +(sh_frac_dist_grad(j)*VofOverlap
9408 C  gradient po costhet
9409      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9410      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9411      &       sinphi/sinthet*costhet*costhet_grad(j)
9412      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9413      & )*wshield
9414 C grad_shield_side is Cbeta sidechain gradient
9415       grad_shield_side(j,ishield_list(i),i)=
9416      &        (sh_frac_dist_grad(j)*(-2.0d0)
9417      &        *VofOverlap
9418      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9419      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9420      &       sinphi/sinthet*costhet*costhet_grad(j)
9421      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9422      &       )*wshield
9423
9424        grad_shield_loc(j,ishield_list(i),i)=
9425      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9426      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9427      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9428      &        ))
9429      &        *wshield
9430       enddo
9431       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9432       enddo
9433       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9434 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9435 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9436       enddo
9437       return
9438       end
9439 C--------------------------------------------------------------------------
9440       double precision function tschebyshev(m,n,x,y)
9441       implicit none
9442       include "DIMENSIONS"
9443       integer i,m,n
9444       double precision x(n),y,yy(0:maxvar),aux
9445 c Tschebyshev polynomial. Note that the first term is omitted
9446 c m=0: the constant term is included
9447 c m=1: the constant term is not included
9448       yy(0)=1.0d0
9449       yy(1)=y
9450       do i=2,n
9451         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9452       enddo
9453       aux=0.0d0
9454       do i=m,n
9455         aux=aux+x(i)*yy(i)
9456       enddo
9457       tschebyshev=aux
9458       return
9459       end
9460 C--------------------------------------------------------------------------
9461       double precision function gradtschebyshev(m,n,x,y)
9462       implicit none
9463       include "DIMENSIONS"
9464       integer i,m,n
9465       double precision x(n+1),y,yy(0:maxvar),aux
9466 c Tschebyshev polynomial. Note that the first term is omitted
9467 c m=0: the constant term is included
9468 c m=1: the constant term is not included
9469       yy(0)=1.0d0
9470       yy(1)=2.0d0*y
9471       do i=2,n
9472         yy(i)=2*y*yy(i-1)-yy(i-2)
9473       enddo
9474       aux=0.0d0
9475       do i=m,n
9476         aux=aux+x(i+1)*yy(i)*(i+1)
9477 C        print *, x(i+1),yy(i),i
9478       enddo
9479       gradtschebyshev=aux
9480       return
9481       end
9482 c----------------------------------------------------------------------------
9483       double precision function sscale2(r,r_cut,r0,rlamb)
9484       implicit none
9485       double precision r,gamm,r_cut,r0,rlamb,rr
9486       rr = dabs(r-r0)
9487 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9488 c      write (2,*) "rr",rr
9489       if(rr.lt.r_cut-rlamb) then
9490         sscale2=1.0d0
9491       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9492         gamm=(rr-(r_cut-rlamb))/rlamb
9493         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9494       else
9495         sscale2=0d0
9496       endif
9497       return
9498       end
9499 C-----------------------------------------------------------------------
9500       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9501       implicit none
9502       double precision r,gamm,r_cut,r0,rlamb,rr
9503       rr = dabs(r-r0)
9504       if(rr.lt.r_cut-rlamb) then
9505         sscalgrad2=0.0d0
9506       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9507         gamm=(rr-(r_cut-rlamb))/rlamb
9508         if (r.ge.r0) then
9509           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9510         else
9511           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9512         endif
9513       else
9514         sscalgrad2=0.0d0
9515       endif
9516       return
9517       end
9518 c----------------------------------------------------------------------------
9519       subroutine e_saxs(Esaxs_constr)
9520       implicit none
9521       include 'DIMENSIONS'
9522 #ifdef MPI
9523       include "mpif.h"
9524       include "COMMON.SETUP"
9525       integer IERR
9526 #endif
9527       include 'COMMON.SBRIDGE'
9528       include 'COMMON.CHAIN'
9529       include 'COMMON.GEO'
9530       include 'COMMON.LOCAL'
9531       include 'COMMON.INTERACT'
9532       include 'COMMON.VAR'
9533       include 'COMMON.IOUNITS'
9534       include 'COMMON.DERIV'
9535       include 'COMMON.CONTROL'
9536       include 'COMMON.NAMES'
9537       include 'COMMON.FFIELD'
9538       include 'COMMON.LANGEVIN'
9539       include 'COMMON.SAXS'
9540 c
9541       double precision Esaxs_constr
9542       integer i,iint,j,k,l
9543       double precision PgradC(maxSAXS,3,maxres),
9544      &  PgradX(maxSAXS,3,maxres)
9545 #ifdef MPI
9546       double precision PgradC_(maxSAXS,3,maxres),
9547      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9548 #endif
9549       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9550      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9551      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9552      & auxX,auxX1,CACAgrad,Cnorm
9553       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9554       double precision dist
9555       external dist
9556 c  SAXS restraint penalty function
9557 #ifdef DEBUG
9558       write(iout,*) "------- SAXS penalty function start -------"
9559       write (iout,*) "nsaxs",nsaxs
9560       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9561       write (iout,*) "Psaxs"
9562       do i=1,nsaxs
9563         write (iout,'(i5,e15.5)') i, Psaxs(i)
9564       enddo
9565 #endif
9566       Esaxs_constr = 0.0d0
9567       do k=1,nsaxs
9568         Pcalc(k)=0.0d0
9569         do j=1,nres
9570           do l=1,3
9571             PgradC(k,l,j)=0.0d0
9572             PgradX(k,l,j)=0.0d0
9573           enddo
9574         enddo
9575       enddo
9576       do i=iatsc_s,iatsc_e
9577        if (itype(i).eq.ntyp1) cycle
9578        do iint=1,nint_gr(i)
9579          do j=istart(i,iint),iend(i,iint)
9580            if (itype(j).eq.ntyp1) cycle
9581 #ifdef ALLSAXS
9582            dijCACA=dist(i,j)
9583            dijCASC=dist(i,j+nres)
9584            dijSCCA=dist(i+nres,j)
9585            dijSCSC=dist(i+nres,j+nres)
9586            sigma2CACA=2.0d0/(pstok**2)
9587            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9588            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9589            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9590            do k=1,nsaxs
9591              dk = distsaxs(k)
9592              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9593              if (itype(j).ne.10) then
9594              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9595              else
9596              endif
9597              expCASC = 0.0d0
9598              if (itype(i).ne.10) then
9599              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9600              else
9601              expSCCA = 0.0d0
9602              endif
9603              if (itype(i).ne.10 .and. itype(j).ne.10) then
9604              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9605              else
9606              expSCSC = 0.0d0
9607              endif
9608              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9609 #ifdef DEBUG
9610              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9611 #endif
9612              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9613              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9614              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9615              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9616              do l=1,3
9617 c CA CA
9618                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9619                PgradC(k,l,i) = PgradC(k,l,i)-aux
9620                PgradC(k,l,j) = PgradC(k,l,j)+aux
9621 c CA SC
9622                if (itype(j).ne.10) then
9623                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9624                PgradC(k,l,i) = PgradC(k,l,i)-aux
9625                PgradC(k,l,j) = PgradC(k,l,j)+aux
9626                PgradX(k,l,j) = PgradX(k,l,j)+aux
9627                endif
9628 c SC CA
9629                if (itype(i).ne.10) then
9630                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9631                PgradX(k,l,i) = PgradX(k,l,i)-aux
9632                PgradC(k,l,i) = PgradC(k,l,i)-aux
9633                PgradC(k,l,j) = PgradC(k,l,j)+aux
9634                endif
9635 c SC SC
9636                if (itype(i).ne.10 .and. itype(j).ne.10) then
9637                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9638                PgradC(k,l,i) = PgradC(k,l,i)-aux
9639                PgradC(k,l,j) = PgradC(k,l,j)+aux
9640                PgradX(k,l,i) = PgradX(k,l,i)-aux
9641                PgradX(k,l,j) = PgradX(k,l,j)+aux
9642                endif
9643              enddo ! l
9644            enddo ! k
9645 #else
9646            dijCACA=dist(i,j)
9647            sigma2CACA=scal_rad**2*0.25d0/
9648      &        (restok(itype(j))**2+restok(itype(i))**2)
9649
9650            IF (saxs_cutoff.eq.0) THEN
9651            do k=1,nsaxs
9652              dk = distsaxs(k)
9653              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9654              Pcalc(k) = Pcalc(k)+expCACA
9655              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9656              do l=1,3
9657                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9658                PgradC(k,l,i) = PgradC(k,l,i)-aux
9659                PgradC(k,l,j) = PgradC(k,l,j)+aux
9660              enddo ! l
9661            enddo ! k
9662            ELSE
9663            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9664            do k=1,nsaxs
9665              dk = distsaxs(k)
9666 c             write (2,*) "ijk",i,j,k
9667              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9668              if (sss2.eq.0.0d0) cycle
9669              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9670              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9671              Pcalc(k) = Pcalc(k)+expCACA
9672 #ifdef DEBUG
9673              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9674 #endif
9675              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9676      &             ssgrad2*expCACA/sss2
9677              do l=1,3
9678 c CA CA
9679                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9680                PgradC(k,l,i) = PgradC(k,l,i)+aux
9681                PgradC(k,l,j) = PgradC(k,l,j)-aux
9682              enddo ! l
9683            enddo ! k
9684            ENDIF
9685 #endif
9686          enddo ! j
9687        enddo ! iint
9688       enddo ! i
9689 #ifdef MPI
9690       if (nfgtasks.gt.1) then
9691         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9692      &    MPI_SUM,king,FG_COMM,IERR)
9693         if (fg_rank.eq.king) then
9694           do k=1,nsaxs
9695             Pcalc(k) = Pcalc_(k)
9696           enddo
9697         endif
9698         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9699      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9700         if (fg_rank.eq.king) then
9701           do i=1,nres
9702             do l=1,3
9703               do k=1,nsaxs
9704                 PgradC(k,l,i) = PgradC_(k,l,i)
9705               enddo
9706             enddo
9707           enddo
9708         endif
9709 #ifdef ALLSAXS
9710         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9711      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9712         if (fg_rank.eq.king) then
9713           do i=1,nres
9714             do l=1,3
9715               do k=1,nsaxs
9716                 PgradX(k,l,i) = PgradX_(k,l,i)
9717               enddo
9718             enddo
9719           enddo
9720         endif
9721 #endif
9722       endif
9723 #endif
9724 #ifdef MPI
9725       if (fg_rank.eq.king) then
9726 #endif
9727       Cnorm = 0.0d0
9728       do k=1,nsaxs
9729         Cnorm = Cnorm + Pcalc(k)
9730       enddo
9731       Esaxs_constr = dlog(Cnorm)-wsaxs0
9732       do k=1,nsaxs
9733         if (Pcalc(k).gt.0.0d0)
9734      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9735 #ifdef DEBUG
9736         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9737 #endif
9738       enddo
9739 #ifdef DEBUG
9740       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9741 #endif
9742       do i=nnt,nct
9743         do l=1,3
9744           auxC=0.0d0
9745           auxC1=0.0d0
9746           auxX=0.0d0
9747           auxX1=0.d0
9748           do k=1,nsaxs
9749             if (Pcalc(k).gt.0)
9750      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9751             auxC1 = auxC1+PgradC(k,l,i)
9752 #ifdef ALLSAXS
9753             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9754             auxX1 = auxX1+PgradX(k,l,i)
9755 #endif
9756           enddo
9757           gsaxsC(l,i) = auxC - auxC1/Cnorm
9758 #ifdef ALLSAXS
9759           gsaxsX(l,i) = auxX - auxX1/Cnorm
9760 #endif
9761 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9762 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9763         enddo
9764       enddo
9765 #ifdef MPI
9766       endif
9767 #endif
9768       return
9769       end
9770 c----------------------------------------------------------------------------
9771       subroutine e_saxsC(Esaxs_constr)
9772       implicit none
9773       include 'DIMENSIONS'
9774 #ifdef MPI
9775       include "mpif.h"
9776       include "COMMON.SETUP"
9777       integer IERR
9778 #endif
9779       include 'COMMON.SBRIDGE'
9780       include 'COMMON.CHAIN'
9781       include 'COMMON.GEO'
9782       include 'COMMON.LOCAL'
9783       include 'COMMON.INTERACT'
9784       include 'COMMON.VAR'
9785       include 'COMMON.IOUNITS'
9786       include 'COMMON.DERIV'
9787       include 'COMMON.CONTROL'
9788       include 'COMMON.NAMES'
9789       include 'COMMON.FFIELD'
9790       include 'COMMON.LANGEVIN'
9791       include 'COMMON.SAXS'
9792 c
9793       double precision Esaxs_constr
9794       integer i,iint,j,k,l
9795       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9796 #ifdef MPI
9797       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9798 #endif
9799       double precision dk,dijCASPH,dijSCSPH,
9800      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9801      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9802      & auxX,auxX1,Cnorm
9803 c  SAXS restraint penalty function
9804 #ifdef DEBUG
9805       write(iout,*) "------- SAXS penalty function start -------"
9806       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9807      & " isaxs_end",isaxs_end
9808       write (iout,*) "nnt",nnt," ntc",nct
9809       do i=nnt,nct
9810         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9811      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9812       enddo
9813       do i=nnt,nct
9814         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9815       enddo
9816 #endif
9817       Esaxs_constr = 0.0d0
9818       logPtot=0.0d0
9819       do j=isaxs_start,isaxs_end
9820         Pcalc_=0.0d0
9821         do i=1,nres
9822           do l=1,3
9823             PgradC(l,i)=0.0d0
9824             PgradX(l,i)=0.0d0
9825           enddo
9826         enddo
9827         do i=nnt,nct
9828           dijCASPH=0.0d0
9829           dijSCSPH=0.0d0
9830           do l=1,3
9831             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9832           enddo
9833           if (itype(i).ne.10) then
9834           do l=1,3
9835             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9836           enddo
9837           endif
9838           sigma2CA=2.0d0/pstok**2
9839           sigma2SC=4.0d0/restok(itype(i))**2
9840           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9841           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9842           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9843 #ifdef DEBUG
9844           write(*,*) "processor i j Pcalc",
9845      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9846 #endif
9847           CASPHgrad = sigma2CA*expCASPH
9848           SCSPHgrad = sigma2SC*expSCSPH
9849           do l=1,3
9850             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9851             PgradX(l,i) = PgradX(l,i) + aux
9852             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9853           enddo ! l
9854         enddo ! i
9855         do i=nnt,nct
9856           do l=1,3
9857             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9858             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9859           enddo
9860         enddo
9861         logPtot = logPtot - dlog(Pcalc_)
9862 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9863 c     &    " logPtot",logPtot
9864       enddo ! j
9865 #ifdef MPI
9866       if (nfgtasks.gt.1) then
9867 c        write (iout,*) "logPtot before reduction",logPtot
9868         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9869      &    MPI_SUM,king,FG_COMM,IERR)
9870         logPtot = logPtot_
9871 c        write (iout,*) "logPtot after reduction",logPtot
9872         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9873      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9874         if (fg_rank.eq.king) then
9875           do i=1,nres
9876             do l=1,3
9877               gsaxsC(l,i) = gsaxsC_(l,i)
9878             enddo
9879           enddo
9880         endif
9881         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9882      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9883         if (fg_rank.eq.king) then
9884           do i=1,nres
9885             do l=1,3
9886               gsaxsX(l,i) = gsaxsX_(l,i)
9887             enddo
9888           enddo
9889         endif
9890       endif
9891 #endif
9892       Esaxs_constr = logPtot
9893       return
9894       end
9895 C--------------------------------------------------------------------------
9896 c MODELLER restraint function
9897       subroutine e_modeller(ehomology_constr)
9898       implicit real*8 (a-h,o-z)
9899       include 'DIMENSIONS'
9900       integer nnn, i, j, k, ki, irec, l
9901       integer katy, odleglosci, test7
9902       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
9903       real*8 distance(max_template),distancek(max_template),
9904      &    min_odl,godl(max_template),dih_diff(max_template)
9905
9906 c
9907 c     FP - 30/10/2014 Temporary specifications for homology restraints
9908 c
9909       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
9910      &                 sgtheta
9911       double precision, dimension (maxres) :: guscdiff,usc_diff
9912       double precision, dimension (max_template) ::
9913      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
9914      &           theta_diff
9915
9916       include 'COMMON.SBRIDGE'
9917       include 'COMMON.CHAIN'
9918       include 'COMMON.GEO'
9919       include 'COMMON.DERIV'
9920       include 'COMMON.LOCAL'
9921       include 'COMMON.INTERACT'
9922       include 'COMMON.VAR'
9923       include 'COMMON.IOUNITS'
9924       include 'COMMON.CONTROL'
9925       include 'COMMON.HOMRESTR'
9926       include 'COMMON.HOMOLOGY'
9927       include 'COMMON.SETUP'
9928       include 'COMMON.NAMES'
9929
9930       do i=1,max_template
9931         distancek(i)=9999999.9
9932       enddo
9933
9934       odleg=0.0d0
9935
9936 c Pseudo-energy and gradient from homology restraints (MODELLER-like
9937 c function)
9938 C AL 5/2/14 - Introduce list of restraints
9939 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
9940 #ifdef DEBUG
9941       write(iout,*) "------- dist restrs start -------"
9942 #endif
9943       do ii = link_start_homo,link_end_homo
9944          i = ires_homo(ii)
9945          j = jres_homo(ii)
9946          dij=dist(i,j)
9947 c        write (iout,*) "dij(",i,j,") =",dij
9948          nexl=0
9949          do k=1,constr_homology
9950            if(.not.l_homo(k,ii)) then
9951               nexl=nexl+1
9952               cycle
9953            endif
9954            distance(k)=odl(k,ii)-dij
9955 c          write (iout,*) "distance(",k,") =",distance(k)
9956 c
9957 c          For Gaussian-type Urestr
9958 c
9959            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
9960 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
9961 c          write (iout,*) "distancek(",k,") =",distancek(k)
9962 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
9963 c
9964 c          For Lorentzian-type Urestr
9965 c
9966            if (waga_dist.lt.0.0d0) then
9967               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
9968               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
9969      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
9970            endif
9971          enddo
9972
9973 c         min_odl=minval(distancek)
9974          if (nexl.gt.0) then
9975            min_odl=0.0d0
9976          else
9977            do kk=1,constr_homology
9978             if(l_homo(kk,ii)) then
9979               min_odl=distancek(kk)
9980               exit
9981             endif
9982            enddo
9983            do kk=1,constr_homology
9984             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
9985      &              min_odl=distancek(kk)
9986            enddo
9987          endif
9988 c        write (iout,* )"min_odl",min_odl
9989 #ifdef DEBUG
9990          write (iout,*) "ij dij",i,j,dij
9991          write (iout,*) "distance",(distance(k),k=1,constr_homology)
9992          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
9993          write (iout,* )"min_odl",min_odl
9994 #endif
9995 #ifdef OLDRESTR
9996          odleg2=0.0d0
9997 #else
9998          if (waga_dist.ge.0.0d0) then
9999            odleg2=nexl
10000          else
10001            odleg2=0.0d0
10002          endif
10003 #endif
10004          do k=1,constr_homology
10005 c Nie wiem po co to liczycie jeszcze raz!
10006 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10007 c     &              (2*(sigma_odl(i,j,k))**2))
10008            if(.not.l_homo(k,ii)) cycle
10009            if (waga_dist.ge.0.0d0) then
10010 c
10011 c          For Gaussian-type Urestr
10012 c
10013             godl(k)=dexp(-distancek(k)+min_odl)
10014             odleg2=odleg2+godl(k)
10015 c
10016 c          For Lorentzian-type Urestr
10017 c
10018            else
10019             odleg2=odleg2+distancek(k)
10020            endif
10021
10022 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10023 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10024 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10025 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10026
10027          enddo
10028 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10029 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10030 #ifdef DEBUG
10031          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10032          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10033 #endif
10034            if (waga_dist.ge.0.0d0) then
10035 c
10036 c          For Gaussian-type Urestr
10037 c
10038               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10039 c
10040 c          For Lorentzian-type Urestr
10041 c
10042            else
10043               odleg=odleg+odleg2/constr_homology
10044            endif
10045 c
10046 #ifdef GRAD
10047 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10048 c Gradient
10049 c
10050 c          For Gaussian-type Urestr
10051 c
10052          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10053          sum_sgodl=0.0d0
10054          do k=1,constr_homology
10055 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10056 c     &           *waga_dist)+min_odl
10057 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10058 c
10059          if(.not.l_homo(k,ii)) cycle
10060          if (waga_dist.ge.0.0d0) then
10061 c          For Gaussian-type Urestr
10062 c
10063            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10064 c
10065 c          For Lorentzian-type Urestr
10066 c
10067          else
10068            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10069      &           sigma_odlir(k,ii)**2)**2)
10070          endif
10071            sum_sgodl=sum_sgodl+sgodl
10072
10073 c            sgodl2=sgodl2+sgodl
10074 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10075 c      write(iout,*) "constr_homology=",constr_homology
10076 c      write(iout,*) i, j, k, "TEST K"
10077          enddo
10078          if (waga_dist.ge.0.0d0) then
10079 c
10080 c          For Gaussian-type Urestr
10081 c
10082             grad_odl3=waga_homology(iset)*waga_dist
10083      &                *sum_sgodl/(sum_godl*dij)
10084 c
10085 c          For Lorentzian-type Urestr
10086 c
10087          else
10088 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10089 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10090             grad_odl3=-waga_homology(iset)*waga_dist*
10091      &                sum_sgodl/(constr_homology*dij)
10092          endif
10093 c
10094 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10095
10096
10097 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10098 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10099 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10100
10101 ccc      write(iout,*) godl, sgodl, grad_odl3
10102
10103 c          grad_odl=grad_odl+grad_odl3
10104
10105          do jik=1,3
10106             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10107 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10108 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10109 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10110             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10111             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10112 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10113 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10114 c         if (i.eq.25.and.j.eq.27) then
10115 c         write(iout,*) "jik",jik,"i",i,"j",j
10116 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10117 c         write(iout,*) "grad_odl3",grad_odl3
10118 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10119 c         write(iout,*) "ggodl",ggodl
10120 c         write(iout,*) "ghpbc(",jik,i,")",
10121 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10122 c     &                 ghpbc(jik,j)
10123 c         endif
10124          enddo
10125 #endif
10126 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10127 ccc     & dLOG(odleg2),"-odleg=", -odleg
10128
10129       enddo ! ii-loop for dist
10130 #ifdef DEBUG
10131       write(iout,*) "------- dist restrs end -------"
10132 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10133 c    &     waga_d.eq.1.0d0) call sum_gradient
10134 #endif
10135 c Pseudo-energy and gradient from dihedral-angle restraints from
10136 c homology templates
10137 c      write (iout,*) "End of distance loop"
10138 c      call flush(iout)
10139       kat=0.0d0
10140 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10141 #ifdef DEBUG
10142       write(iout,*) "------- dih restrs start -------"
10143       do i=idihconstr_start_homo,idihconstr_end_homo
10144         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10145       enddo
10146 #endif
10147       do i=idihconstr_start_homo,idihconstr_end_homo
10148         kat2=0.0d0
10149 c        betai=beta(i,i+1,i+2,i+3)
10150         betai = phi(i)
10151 c       write (iout,*) "betai =",betai
10152         do k=1,constr_homology
10153           dih_diff(k)=pinorm(dih(k,i)-betai)
10154 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10155 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10156 c     &                                   -(6.28318-dih_diff(i,k))
10157 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10158 c     &                                   6.28318+dih_diff(i,k)
10159 #ifdef OLD_DIHED
10160           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10161 #else
10162           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10163 #endif
10164 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10165           gdih(k)=dexp(kat3)
10166           kat2=kat2+gdih(k)
10167 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10168 c          write(*,*)""
10169         enddo
10170 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10171 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10172 #ifdef DEBUG
10173         write (iout,*) "i",i," betai",betai," kat2",kat2
10174         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10175 #endif
10176         if (kat2.le.1.0d-14) cycle
10177         kat=kat-dLOG(kat2/constr_homology)
10178 c       write (iout,*) "kat",kat ! sum of -ln-s
10179
10180 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10181 ccc     & dLOG(kat2), "-kat=", -kat
10182
10183 #ifdef GRAD
10184 c ----------------------------------------------------------------------
10185 c Gradient
10186 c ----------------------------------------------------------------------
10187
10188         sum_gdih=kat2
10189         sum_sgdih=0.0d0
10190         do k=1,constr_homology
10191 #ifdef OLD_DIHED
10192           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10193 #else
10194           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10195 #endif
10196 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10197           sum_sgdih=sum_sgdih+sgdih
10198         enddo
10199 c       grad_dih3=sum_sgdih/sum_gdih
10200         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10201
10202 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10203 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10204 ccc     & gloc(nphi+i-3,icg)
10205         gloc(i,icg)=gloc(i,icg)+grad_dih3
10206 c        if (i.eq.25) then
10207 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10208 c        endif
10209 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10210 ccc     & gloc(nphi+i-3,icg)
10211 #endif
10212       enddo ! i-loop for dih
10213 #ifdef DEBUG
10214       write(iout,*) "------- dih restrs end -------"
10215 #endif
10216
10217 c Pseudo-energy and gradient for theta angle restraints from
10218 c homology templates
10219 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10220 c adapted
10221
10222 c
10223 c     For constr_homology reference structures (FP)
10224 c
10225 c     Uconst_back_tot=0.0d0
10226       Eval=0.0d0
10227       Erot=0.0d0
10228 c     Econstr_back legacy
10229 #ifdef GRAD
10230       do i=1,nres
10231 c     do i=ithet_start,ithet_end
10232        dutheta(i)=0.0d0
10233 c     enddo
10234 c     do i=loc_start,loc_end
10235         do j=1,3
10236           duscdiff(j,i)=0.0d0
10237           duscdiffx(j,i)=0.0d0
10238         enddo
10239       enddo
10240 #endif
10241 c
10242 c     do iref=1,nref
10243 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10244 c     write (iout,*) "waga_theta",waga_theta
10245       if (waga_theta.gt.0.0d0) then
10246 #ifdef DEBUG
10247       write (iout,*) "usampl",usampl
10248       write(iout,*) "------- theta restrs start -------"
10249 c     do i=ithet_start,ithet_end
10250 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10251 c     enddo
10252 #endif
10253 c     write (iout,*) "maxres",maxres,"nres",nres
10254
10255       do i=ithet_start,ithet_end
10256 c
10257 c     do i=1,nfrag_back
10258 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10259 c
10260 c Deviation of theta angles wrt constr_homology ref structures
10261 c
10262         utheta_i=0.0d0 ! argument of Gaussian for single k
10263         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10264 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10265 c       over residues in a fragment
10266 c       write (iout,*) "theta(",i,")=",theta(i)
10267         do k=1,constr_homology
10268 c
10269 c         dtheta_i=theta(j)-thetaref(j,iref)
10270 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10271           theta_diff(k)=thetatpl(k,i)-theta(i)
10272 c
10273           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10274 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10275           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10276           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10277 c         Gradient for single Gaussian restraint in subr Econstr_back
10278 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10279 c
10280         enddo
10281 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10282 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10283
10284 c
10285 #ifdef GRAD
10286 c         Gradient for multiple Gaussian restraint
10287         sum_gtheta=gutheta_i
10288         sum_sgtheta=0.0d0
10289         do k=1,constr_homology
10290 c        New generalized expr for multiple Gaussian from Econstr_back
10291          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10292 c
10293 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10294           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10295         enddo
10296 c
10297 c       Final value of gradient using same var as in Econstr_back
10298         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10299      &               *waga_homology(iset)
10300 c       dutheta(i)=sum_sgtheta/sum_gtheta
10301 c
10302 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10303 #endif
10304         Eval=Eval-dLOG(gutheta_i/constr_homology)
10305 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10306 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10307 c       Uconst_back=Uconst_back+utheta(i)
10308       enddo ! (i-loop for theta)
10309 #ifdef DEBUG
10310       write(iout,*) "------- theta restrs end -------"
10311 #endif
10312       endif
10313 c
10314 c Deviation of local SC geometry
10315 c
10316 c Separation of two i-loops (instructed by AL - 11/3/2014)
10317 c
10318 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10319 c     write (iout,*) "waga_d",waga_d
10320
10321 #ifdef DEBUG
10322       write(iout,*) "------- SC restrs start -------"
10323       write (iout,*) "Initial duscdiff,duscdiffx"
10324       do i=loc_start,loc_end
10325         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10326      &                 (duscdiffx(jik,i),jik=1,3)
10327       enddo
10328 #endif
10329       do i=loc_start,loc_end
10330         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10331         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10332 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10333 c       write(iout,*) "xxtab, yytab, zztab"
10334 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10335         do k=1,constr_homology
10336 c
10337           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10338 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10339           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10340           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10341 c         write(iout,*) "dxx, dyy, dzz"
10342 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10343 c
10344           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10345 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10346 c         uscdiffk(k)=usc_diff(i)
10347           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10348           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10349 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10350 c     &      xxref(j),yyref(j),zzref(j)
10351         enddo
10352 c
10353 c       Gradient
10354 c
10355 c       Generalized expression for multiple Gaussian acc to that for a single
10356 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10357 c
10358 c       Original implementation
10359 c       sum_guscdiff=guscdiff(i)
10360 c
10361 c       sum_sguscdiff=0.0d0
10362 c       do k=1,constr_homology
10363 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10364 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10365 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10366 c       enddo
10367 c
10368 c       Implementation of new expressions for gradient (Jan. 2015)
10369 c
10370 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10371 #ifdef GRAD
10372         do k=1,constr_homology
10373 c
10374 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10375 c       before. Now the drivatives should be correct
10376 c
10377           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10378 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10379           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10380           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10381 c
10382 c         New implementation
10383 c
10384           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10385      &                 sigma_d(k,i) ! for the grad wrt r'
10386 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10387 c
10388 c
10389 c        New implementation
10390          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10391          do jik=1,3
10392             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10393      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10394      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10395             duscdiff(jik,i)=duscdiff(jik,i)+
10396      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10397      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10398             duscdiffx(jik,i)=duscdiffx(jik,i)+
10399      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10400      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10401 c
10402 #ifdef DEBUG
10403              write(iout,*) "jik",jik,"i",i
10404              write(iout,*) "dxx, dyy, dzz"
10405              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10406              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10407 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10408 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10409 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10410 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10411 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10412 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10413 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10414 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10415 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10416 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10417 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10418 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10419 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10420 c            endif
10421 #endif
10422          enddo
10423         enddo
10424 #endif
10425 c
10426 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10427 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10428 c
10429 c        write (iout,*) i," uscdiff",uscdiff(i)
10430 c
10431 c Put together deviations from local geometry
10432
10433 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10434 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10435         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10436 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10437 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10438 c       Uconst_back=Uconst_back+usc_diff(i)
10439 c
10440 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10441 c
10442 c     New implment: multiplied by sum_sguscdiff
10443 c
10444
10445       enddo ! (i-loop for dscdiff)
10446
10447 c      endif
10448
10449 #ifdef DEBUG
10450       write(iout,*) "------- SC restrs end -------"
10451         write (iout,*) "------ After SC loop in e_modeller ------"
10452         do i=loc_start,loc_end
10453          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10454          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10455         enddo
10456       if (waga_theta.eq.1.0d0) then
10457       write (iout,*) "in e_modeller after SC restr end: dutheta"
10458       do i=ithet_start,ithet_end
10459         write (iout,*) i,dutheta(i)
10460       enddo
10461       endif
10462       if (waga_d.eq.1.0d0) then
10463       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10464       do i=1,nres
10465         write (iout,*) i,(duscdiff(j,i),j=1,3)
10466         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10467       enddo
10468       endif
10469 #endif
10470
10471 c Total energy from homology restraints
10472 #ifdef DEBUG
10473       write (iout,*) "odleg",odleg," kat",kat
10474       write (iout,*) "odleg",odleg," kat",kat
10475       write (iout,*) "Eval",Eval," Erot",Erot
10476       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10477       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10478       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10479 #endif
10480 c
10481 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10482 c
10483 c     ehomology_constr=odleg+kat
10484 c
10485 c     For Lorentzian-type Urestr
10486 c
10487
10488       if (waga_dist.ge.0.0d0) then
10489 c
10490 c          For Gaussian-type Urestr
10491 c
10492 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10493 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10494         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10495      &              waga_theta*Eval+waga_d*Erot
10496 c     write (iout,*) "ehomology_constr=",ehomology_constr
10497       else
10498 c
10499 c          For Lorentzian-type Urestr
10500 c
10501 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10502 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10503         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10504      &              waga_theta*Eval+waga_d*Erot
10505 c     write (iout,*) "ehomology_constr=",ehomology_constr
10506       endif
10507 #ifdef DEBUG
10508       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10509      & "Eval",waga_theta,eval,
10510      &   "Erot",waga_d,Erot
10511       write (iout,*) "ehomology_constr",ehomology_constr
10512 #endif
10513       return
10514
10515   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10516   747 format(a12,i4,i4,i4,f8.3,f8.3)
10517   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10518   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10519   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10520      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10521       end