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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11
  12       include 'COMMON.IOUNITS'
  13       double precision energia(0:max_ene),energia1(0:max_ene+1)
  14       include 'COMMON.FFIELD'
  15       include 'COMMON.DERIV'
  16       include 'COMMON.INTERACT'
  17       include 'COMMON.SBRIDGE'
  18       include 'COMMON.CHAIN'
  19       include 'COMMON.SHIELD'
  20       include 'COMMON.CONTROL'
  21       include 'COMMON.TORCNSTR'
  22       include 'COMMON.SAXS'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C
  47 C Calculate electrostatic (H-bonding) energy of the main chain.
  48 C
  49   106 continue
  50 c      write (iout,*) "Sidechain"
  51       call flush(iout)
  52       call vec_and_deriv
  53       if (shield_mode.eq.1) then
  54        call set_shield_fac
  55       else if  (shield_mode.eq.2) then
  56        call set_shield_fac2
  57       endif
  58       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  59 c            write(iout,*) 'po eelec'
  60 c      call flush(iout)
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       if (wang.gt.0d0) then
  83        if (tor_mode.eq.0) then
  84          call ebend(ebe)
  85        else
  86 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  87 C energy function
  88          call ebend_kcc(ebe)
  89        endif
  90       else
  91         ebe=0.0d0
  92       endif
  93       ethetacnstr=0.0d0
  94       if (with_theta_constr) call etheta_constr(ethetacnstr)
  95 c      call ebend(ebe,ethetacnstr)
  96 cd    print *,'Bend energy finished.'
  97 C
  98 C Calculate the SC local energy.
  99 C
 100       call esc(escloc)
 101 C       print *,'SCLOC energy finished.'
 102 C
 103 C Calculate the virtual-bond torsional energy.
 104 C
 105       if (wtor.gt.0.0d0) then
 106          if (tor_mode.eq.0) then
 107            call etor(etors,fact(1))
 108          else
 109 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 110 C energy function
 111            call etor_kcc(etors,fact(1))
 112          endif
 113       else
 114         etors=0.0d0
 115       endif
 116       edihcnstr=0.0d0
 117       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 118 c      print *,"Processor",myrank," computed Utor"
 119 C
 120 C 6/23/01 Calculate double-torsional energy
 121 C
 122       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 123         call etor_d(etors_d,fact(2))
 124       else
 125         etors_d=0
 126       endif
 127 c      print *,"Processor",myrank," computed Utord"
 128 C
 129       if (wsccor.gt.0.0d0) then
 130         call eback_sc_corr(esccor)
 131       else
 132         esccor=0.0d0
 133       endif
 134
 135       if (wliptran.gt.0) then
 136         call Eliptransfer(eliptran)
 137       else
 138         eliptran=0.0d0
 139       endif
 140 #ifdef FOURBODY
 141 C
 142 C 12/1/95 Multi-body terms
 143 C
 144       n_corr=0
 145       n_corr1=0
 146       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 147      &    .or. wturn6.gt.0.0d0) then
 148 c         write(iout,*)"calling multibody_eello"
 149          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 150 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 151 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 152       else
 153          ecorr=0.0d0
 154          ecorr5=0.0d0
 155          ecorr6=0.0d0
 156          eturn6=0.0d0
 157       endif
 158       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 159 c         write (iout,*) "Calling multibody_hbond"
 160          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 161       endif
 162 #endif
 163 c      write (iout,*) "NSAXS",nsaxs
 164       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 165         call e_saxs(Esaxs_constr)
 166 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 167       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 168         call e_saxsC(Esaxs_constr)
 169 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 170       else
 171         Esaxs_constr = 0.0d0
 172       endif
 173 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 174       if (constr_homology.ge.1) then
 175         call e_modeller(ehomology_constr)
 176       else
 177         ehomology_constr=0.0d0
 178       endif
 179
 180 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 181 #ifdef DFA
 182 C     BARTEK for dfa test!
 183       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.CONTROL'
1108       include 'COMMON.GEO'
1109       include 'COMMON.VAR'
1110       include 'COMMON.LOCAL'
1111       include 'COMMON.CHAIN'
1112       include 'COMMON.DERIV'
1113       include 'COMMON.NAMES'
1114       include 'COMMON.INTERACT'
1115       include 'COMMON.IOUNITS'
1116       include 'COMMON.CALC'
1117       include 'COMMON.SBRIDGE'
1118       logical lprn
1119       common /srutu/icall
1120       integer icant,xshift,yshift,zshift
1121       external icant
1122 c      do i=1,210
1123 c        do j=1,2
1124 c          eneps_temp(j,i)=0.0d0
1125 c        enddo
1126 c      enddo
1127 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1128       evdw=0.0D0
1129       evdw_t=0.0d0
1130       lprn=.false.
1131 c      if (icall.gt.0) lprn=.true.
1132       ind=0
1133       do i=iatsc_s,iatsc_e
1134         itypi=iabs(itype(i))
1135         if (itypi.eq.ntyp1) cycle
1136         itypi1=iabs(itype(i+1))
1137         xi=c(1,nres+i)
1138         yi=c(2,nres+i)
1139         zi=c(3,nres+i)
1140 C returning the ith atom to box
1141         call to_box(xi,yi,zi)
1142         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1143         dxi=dc_norm(1,nres+i)
1144         dyi=dc_norm(2,nres+i)
1145         dzi=dc_norm(3,nres+i)
1146         dsci_inv=vbld_inv(i+nres)
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151           do j=istart(i,iint),iend(i,iint)
1152             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1153               call dyn_ssbond_ene(i,j,evdwij)
1154               evdw=evdw+evdwij
1155 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1156 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1157 C triple bond artifac removal
1158              do k=j+1,iend(i,iint)
1159 C search over all next residues
1160               if (dyn_ss_mask(k)) then
1161 C check if they are cysteins
1162 C              write(iout,*) 'k=',k
1163               call triple_ssbond_ene(i,j,k,evdwij)
1164 C call the energy function that removes the artifical triple disulfide
1165 C bond the soubroutine is located in ssMD.F
1166               evdw=evdw+evdwij
1167 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1168 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1169               endif!dyn_ss_mask(k)
1170              enddo! k
1171             ELSE
1172             ind=ind+1
1173             itypj=iabs(itype(j))
1174             if (itypj.eq.ntyp1) cycle
1175             dscj_inv=vbld_inv(j+nres)
1176             sig0ij=sigma(itypi,itypj)
1177             chi1=chi(itypi,itypj)
1178             chi2=chi(itypj,itypi)
1179             chi12=chi1*chi2
1180             chip1=chip(itypi)
1181             chip2=chip(itypj)
1182             chip12=chip1*chip2
1183             alf1=alp(itypi)
1184             alf2=alp(itypj)
1185             alf12=0.5D0*(alf1+alf2)
1186 C For diagnostics only!!!
1187 c           chi1=0.0D0
1188 c           chi2=0.0D0
1189 c           chi12=0.0D0
1190 c           chip1=0.0D0
1191 c           chip2=0.0D0
1192 c           chip12=0.0D0
1193 c           alf1=0.0D0
1194 c           alf2=0.0D0
1195 c           alf12=0.0D0
1196             xj=c(1,nres+j)
1197             yj=c(2,nres+j)
1198             zj=c(3,nres+j)
1199 C returning jth atom to box
1200             call to_box(xj,yj,zj)
1201             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1202             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1203      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1204             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1205      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1206             xj=boxshift(xj-xi,boxxsize)
1207             yj=boxshift(yj-yi,boxysize)
1208             zj=boxshift(zj-zi,boxzsize)
1209             dxj=dc_norm(1,nres+j)
1210             dyj=dc_norm(2,nres+j)
1211             dzj=dc_norm(3,nres+j)
1212 c            write (iout,*) i,j,xj,yj,zj
1213             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1214             rij=dsqrt(rrij)
1215             sss=sscale(1.0d0/rij)
1216             sssgrad=sscagrad(1.0d0/rij)
1217             if (sss.le.0.0) cycle
1218 C Calculate angle-dependent terms of energy and contributions to their
1219 C derivatives.
1220
1221             call sc_angular
1222             sigsq=1.0D0/sigsq
1223             sig=sig0ij*dsqrt(sigsq)
1224             rij_shift=1.0D0/rij-sig+sig0ij
1225 C I hate to put IF's in the loops, but here don't have another choice!!!!
1226             if (rij_shift.le.0.0D0) then
1227               evdw=1.0D20
1228               return
1229             endif
1230             sigder=-sig*sigsq
1231 c---------------------------------------------------------------
1232             rij_shift=1.0D0/rij_shift
1233             fac=rij_shift**expon
1234             e1=fac*fac*aa
1235             e2=fac*bb
1236             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1237             eps2der=evdwij*eps3rt
1238             eps3der=evdwij*eps2rt
1239             evdwij=evdwij*eps2rt*eps3rt
1240             if (bb.gt.0) then
1241               evdw=evdw+evdwij*sss
1242             else
1243               evdw_t=evdw_t+evdwij*sss
1244             endif
1245             ij=icant(itypi,itypj)
1246             aux=eps1*eps2rt**2*eps3rt**2
1247 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1248 c     &        /dabs(eps(itypi,itypj))
1249 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1250 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1251 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1252 c     &         aux*e2/eps(itypi,itypj)
1253 c            if (lprn) then
1254             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1255             epsi=bb**2/aa
1256 C#define DEBUG
1257 #ifdef DEBUG
1258             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1259      &        restyp(itypi),i,restyp(itypj),j,
1260      &        epsi,sigm,chi1,chi2,chip1,chip2,
1261      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1262      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1263      &        evdwij
1264              write (iout,*) "partial sum", evdw, evdw_t
1265 #endif
1266 C#undef DEBUG
1267 c            endif
1268             if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
1269      &       'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
1270             if (calc_grad) then
1271 C Calculate gradient components.
1272             e1=e1*eps1*eps2rt**2*eps3rt**2
1273             fac=-expon*(e1+evdwij)*rij_shift
1274             sigder=fac*sigder
1275             fac=rij*fac
1276             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1277 C Calculate the radial part of the gradient
1278             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1279      &        *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1280      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1281      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1282             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1283             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1284             gg(1)=xj*fac
1285             gg(2)=yj*fac
1286             gg(3)=zj*fac
1287 C Calculate angular part of the gradient.
1288             call sc_grad
1289             endif
1290 C            write(iout,*)  "partial sum", evdw, evdw_t
1291             ENDIF    ! dyn_ss
1292           enddo      ! j
1293         enddo        ! iint
1294       enddo          ! i
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine egbv(evdw,evdw_t)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the Gay-Berne-Vorobjev potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include "DIMENSIONS.COMPAR"
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.NAMES'
1312       include 'COMMON.INTERACT'
1313       include 'COMMON.IOUNITS'
1314       include 'COMMON.CALC'
1315       common /srutu/ icall
1316       logical lprn
1317       integer icant
1318       external icant
1319 c      do i=1,210
1320 c        do j=1,2
1321 c          eneps_temp(j,i)=0.0d0
1322 c        enddo
1323 c      enddo
1324       evdw=0.0D0
1325       evdw_t=0.0d0
1326 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1327       evdw=0.0D0
1328       lprn=.false.
1329 c      if (icall.gt.0) lprn=.true.
1330       ind=0
1331       do i=iatsc_s,iatsc_e
1332         itypi=iabs(itype(i))
1333         if (itypi.eq.ntyp1) cycle
1334         itypi1=iabs(itype(i+1))
1335         xi=c(1,nres+i)
1336         yi=c(2,nres+i)
1337         zi=c(3,nres+i)
1338         call to_box(xi,yi,zi)
1339         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1340         dxi=dc_norm(1,nres+i)
1341         dyi=dc_norm(2,nres+i)
1342         dzi=dc_norm(3,nres+i)
1343         dsci_inv=vbld_inv(i+nres)
1344 C
1345 C Calculate SC interaction energy.
1346 C
1347         do iint=1,nint_gr(i)
1348           do j=istart(i,iint),iend(i,iint)
1349             ind=ind+1
1350             itypj=iabs(itype(j))
1351             if (itypj.eq.ntyp1) cycle
1352             dscj_inv=vbld_inv(j+nres)
1353             sig0ij=sigma(itypi,itypj)
1354             r0ij=r0(itypi,itypj)
1355             chi1=chi(itypi,itypj)
1356             chi2=chi(itypj,itypi)
1357             chi12=chi1*chi2
1358             chip1=chip(itypi)
1359             chip2=chip(itypj)
1360             chip12=chip1*chip2
1361             alf1=alp(itypi)
1362             alf2=alp(itypj)
1363             alf12=0.5D0*(alf1+alf2)
1364 C For diagnostics only!!!
1365 c           chi1=0.0D0
1366 c           chi2=0.0D0
1367 c           chi12=0.0D0
1368 c           chip1=0.0D0
1369 c           chip2=0.0D0
1370 c           chip12=0.0D0
1371 c           alf1=0.0D0
1372 c           alf2=0.0D0
1373 c           alf12=0.0D0
1374             xj=c(1,nres+j)
1375             yj=c(2,nres+j)
1376             zj=c(3,nres+j)
1377             call to_box(xj,yj,zj)
1378             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1379             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1380      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1381             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1382      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1383             dxj=dc_norm(1,nres+j)
1384             dyj=dc_norm(2,nres+j)
1385             dzj=dc_norm(3,nres+j)
1386             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1387             rij=dsqrt(rrij)
1388             sss=sscale(1.0d0/rij)
1389             if (sss.eq.0.0d0) cycle
1390             sssgrad=sscagrad(1.0d0/rij)
1391 C Calculate angle-dependent terms of energy and contributions to their
1392 C derivatives.
1393             call sc_angular
1394             sigsq=1.0D0/sigsq
1395             sig=sig0ij*dsqrt(sigsq)
1396             rij_shift=1.0D0/rij-sig+r0ij
1397 C I hate to put IF's in the loops, but here don't have another choice!!!!
1398             if (rij_shift.le.0.0D0) then
1399               evdw=1.0D20
1400               return
1401             endif
1402             sigder=-sig*sigsq
1403 c---------------------------------------------------------------
1404             rij_shift=1.0D0/rij_shift
1405             fac=rij_shift**expon
1406             e1=fac*fac*aa
1407             e2=fac*bb
1408             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1409             eps2der=evdwij*eps3rt
1410             eps3der=evdwij*eps2rt
1411             fac_augm=rrij**expon
1412             e_augm=augm(itypi,itypj)*fac_augm
1413             evdwij=evdwij*eps2rt*eps3rt
1414             if (bb.gt.0.0d0) then
1415               evdw=evdw+(evdwij+e_augm)*sss
1416             else
1417               evdw_t=evdw_t+(evdwij+e_augm)*sss
1418             endif
1419             ij=icant(itypi,itypj)
1420             aux=eps1*eps2rt**2*eps3rt**2
1421 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1422 c     &        /dabs(eps(itypi,itypj))
1423 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1424 c            eneps_temp(ij)=eneps_temp(ij)
1425 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1426 c            if (lprn) then
1427 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1428 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1429 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1430 c     &        restyp(itypi),i,restyp(itypj),j,
1431 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1432 c     &        chi1,chi2,chip1,chip2,
1433 c     &        eps1,eps2rt**2,eps3rt**2,
1434 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1435 c     &        evdwij+e_augm
1436 c            endif
1437             if (calc_grad) then
1438 C Calculate gradient components.
1439             e1=e1*eps1*eps2rt**2*eps3rt**2
1440             fac=-expon*(e1+evdwij)*rij_shift
1441             sigder=fac*sigder
1442             fac=rij*fac-2*expon*rrij*e_augm
1443             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1444 C Calculate the radial part of the gradient
1445             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1446      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1447      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1448      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1449             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1450             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1451             gg(1)=xj*fac
1452             gg(2)=yj*fac
1453             gg(3)=zj*fac
1454 C Calculate angular part of the gradient.
1455             call sc_grad
1456             endif
1457           enddo      ! j
1458         enddo        ! iint
1459       enddo          ! i
1460       return
1461       end
1462 C-----------------------------------------------------------------------------
1463       subroutine sc_angular
1464 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1465 C om12. Called by ebp, egb, and egbv.
1466       implicit none
1467       include 'COMMON.CALC'
1468       erij(1)=xj*rij
1469       erij(2)=yj*rij
1470       erij(3)=zj*rij
1471       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1472       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1473       om12=dxi*dxj+dyi*dyj+dzi*dzj
1474       chiom12=chi12*om12
1475 C Calculate eps1(om12) and its derivative in om12
1476       faceps1=1.0D0-om12*chiom12
1477       faceps1_inv=1.0D0/faceps1
1478       eps1=dsqrt(faceps1_inv)
1479 C Following variable is eps1*deps1/dom12
1480       eps1_om12=faceps1_inv*chiom12
1481 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1482 C and om12.
1483       om1om2=om1*om2
1484       chiom1=chi1*om1
1485       chiom2=chi2*om2
1486       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1487       sigsq=1.0D0-facsig*faceps1_inv
1488       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1489       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1490       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1491 C Calculate eps2 and its derivatives in om1, om2, and om12.
1492       chipom1=chip1*om1
1493       chipom2=chip2*om2
1494       chipom12=chip12*om12
1495       facp=1.0D0-om12*chipom12
1496       facp_inv=1.0D0/facp
1497       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1498 C Following variable is the square root of eps2
1499       eps2rt=1.0D0-facp1*facp_inv
1500 C Following three variables are the derivatives of the square root of eps
1501 C in om1, om2, and om12.
1502       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1503       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1504       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1505 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1506       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1507 C Calculate whole angle-dependent part of epsilon and contributions
1508 C to its derivatives
1509       return
1510       end
1511 C----------------------------------------------------------------------------
1512       subroutine sc_grad
1513       implicit real*8 (a-h,o-z)
1514       include 'DIMENSIONS'
1515       include 'COMMON.CHAIN'
1516       include 'COMMON.DERIV'
1517       include 'COMMON.CALC'
1518       double precision dcosom1(3),dcosom2(3)
1519       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1520       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1521       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1522      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1523       do k=1,3
1524         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1525         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1526       enddo
1527       do k=1,3
1528         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1529       enddo
1530       do k=1,3
1531         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1532      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1533      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1534         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1535      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1536      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1537       enddo
1538 C
1539 C Calculate the components of the gradient in DC and X
1540 C
1541       do k=i,j-1
1542         do l=1,3
1543           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1544         enddo
1545       enddo
1546       return
1547       end
1548 c------------------------------------------------------------------------------
1549       subroutine vec_and_deriv
1550       implicit real*8 (a-h,o-z)
1551       include 'DIMENSIONS'
1552       include 'COMMON.IOUNITS'
1553       include 'COMMON.GEO'
1554       include 'COMMON.VAR'
1555       include 'COMMON.LOCAL'
1556       include 'COMMON.CHAIN'
1557       include 'COMMON.VECTORS'
1558       include 'COMMON.DERIV'
1559       include 'COMMON.INTERACT'
1560       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1561 C Compute the local reference systems. For reference system (i), the
1562 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1563 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1564       do i=1,nres-1
1565 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1566           if (i.eq.nres-1) then
1567 C Case of the last full residue
1568 C Compute the Z-axis
1569             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1570             costh=dcos(pi-theta(nres))
1571             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1572 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1573 c     &         " uz",uz(:,i)
1574             do k=1,3
1575               uz(k,i)=fac*uz(k,i)
1576             enddo
1577             if (calc_grad) then
1578 C Compute the derivatives of uz
1579             uzder(1,1,1)= 0.0d0
1580             uzder(2,1,1)=-dc_norm(3,i-1)
1581             uzder(3,1,1)= dc_norm(2,i-1)
1582             uzder(1,2,1)= dc_norm(3,i-1)
1583             uzder(2,2,1)= 0.0d0
1584             uzder(3,2,1)=-dc_norm(1,i-1)
1585             uzder(1,3,1)=-dc_norm(2,i-1)
1586             uzder(2,3,1)= dc_norm(1,i-1)
1587             uzder(3,3,1)= 0.0d0
1588             uzder(1,1,2)= 0.0d0
1589             uzder(2,1,2)= dc_norm(3,i)
1590             uzder(3,1,2)=-dc_norm(2,i)
1591             uzder(1,2,2)=-dc_norm(3,i)
1592             uzder(2,2,2)= 0.0d0
1593             uzder(3,2,2)= dc_norm(1,i)
1594             uzder(1,3,2)= dc_norm(2,i)
1595             uzder(2,3,2)=-dc_norm(1,i)
1596             uzder(3,3,2)= 0.0d0
1597             endif ! calc_grad
1598 C Compute the Y-axis
1599             facy=fac
1600             do k=1,3
1601               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1602             enddo
1603             if (calc_grad) then
1604 C Compute the derivatives of uy
1605             do j=1,3
1606               do k=1,3
1607                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1608      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1609                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1610               enddo
1611               uyder(j,j,1)=uyder(j,j,1)-costh
1612               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1613             enddo
1614             do j=1,2
1615               do k=1,3
1616                 do l=1,3
1617                   uygrad(l,k,j,i)=uyder(l,k,j)
1618                   uzgrad(l,k,j,i)=uzder(l,k,j)
1619                 enddo
1620               enddo
1621             enddo
1622             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1623             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1624             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1625             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1626             endif
1627           else
1628 C Other residues
1629 C Compute the Z-axis
1630             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1631             costh=dcos(pi-theta(i+2))
1632             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1633             do k=1,3
1634               uz(k,i)=fac*uz(k,i)
1635             enddo
1636             if (calc_grad) then
1637 C Compute the derivatives of uz
1638             uzder(1,1,1)= 0.0d0
1639             uzder(2,1,1)=-dc_norm(3,i+1)
1640             uzder(3,1,1)= dc_norm(2,i+1)
1641             uzder(1,2,1)= dc_norm(3,i+1)
1642             uzder(2,2,1)= 0.0d0
1643             uzder(3,2,1)=-dc_norm(1,i+1)
1644             uzder(1,3,1)=-dc_norm(2,i+1)
1645             uzder(2,3,1)= dc_norm(1,i+1)
1646             uzder(3,3,1)= 0.0d0
1647             uzder(1,1,2)= 0.0d0
1648             uzder(2,1,2)= dc_norm(3,i)
1649             uzder(3,1,2)=-dc_norm(2,i)
1650             uzder(1,2,2)=-dc_norm(3,i)
1651             uzder(2,2,2)= 0.0d0
1652             uzder(3,2,2)= dc_norm(1,i)
1653             uzder(1,3,2)= dc_norm(2,i)
1654             uzder(2,3,2)=-dc_norm(1,i)
1655             uzder(3,3,2)= 0.0d0
1656             endif
1657 C Compute the Y-axis
1658             facy=fac
1659             do k=1,3
1660               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1661             enddo
1662             if (calc_grad) then
1663 C Compute the derivatives of uy
1664             do j=1,3
1665               do k=1,3
1666                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1667      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1668                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1669               enddo
1670               uyder(j,j,1)=uyder(j,j,1)-costh
1671               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1672             enddo
1673             do j=1,2
1674               do k=1,3
1675                 do l=1,3
1676                   uygrad(l,k,j,i)=uyder(l,k,j)
1677                   uzgrad(l,k,j,i)=uzder(l,k,j)
1678                 enddo
1679               enddo
1680             enddo
1681             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1682             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1683             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1684             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1685           endif
1686           endif
1687       enddo
1688       if (calc_grad) then
1689       do i=1,nres-1
1690         vbld_inv_temp(1)=vbld_inv(i+1)
1691         if (i.lt.nres-1) then
1692           vbld_inv_temp(2)=vbld_inv(i+2)
1693         else
1694           vbld_inv_temp(2)=vbld_inv(i)
1695         endif
1696         do j=1,2
1697           do k=1,3
1698             do l=1,3
1699               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1700               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1701             enddo
1702           enddo
1703         enddo
1704       enddo
1705       endif
1706       return
1707       end
1708 C--------------------------------------------------------------------------
1709       subroutine set_matrices
1710       implicit real*8 (a-h,o-z)
1711       include 'DIMENSIONS'
1712 #ifdef MPI
1713       include "mpif.h"
1714       integer IERR
1715       integer status(MPI_STATUS_SIZE)
1716 #endif
1717       include 'COMMON.IOUNITS'
1718       include 'COMMON.GEO'
1719       include 'COMMON.VAR'
1720       include 'COMMON.LOCAL'
1721       include 'COMMON.CHAIN'
1722       include 'COMMON.DERIV'
1723       include 'COMMON.INTERACT'
1724       include 'COMMON.CONTACTS'
1725       include 'COMMON.TORSION'
1726       include 'COMMON.VECTORS'
1727       include 'COMMON.FFIELD'
1728       include 'COMMON.CORRMAT'
1729       double precision auxvec(2),auxmat(2,2)
1730 C
1731 C Compute the virtual-bond-torsional-angle dependent quantities needed
1732 C to calculate the el-loc multibody terms of various order.
1733 C
1734 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1735       do i=3,nres+1
1736         ii=ireschain(i-2)
1737         if (ii.eq.0) cycle
1738         innt=chain_border(1,ii)
1739         inct=chain_border(2,ii)
1740         if (i.gt. innt+2 .and. i.lt.inct+2) then
1741           iti = itype2loc(itype(i-2))
1742         else
1743           iti=nloctyp
1744         endif
1745 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1746         if (i.gt. innt+1 .and. i.lt.inct+1) then
1747           iti1 = itype2loc(itype(i-1))
1748         else
1749           iti1=nloctyp
1750         endif
1751 #ifdef NEWCORR
1752         cost1=dcos(theta(i-1))
1753         sint1=dsin(theta(i-1))
1754         sint1sq=sint1*sint1
1755         sint1cub=sint1sq*sint1
1756         sint1cost1=2*sint1*cost1
1757 #ifdef DEBUG
1758         write (iout,*) "bnew1",i,iti
1759         write (iout,*) (bnew1(k,1,iti),k=1,3)
1760         write (iout,*) (bnew1(k,2,iti),k=1,3)
1761         write (iout,*) "bnew2",i,iti
1762         write (iout,*) (bnew2(k,1,iti),k=1,3)
1763         write (iout,*) (bnew2(k,2,iti),k=1,3)
1764 #endif
1765         do k=1,2
1766           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1767           b1(k,i-2)=sint1*b1k
1768           gtb1(k,i-2)=cost1*b1k-sint1sq*
1769      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1770           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1771           b2(k,i-2)=sint1*b2k
1772           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1773      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1774         enddo
1775         do k=1,2
1776           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1777           cc(1,k,i-2)=sint1sq*aux
1778           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1779      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1780           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1781           dd(1,k,i-2)=sint1sq*aux
1782           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1783      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1784         enddo
1785         cc(2,1,i-2)=cc(1,2,i-2)
1786         cc(2,2,i-2)=-cc(1,1,i-2)
1787         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1788         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1789         dd(2,1,i-2)=dd(1,2,i-2)
1790         dd(2,2,i-2)=-dd(1,1,i-2)
1791         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1792         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1793         do k=1,2
1794           do l=1,2
1795             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1796             EE(l,k,i-2)=sint1sq*aux
1797             if (calc_grad)
1798      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1799           enddo
1800         enddo
1801         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1802         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1803         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1804         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1805         if (calc_grad) then
1806         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1807         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1808         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1809         endif
1810 c        b1tilde(1,i-2)=b1(1,i-2)
1811 c        b1tilde(2,i-2)=-b1(2,i-2)
1812 c        b2tilde(1,i-2)=b2(1,i-2)
1813 c        b2tilde(2,i-2)=-b2(2,i-2)
1814 #ifdef DEBUG
1815         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1816         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1817         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1818         write (iout,*) 'theta=', theta(i-1)
1819 #endif
1820 #else
1821         if (i.gt. innt+2 .and. i.lt.inct+2) then
1822 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1823           iti = itype2loc(itype(i-2))
1824         else
1825           iti=nloctyp
1826         endif
1827 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
1828 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1829         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1830           iti1 = itype2loc(itype(i-1))
1831         else
1832           iti1=nloctyp
1833         endif
1834 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1835 c          iti = itype2loc(itype(i-2))
1836 c        else
1837 c          iti=nloctyp
1838 c        endif
1839 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1840 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1841 c          iti1 = itype2loc(itype(i-1))
1842 c        else
1843 c          iti1=nloctyp
1844 c        endif
1845         b1(1,i-2)=b(3,iti)
1846         b1(2,i-2)=b(5,iti)
1847         b2(1,i-2)=b(2,iti)
1848         b2(2,i-2)=b(4,iti)
1849         do k=1,2
1850           do l=1,2
1851            CC(k,l,i-2)=ccold(k,l,iti)
1852            DD(k,l,i-2)=ddold(k,l,iti)
1853            EE(k,l,i-2)=eeold(k,l,iti)
1854           enddo
1855         enddo
1856 #endif
1857         b1tilde(1,i-2)= b1(1,i-2)
1858         b1tilde(2,i-2)=-b1(2,i-2)
1859         b2tilde(1,i-2)= b2(1,i-2)
1860         b2tilde(2,i-2)=-b2(2,i-2)
1861 c
1862         Ctilde(1,1,i-2)= CC(1,1,i-2)
1863         Ctilde(1,2,i-2)= CC(1,2,i-2)
1864         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1865         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1866 c
1867         Dtilde(1,1,i-2)= DD(1,1,i-2)
1868         Dtilde(1,2,i-2)= DD(1,2,i-2)
1869         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1870         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1871 c        write(iout,*) "i",i," iti",iti
1872 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1873 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1874       enddo
1875       do i=3,nres+1
1876         if (i .lt. nres+1) then
1877           sin1=dsin(phi(i))
1878           cos1=dcos(phi(i))
1879           sintab(i-2)=sin1
1880           costab(i-2)=cos1
1881           obrot(1,i-2)=cos1
1882           obrot(2,i-2)=sin1
1883           sin2=dsin(2*phi(i))
1884           cos2=dcos(2*phi(i))
1885           sintab2(i-2)=sin2
1886           costab2(i-2)=cos2
1887           obrot2(1,i-2)=cos2
1888           obrot2(2,i-2)=sin2
1889           Ug(1,1,i-2)=-cos1
1890           Ug(1,2,i-2)=-sin1
1891           Ug(2,1,i-2)=-sin1
1892           Ug(2,2,i-2)= cos1
1893           Ug2(1,1,i-2)=-cos2
1894           Ug2(1,2,i-2)=-sin2
1895           Ug2(2,1,i-2)=-sin2
1896           Ug2(2,2,i-2)= cos2
1897         else
1898           costab(i-2)=1.0d0
1899           sintab(i-2)=0.0d0
1900           obrot(1,i-2)=1.0d0
1901           obrot(2,i-2)=0.0d0
1902           obrot2(1,i-2)=0.0d0
1903           obrot2(2,i-2)=0.0d0
1904           Ug(1,1,i-2)=1.0d0
1905           Ug(1,2,i-2)=0.0d0
1906           Ug(2,1,i-2)=0.0d0
1907           Ug(2,2,i-2)=1.0d0
1908           Ug2(1,1,i-2)=0.0d0
1909           Ug2(1,2,i-2)=0.0d0
1910           Ug2(2,1,i-2)=0.0d0
1911           Ug2(2,2,i-2)=0.0d0
1912         endif
1913         if (i .gt. 3 .and. i .lt. nres+1) then
1914           obrot_der(1,i-2)=-sin1
1915           obrot_der(2,i-2)= cos1
1916           Ugder(1,1,i-2)= sin1
1917           Ugder(1,2,i-2)=-cos1
1918           Ugder(2,1,i-2)=-cos1
1919           Ugder(2,2,i-2)=-sin1
1920           dwacos2=cos2+cos2
1921           dwasin2=sin2+sin2
1922           obrot2_der(1,i-2)=-dwasin2
1923           obrot2_der(2,i-2)= dwacos2
1924           Ug2der(1,1,i-2)= dwasin2
1925           Ug2der(1,2,i-2)=-dwacos2
1926           Ug2der(2,1,i-2)=-dwacos2
1927           Ug2der(2,2,i-2)=-dwasin2
1928         else
1929           obrot_der(1,i-2)=0.0d0
1930           obrot_der(2,i-2)=0.0d0
1931           Ugder(1,1,i-2)=0.0d0
1932           Ugder(1,2,i-2)=0.0d0
1933           Ugder(2,1,i-2)=0.0d0
1934           Ugder(2,2,i-2)=0.0d0
1935           obrot2_der(1,i-2)=0.0d0
1936           obrot2_der(2,i-2)=0.0d0
1937           Ug2der(1,1,i-2)=0.0d0
1938           Ug2der(1,2,i-2)=0.0d0
1939           Ug2der(2,1,i-2)=0.0d0
1940           Ug2der(2,2,i-2)=0.0d0
1941         endif
1942 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1943         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1944           iti = itype2loc(itype(i-2))
1945         else
1946           iti=nloctyp
1947         endif
1948 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1949         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1950           iti1 = itype2loc(itype(i-1))
1951         else
1952           iti1=nloctyp
1953         endif
1954 cd        write (iout,*) '*******i',i,' iti1',iti
1955 cd        write (iout,*) 'b1',b1(:,iti)
1956 cd        write (iout,*) 'b2',b2(:,iti)
1957 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1958 c        if (i .gt. iatel_s+2) then
1959         if (i .gt. nnt+2) then
1960           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1961 #ifdef NEWCORR
1962           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1963 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1964 #endif
1965 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1966 c     &    EE(1,2,iti),EE(2,2,i)
1967           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1968           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1969 c          write(iout,*) "Macierz EUG",
1970 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1971 c     &    eug(2,2,i-2)
1972 #ifdef FOURBODY
1973           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1974      &    then
1975           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1976           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1977           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1978           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1979           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1980           endif
1981 #endif
1982         else
1983           do k=1,2
1984             Ub2(k,i-2)=0.0d0
1985             Ctobr(k,i-2)=0.0d0
1986             Dtobr2(k,i-2)=0.0d0
1987             do l=1,2
1988               EUg(l,k,i-2)=0.0d0
1989               CUg(l,k,i-2)=0.0d0
1990               DUg(l,k,i-2)=0.0d0
1991               DtUg2(l,k,i-2)=0.0d0
1992             enddo
1993           enddo
1994         endif
1995         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1996         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1997         do k=1,2
1998           muder(k,i-2)=Ub2der(k,i-2)
1999         enddo
2000 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2001         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2002           if (itype(i-1).le.ntyp) then
2003             iti1 = itype2loc(itype(i-1))
2004           else
2005             iti1=nloctyp
2006           endif
2007         else
2008           iti1=nloctyp
2009         endif
2010         do k=1,2
2011           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2012         enddo
2013 #ifdef MUOUT
2014         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2015      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2016      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2017      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2018      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2019      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2020 #endif
2021 cd        write (iout,*) 'mu1',mu1(:,i-2)
2022 cd        write (iout,*) 'mu2',mu2(:,i-2)
2023 #ifdef FOURBODY
2024         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2025      &  then
2026         if (calc_grad) then
2027         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2028         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2029         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2030         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2031         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2032         endif
2033 C Vectors and matrices dependent on a single virtual-bond dihedral.
2034         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2035         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2036         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2037         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2038         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2039         if (calc_grad) then
2040         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2041         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2042         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2043         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2044         endif
2045         endif
2046 #endif
2047       enddo
2048 #ifdef FOURBODY
2049 C Matrices dependent on two consecutive virtual-bond dihedrals.
2050 C The order of matrices is from left to right.
2051       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2052      &then
2053       do i=2,nres-1
2054         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2055         if (calc_grad) then
2056         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2057         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2058         endif
2059         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2060         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2061         if (calc_grad) then
2062         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2063         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2064         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2065         endif
2066       enddo
2067       endif
2068 #endif
2069       return
2070       end
2071 C--------------------------------------------------------------------------
2072       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2073 C
2074 C This subroutine calculates the average interaction energy and its gradient
2075 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2076 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2077 C The potential depends both on the distance of peptide-group centers and on
2078 C the orientation of the CA-CA virtual bonds.
2079 C
2080       implicit real*8 (a-h,o-z)
2081 #ifdef MPI
2082       include 'mpif.h'
2083 #endif
2084       include 'DIMENSIONS'
2085       include 'COMMON.CONTROL'
2086       include 'COMMON.IOUNITS'
2087       include 'COMMON.GEO'
2088       include 'COMMON.VAR'
2089       include 'COMMON.LOCAL'
2090       include 'COMMON.CHAIN'
2091       include 'COMMON.DERIV'
2092       include 'COMMON.INTERACT'
2093 #ifdef FOURBODY
2094       include 'COMMON.CONTACTS'
2095       include 'COMMON.CONTMAT'
2096 #endif
2097       include 'COMMON.CORRMAT'
2098       include 'COMMON.TORSION'
2099       include 'COMMON.VECTORS'
2100       include 'COMMON.FFIELD'
2101       include 'COMMON.TIME1'
2102       include 'COMMON.SPLITELE'
2103       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2104      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2105       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2106      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2107       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2108      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2109      &    num_conti,j1,j2
2110       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
2111       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
2112 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2113 #ifdef MOMENT
2114       double precision scal_el /1.0d0/
2115 #else
2116       double precision scal_el /0.5d0/
2117 #endif
2118 C 12/13/98
2119 C 13-go grudnia roku pamietnego...
2120       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2121      &                   0.0d0,1.0d0,0.0d0,
2122      &                   0.0d0,0.0d0,1.0d0/
2123 cd      write(iout,*) 'In EELEC'
2124 cd      do i=1,nloctyp
2125 cd        write(iout,*) 'Type',i
2126 cd        write(iout,*) 'B1',B1(:,i)
2127 cd        write(iout,*) 'B2',B2(:,i)
2128 cd        write(iout,*) 'CC',CC(:,:,i)
2129 cd        write(iout,*) 'DD',DD(:,:,i)
2130 cd        write(iout,*) 'EE',EE(:,:,i)
2131 cd      enddo
2132 cd      call check_vecgrad
2133 cd      stop
2134       if (icheckgrad.eq.1) then
2135         do i=1,nres-1
2136           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2137           do k=1,3
2138             dc_norm(k,i)=dc(k,i)*fac
2139           enddo
2140 c          write (iout,*) 'i',i,' fac',fac
2141         enddo
2142       endif
2143       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2144      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2145      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2146 c        call vec_and_deriv
2147 #ifdef TIMING
2148         time01=MPI_Wtime()
2149 #endif
2150         call set_matrices
2151 #ifdef TIMING
2152         time_mat=time_mat+MPI_Wtime()-time01
2153 #endif
2154       endif
2155 cd      do i=1,nres-1
2156 cd        write (iout,*) 'i=',i
2157 cd        do k=1,3
2158 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2159 cd        enddo
2160 cd        do k=1,3
2161 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2162 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2163 cd        enddo
2164 cd      enddo
2165       t_eelecij=0.0d0
2166       ees=0.0D0
2167       evdw1=0.0D0
2168       eel_loc=0.0d0
2169       eello_turn3=0.0d0
2170       eello_turn4=0.0d0
2171       ind=0
2172 #ifdef FOURBODY
2173       do i=1,nres
2174         num_cont_hb(i)=0
2175       enddo
2176 #endif
2177 cd      print '(a)','Enter EELEC'
2178 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2179 c      call flush(iout)
2180       do i=1,nres
2181         gel_loc_loc(i)=0.0d0
2182         gcorr_loc(i)=0.0d0
2183       enddo
2184 c
2185 c
2186 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2187 C
2188 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2189 C
2190 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2191       do i=iturn3_start,iturn3_end
2192 c        if (i.le.1) cycle
2193 C        write(iout,*) "tu jest i",i
2194         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2195 C changes suggested by Ana to avoid out of bounds
2196 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2197 c     & .or.((i+4).gt.nres)
2198 c     & .or.((i-1).le.0)
2199 C end of changes by Ana
2200 C dobra zmiana wycofana
2201      &  .or. itype(i+2).eq.ntyp1
2202      &  .or. itype(i+3).eq.ntyp1) cycle
2203 C Adam: Instructions below will switch off existing interactions
2204 c        if(i.gt.1)then
2205 c          if(itype(i-1).eq.ntyp1)cycle
2206 c        end if
2207 c        if(i.LT.nres-3)then
2208 c          if (itype(i+4).eq.ntyp1) cycle
2209 c        end if
2210         dxi=dc(1,i)
2211         dyi=dc(2,i)
2212         dzi=dc(3,i)
2213         dx_normi=dc_norm(1,i)
2214         dy_normi=dc_norm(2,i)
2215         dz_normi=dc_norm(3,i)
2216         xmedi=c(1,i)+0.5d0*dxi
2217         ymedi=c(2,i)+0.5d0*dyi
2218         zmedi=c(3,i)+0.5d0*dzi
2219         call to_box(xmedi,ymedi,zmedi)
2220         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2221         num_conti=0
2222         call eelecij(i,i+2,ees,evdw1,eel_loc)
2223         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2224 #ifdef FOURBODY
2225         num_cont_hb(i)=num_conti
2226 #endif
2227       enddo
2228       do i=iturn4_start,iturn4_end
2229         if (i.lt.1) cycle
2230         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2231 C changes suggested by Ana to avoid out of bounds
2232 c     & .or.((i+5).gt.nres)
2233 c     & .or.((i-1).le.0)
2234 C end of changes suggested by Ana
2235      &    .or. itype(i+3).eq.ntyp1
2236      &    .or. itype(i+4).eq.ntyp1
2237 c     &    .or. itype(i+5).eq.ntyp1
2238 c     &    .or. itype(i).eq.ntyp1
2239 c     &    .or. itype(i-1).eq.ntyp1
2240      &                             ) cycle
2241         dxi=dc(1,i)
2242         dyi=dc(2,i)
2243         dzi=dc(3,i)
2244         dx_normi=dc_norm(1,i)
2245         dy_normi=dc_norm(2,i)
2246         dz_normi=dc_norm(3,i)
2247         xmedi=c(1,i)+0.5d0*dxi
2248         ymedi=c(2,i)+0.5d0*dyi
2249         zmedi=c(3,i)+0.5d0*dzi
2250         call to_box(xmedi,ymedi,zmedi)
2251         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2252 #ifdef FOURBODY
2253         num_conti=num_cont_hb(i)
2254 #endif
2255 c        write(iout,*) "JESTEM W PETLI"
2256         call eelecij(i,i+3,ees,evdw1,eel_loc)
2257         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2258      &   call eturn4(i,eello_turn4)
2259 #ifdef FOURBODY
2260         num_cont_hb(i)=num_conti
2261 #endif
2262       enddo   ! i
2263 C Loop over all neighbouring boxes
2264 C      do xshift=-1,1
2265 C      do yshift=-1,1
2266 C      do zshift=-1,1
2267 c
2268 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2269 c
2270 CTU KURWA
2271       do i=iatel_s,iatel_e
2272 C        do i=75,75
2273 c        if (i.le.1) cycle
2274         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2275 C changes suggested by Ana to avoid out of bounds
2276 c     & .or.((i+2).gt.nres)
2277 c     & .or.((i-1).le.0)
2278 C end of changes by Ana
2279 c     &  .or. itype(i+2).eq.ntyp1
2280 c     &  .or. itype(i-1).eq.ntyp1
2281      &                ) cycle
2282         dxi=dc(1,i)
2283         dyi=dc(2,i)
2284         dzi=dc(3,i)
2285         dx_normi=dc_norm(1,i)
2286         dy_normi=dc_norm(2,i)
2287         dz_normi=dc_norm(3,i)
2288         xmedi=c(1,i)+0.5d0*dxi
2289         ymedi=c(2,i)+0.5d0*dyi
2290         zmedi=c(3,i)+0.5d0*dzi
2291         call to_box(xmedi,ymedi,zmedi)
2292         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2293 #ifdef FOURBODY
2294         num_conti=num_cont_hb(i)
2295 #endif
2296 C I TU KURWA
2297         do j=ielstart(i),ielend(i)
2298 C          do j=16,17
2299 C          write (iout,*) i,j
2300 C         if (j.le.1) cycle
2301           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2302 C changes suggested by Ana to avoid out of bounds
2303 c     & .or.((j+2).gt.nres)
2304 c     & .or.((j-1).le.0)
2305 C end of changes by Ana
2306 c     & .or.itype(j+2).eq.ntyp1
2307 c     & .or.itype(j-1).eq.ntyp1
2308      &) cycle
2309           call eelecij(i,j,ees,evdw1,eel_loc)
2310         enddo ! j
2311 #ifdef FOURBODY
2312         num_cont_hb(i)=num_conti
2313 #endif
2314       enddo   ! i
2315 C     enddo   ! zshift
2316 C      enddo   ! yshift
2317 C      enddo   ! xshift
2318
2319 c      write (iout,*) "Number of loop steps in EELEC:",ind
2320 cd      do i=1,nres
2321 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2322 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2323 cd      enddo
2324 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2325 ccc      eel_loc=eel_loc+eello_turn3
2326 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2327       return
2328       end
2329 C-------------------------------------------------------------------------------
2330       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2331       implicit real*8 (a-h,o-z)
2332       include 'DIMENSIONS'
2333 #ifdef MPI
2334       include "mpif.h"
2335 #endif
2336       include 'COMMON.CONTROL'
2337       include 'COMMON.IOUNITS'
2338       include 'COMMON.GEO'
2339       include 'COMMON.VAR'
2340       include 'COMMON.LOCAL'
2341       include 'COMMON.CHAIN'
2342       include 'COMMON.DERIV'
2343       include 'COMMON.INTERACT'
2344 #ifdef FOURBODY
2345       include 'COMMON.CONTACTS'
2346       include 'COMMON.CONTMAT'
2347 #endif
2348       include 'COMMON.CORRMAT'
2349       include 'COMMON.TORSION'
2350       include 'COMMON.VECTORS'
2351       include 'COMMON.FFIELD'
2352       include 'COMMON.TIME1'
2353       include 'COMMON.SPLITELE'
2354       include 'COMMON.SHIELD'
2355       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2356      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2357       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2358      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2359      &    gmuij2(4),gmuji2(4)
2360       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2361      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2362      &    num_conti,j1,j2
2363       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
2364      & faclipij2
2365       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
2366 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2367 #ifdef MOMENT
2368       double precision scal_el /1.0d0/
2369 #else
2370       double precision scal_el /0.5d0/
2371 #endif
2372 C 12/13/98
2373 C 13-go grudnia roku pamietnego...
2374       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2375      &                   0.0d0,1.0d0,0.0d0,
2376      &                   0.0d0,0.0d0,1.0d0/
2377        integer xshift,yshift,zshift
2378 c          time00=MPI_Wtime()
2379 cd      write (iout,*) "eelecij",i,j
2380 c          ind=ind+1
2381           iteli=itel(i)
2382           itelj=itel(j)
2383           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2384           aaa=app(iteli,itelj)
2385           bbb=bpp(iteli,itelj)
2386           ael6i=ael6(iteli,itelj)
2387           ael3i=ael3(iteli,itelj)
2388           dxj=dc(1,j)
2389           dyj=dc(2,j)
2390           dzj=dc(3,j)
2391           dx_normj=dc_norm(1,j)
2392           dy_normj=dc_norm(2,j)
2393           dz_normj=dc_norm(3,j)
2394 C          xj=c(1,j)+0.5D0*dxj-xmedi
2395 C          yj=c(2,j)+0.5D0*dyj-ymedi
2396 C          zj=c(3,j)+0.5D0*dzj-zmedi
2397           xj=c(1,j)+0.5D0*dxj
2398           yj=c(2,j)+0.5D0*dyj
2399           zj=c(3,j)+0.5D0*dzj
2400           call to_box(xj,yj,zj)
2401           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2402           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
2403           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
2404           xj=boxshift(xj-xmedi,boxxsize)
2405           yj=boxshift(yj-ymedi,boxysize)
2406           zj=boxshift(zj-zmedi,boxzsize)
2407           rij=xj*xj+yj*yj+zj*zj
2408           sss=sscale(sqrt(rij))
2409           if (sss.eq.0.0d0) return
2410           sssgrad=sscagrad(sqrt(rij))
2411 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2412 c     &       " rlamb",rlamb," sss",sss
2413 c            if (sss.gt.0.0d0) then
2414           rrmij=1.0D0/rij
2415           rij=dsqrt(rij)
2416           rmij=1.0D0/rij
2417           r3ij=rrmij*rmij
2418           r6ij=r3ij*r3ij
2419           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2420           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2421           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2422           fac=cosa-3.0D0*cosb*cosg
2423           ev1=aaa*r6ij*r6ij
2424 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2425           if (j.eq.i+2) ev1=scal_el*ev1
2426           ev2=bbb*r6ij
2427           fac3=ael6i*r6ij
2428           fac4=ael3i*r3ij
2429           evdwij=(ev1+ev2)
2430           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2431           el2=fac4*fac
2432 C MARYSIA
2433 C          eesij=(el1+el2)
2434 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2435           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2436           if (shield_mode.gt.0) then
2437 C          fac_shield(i)=0.4
2438 C          fac_shield(j)=0.6
2439           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2440           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2441           eesij=(el1+el2)
2442           ees=ees+eesij*faclipij2
2443           else
2444           fac_shield(i)=1.0
2445           fac_shield(j)=1.0
2446           eesij=(el1+el2)
2447           ees=ees+eesij*faclipij2
2448           endif
2449           evdw1=evdw1+evdwij*sss*faclipij2
2450 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2451 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2452 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2453 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2454
2455           if (energy_dec) then
2456             write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2457      &       'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss
2458             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
2459      &       fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
2460      &       faclipij2
2461           endif
2462
2463 C
2464 C Calculate contributions to the Cartesian gradient.
2465 C
2466 #ifdef SPLITELE
2467           facvdw=-6*rrmij*(ev1+evdwij)*sss
2468           facel=-3*rrmij*(el1+eesij)
2469           fac1=fac
2470           erij(1)=xj*rmij
2471           erij(2)=yj*rmij
2472           erij(3)=zj*rmij
2473
2474 *
2475 * Radial derivatives. First process both termini of the fragment (i,j)
2476 *
2477           if (calc_grad) then
2478           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
2479           ggg(1)=aux*xj
2480           ggg(2)=aux*yj
2481           ggg(3)=aux*zj
2482           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2483      &  (shield_mode.gt.0)) then
2484 C          print *,i,j
2485           do ilist=1,ishield_list(i)
2486            iresshield=shield_list(ilist,i)
2487            do k=1,3
2488            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2489      &      *2.0
2490            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2491      &              rlocshield
2492      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2493             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2494 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2495 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2496 C             if (iresshield.gt.i) then
2497 C               do ishi=i+1,iresshield-1
2498 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2499 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2500 C
2501 C              enddo
2502 C             else
2503 C               do ishi=iresshield,i
2504 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2505 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2506 C
2507 C               enddo
2508 C              endif
2509            enddo
2510           enddo
2511           do ilist=1,ishield_list(j)
2512            iresshield=shield_list(ilist,j)
2513            do k=1,3
2514            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2515      &     *2.0
2516            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2517      &              rlocshield
2518      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2519            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2520
2521 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2522 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2523 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2524 C             if (iresshield.gt.j) then
2525 C               do ishi=j+1,iresshield-1
2526 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2527 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2528 C
2529 C               enddo
2530 C            else
2531 C               do ishi=iresshield,j
2532 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2533 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2534 C               enddo
2535 C              endif
2536            enddo
2537           enddo
2538
2539           do k=1,3
2540             gshieldc(k,i)=gshieldc(k,i)+
2541      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2542             gshieldc(k,j)=gshieldc(k,j)+
2543      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2544             gshieldc(k,i-1)=gshieldc(k,i-1)+
2545      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2546             gshieldc(k,j-1)=gshieldc(k,j-1)+
2547      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2548
2549            enddo
2550            endif
2551 c          do k=1,3
2552 c            ghalf=0.5D0*ggg(k)
2553 c            gelc(k,i)=gelc(k,i)+ghalf
2554 c            gelc(k,j)=gelc(k,j)+ghalf
2555 c          enddo
2556 c 9/28/08 AL Gradient compotents will be summed only at the end
2557 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2558           do k=1,3
2559             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2560 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2561             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2562 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2563 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2564 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2565 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2566 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2567           enddo
2568 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2569
2570 *
2571 * Loop over residues i+1 thru j-1.
2572 *
2573 cgrad          do k=i+1,j-1
2574 cgrad            do l=1,3
2575 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2576 cgrad            enddo
2577 cgrad          enddo
2578           if (sss.gt.0.0) then
2579           facvdw=facvdw+sssgrad*rmij*evdwij*faclipij2
2580           ggg(1)=facvdw*xj
2581           ggg(2)=facvdw*yj
2582           ggg(3)=facvdw*zj
2583           else
2584           ggg(1)=0.0
2585           ggg(2)=0.0
2586           ggg(3)=0.0
2587           endif
2588 c          do k=1,3
2589 c            ghalf=0.5D0*ggg(k)
2590 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2591 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2592 c          enddo
2593 c 9/28/08 AL Gradient compotents will be summed only at the end
2594           do k=1,3
2595             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2596             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2597           enddo
2598 *
2599 * Loop over residues i+1 thru j-1.
2600 *
2601 cgrad          do k=i+1,j-1
2602 cgrad            do l=1,3
2603 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2604 cgrad            enddo
2605 cgrad          enddo
2606           endif ! calc_grad
2607 #else
2608 C MARYSIA
2609           facvdw=(ev1+evdwij)*faclipij2
2610           facel=(el1+eesij)
2611           fac1=fac
2612           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2613      &       +(evdwij+eesij)*sssgrad*rrmij
2614           erij(1)=xj*rmij
2615           erij(2)=yj*rmij
2616           erij(3)=zj*rmij
2617 *
2618 * Radial derivatives. First process both termini of the fragment (i,j)
2619 *
2620           if (calc_grad) then
2621           ggg(1)=fac*xj
2622 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2623           ggg(2)=fac*yj
2624 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2625           ggg(3)=fac*zj
2626 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2627 c          do k=1,3
2628 c            ghalf=0.5D0*ggg(k)
2629 c            gelc(k,i)=gelc(k,i)+ghalf
2630 c            gelc(k,j)=gelc(k,j)+ghalf
2631 c          enddo
2632 c 9/28/08 AL Gradient compotents will be summed only at the end
2633           do k=1,3
2634             gelc_long(k,j)=gelc(k,j)+ggg(k)
2635             gelc_long(k,i)=gelc(k,i)-ggg(k)
2636           enddo
2637 *
2638 * Loop over residues i+1 thru j-1.
2639 *
2640 cgrad          do k=i+1,j-1
2641 cgrad            do l=1,3
2642 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2643 cgrad            enddo
2644 cgrad          enddo
2645 c 9/28/08 AL Gradient compotents will be summed only at the end
2646           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2647           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2648           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2649           do k=1,3
2650             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2651             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2652           enddo
2653           endif ! calc_grad
2654 #endif
2655 *
2656 * Angular part
2657 *
2658           if (calc_grad) then
2659           ecosa=2.0D0*fac3*fac1+fac4
2660           fac4=-3.0D0*fac4
2661           fac3=-6.0D0*fac3
2662           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2663           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2664           do k=1,3
2665             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2666             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2667           enddo
2668 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2669 cd   &          (dcosg(k),k=1,3)
2670           do k=1,3
2671             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2672      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
2673           enddo
2674 c          do k=1,3
2675 c            ghalf=0.5D0*ggg(k)
2676 c            gelc(k,i)=gelc(k,i)+ghalf
2677 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2678 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2679 c            gelc(k,j)=gelc(k,j)+ghalf
2680 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2681 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2682 c          enddo
2683 cgrad          do k=i+1,j-1
2684 cgrad            do l=1,3
2685 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2686 cgrad            enddo
2687 cgrad          enddo
2688 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2689           do k=1,3
2690             gelc(k,i)=gelc(k,i)
2691      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2692      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2693      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2694             gelc(k,j)=gelc(k,j)
2695      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2696      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2697      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2698             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2699             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2700           enddo
2701 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2702
2703 C MARYSIA
2704 c          endif !sscale
2705           endif ! calc_grad
2706           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2707      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2708      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2709 C
2710 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2711 C   energy of a peptide unit is assumed in the form of a second-order
2712 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2713 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2714 C   are computed for EVERY pair of non-contiguous peptide groups.
2715 C
2716
2717           if (j.lt.nres-1) then
2718             j1=j+1
2719             j2=j-1
2720           else
2721             j1=j-1
2722             j2=j-2
2723           endif
2724           kkk=0
2725           lll=0
2726           do k=1,2
2727             do l=1,2
2728               kkk=kkk+1
2729               muij(kkk)=mu(k,i)*mu(l,j)
2730 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2731 #ifdef NEWCORR
2732              if (calc_grad) then
2733              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2734 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2735              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2736              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2737 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2738              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2739              endif
2740 #endif
2741             enddo
2742           enddo
2743 #ifdef DEBUG
2744           write (iout,*) 'EELEC: i',i,' j',j
2745           write (iout,*) 'j',j,' j1',j1,' j2',j2
2746           write(iout,*) 'muij',muij
2747           write (iout,*) "uy",uy(:,i)
2748           write (iout,*) "uz",uz(:,j)
2749           write (iout,*) "erij",erij
2750 #endif
2751           ury=scalar(uy(1,i),erij)
2752           urz=scalar(uz(1,i),erij)
2753           vry=scalar(uy(1,j),erij)
2754           vrz=scalar(uz(1,j),erij)
2755           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2756           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2757           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2758           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2759           fac=dsqrt(-ael6i)*r3ij
2760           a22=a22*fac
2761           a23=a23*fac
2762           a32=a32*fac
2763           a33=a33*fac
2764 cd          write (iout,'(4i5,4f10.5)')
2765 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2766 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2767 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2768 cd     &      uy(:,j),uz(:,j)
2769 cd          write (iout,'(4f10.5)')
2770 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2771 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2772 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2773 cd           write (iout,'(9f10.5/)')
2774 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2775 C Derivatives of the elements of A in virtual-bond vectors
2776           if (calc_grad) then
2777           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2778           do k=1,3
2779             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2780             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2781             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2782             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2783             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2784             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2785             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2786             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2787             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2788             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2789             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2790             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2791           enddo
2792 C Compute radial contributions to the gradient
2793           facr=-3.0d0*rrmij
2794           a22der=a22*facr
2795           a23der=a23*facr
2796           a32der=a32*facr
2797           a33der=a33*facr
2798           agg(1,1)=a22der*xj
2799           agg(2,1)=a22der*yj
2800           agg(3,1)=a22der*zj
2801           agg(1,2)=a23der*xj
2802           agg(2,2)=a23der*yj
2803           agg(3,2)=a23der*zj
2804           agg(1,3)=a32der*xj
2805           agg(2,3)=a32der*yj
2806           agg(3,3)=a32der*zj
2807           agg(1,4)=a33der*xj
2808           agg(2,4)=a33der*yj
2809           agg(3,4)=a33der*zj
2810 C Add the contributions coming from er
2811           fac3=-3.0d0*fac
2812           do k=1,3
2813             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2814             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2815             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2816             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2817           enddo
2818           do k=1,3
2819 C Derivatives in DC(i)
2820 cgrad            ghalf1=0.5d0*agg(k,1)
2821 cgrad            ghalf2=0.5d0*agg(k,2)
2822 cgrad            ghalf3=0.5d0*agg(k,3)
2823 cgrad            ghalf4=0.5d0*agg(k,4)
2824             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2825      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2826             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2827      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2828             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2829      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2830             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2831      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2832 C Derivatives in DC(i+1)
2833             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2834      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2835             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2836      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2837             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2838      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2839             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2840      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2841 C Derivatives in DC(j)
2842             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2843      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2844             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2845      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2846             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2847      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2848             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2849      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2850 C Derivatives in DC(j+1) or DC(nres-1)
2851             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2852      &      -3.0d0*vryg(k,3)*ury)
2853             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2854      &      -3.0d0*vrzg(k,3)*ury)
2855             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2856      &      -3.0d0*vryg(k,3)*urz)
2857             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2858      &      -3.0d0*vrzg(k,3)*urz)
2859 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2860 cgrad              do l=1,4
2861 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2862 cgrad              enddo
2863 cgrad            endif
2864           enddo
2865           endif ! calc_grad
2866           acipa(1,1)=a22
2867           acipa(1,2)=a23
2868           acipa(2,1)=a32
2869           acipa(2,2)=a33
2870           a22=-a22
2871           a23=-a23
2872           if (calc_grad) then
2873           do l=1,2
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 ! calc_grad
2883           if (j.lt.nres-1) then
2884             a22=-a22
2885             a32=-a32
2886             do l=1,3,2
2887               do k=1,3
2888                 agg(k,l)=-agg(k,l)
2889                 aggi(k,l)=-aggi(k,l)
2890                 aggi1(k,l)=-aggi1(k,l)
2891                 aggj(k,l)=-aggj(k,l)
2892                 aggj1(k,l)=-aggj1(k,l)
2893               enddo
2894             enddo
2895           else
2896             a22=-a22
2897             a23=-a23
2898             a32=-a32
2899             a33=-a33
2900             do l=1,4
2901               do k=1,3
2902                 agg(k,l)=-agg(k,l)
2903                 aggi(k,l)=-aggi(k,l)
2904                 aggi1(k,l)=-aggi1(k,l)
2905                 aggj(k,l)=-aggj(k,l)
2906                 aggj1(k,l)=-aggj1(k,l)
2907               enddo
2908             enddo
2909           endif
2910           ENDIF ! WCORR
2911           IF (wel_loc.gt.0.0d0) THEN
2912 C Contribution to the local-electrostatic energy coming from the i-j pair
2913           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2914      &     +a33*muij(4)
2915 #ifdef DEBUG
2916           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2917      &     " a33",a33
2918           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2919      &     " wel_loc",wel_loc
2920 #endif
2921           if (shield_mode.eq.0) then
2922            fac_shield(i)=1.0
2923            fac_shield(j)=1.0
2924 C          else
2925 C           fac_shield(i)=0.4
2926 C           fac_shield(j)=0.6
2927           endif
2928           eel_loc_ij=eel_loc_ij
2929      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
2930           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2931      &            'eelloc',i,j,eel_loc_ij
2932 c           if (eel_loc_ij.ne.0)
2933 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2934 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2935
2936           eel_loc=eel_loc+eel_loc_ij
2937 C Now derivative over eel_loc
2938           if (calc_grad) then
2939           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2940      &  (shield_mode.gt.0)) then
2941 C          print *,i,j
2942
2943           do ilist=1,ishield_list(i)
2944            iresshield=shield_list(ilist,i)
2945            do k=1,3
2946            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2947      &                                          /fac_shield(i)
2948 C     &      *2.0
2949            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2950      &              rlocshield
2951      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2952             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2953      &      +rlocshield
2954            enddo
2955           enddo
2956           do ilist=1,ishield_list(j)
2957            iresshield=shield_list(ilist,j)
2958            do k=1,3
2959            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2960      &                                       /fac_shield(j)
2961 C     &     *2.0
2962            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2963      &              rlocshield
2964      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2965            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2966      &             +rlocshield
2967
2968            enddo
2969           enddo
2970
2971           do k=1,3
2972             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2973      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2974             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2975      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2976             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2977      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2978             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2979      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2980            enddo
2981            endif
2982
2983
2984 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
2985 c     &                     ' eel_loc_ij',eel_loc_ij
2986 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2987 C Calculate patrial derivative for theta angle
2988 #ifdef NEWCORR
2989          geel_loc_ij=(a22*gmuij1(1)
2990      &     +a23*gmuij1(2)
2991      &     +a32*gmuij1(3)
2992      &     +a33*gmuij1(4))
2993      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
2994 c         write(iout,*) "derivative over thatai"
2995 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
2996 c     &   a33*gmuij1(4)
2997          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
2998      &      geel_loc_ij*wel_loc
2999 c         write(iout,*) "derivative over thatai-1"
3000 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3001 c     &   a33*gmuij2(4)
3002          geel_loc_ij=
3003      &     a22*gmuij2(1)
3004      &     +a23*gmuij2(2)
3005      &     +a32*gmuij2(3)
3006      &     +a33*gmuij2(4)
3007          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3008      &      geel_loc_ij*wel_loc
3009      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3010
3011 c  Derivative over j residue
3012          geel_loc_ji=a22*gmuji1(1)
3013      &     +a23*gmuji1(2)
3014      &     +a32*gmuji1(3)
3015      &     +a33*gmuji1(4)
3016 c         write(iout,*) "derivative over thataj"
3017 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3018 c     &   a33*gmuji1(4)
3019
3020         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3021      &      geel_loc_ji*wel_loc
3022      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3023
3024          geel_loc_ji=
3025      &     +a22*gmuji2(1)
3026      &     +a23*gmuji2(2)
3027      &     +a32*gmuji2(3)
3028      &     +a33*gmuji2(4)
3029 c         write(iout,*) "derivative over thataj-1"
3030 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3031 c     &   a33*gmuji2(4)
3032          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3033      &      geel_loc_ji*wel_loc
3034      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3035 #endif
3036 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3037
3038 C Partial derivatives in virtual-bond dihedral angles gamma
3039           if (i.gt.1)
3040      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3041      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3042      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3043      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3044
3045           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3046      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3047      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3048      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3049 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3050           aux=eel_loc_ij/sss*sssgrad*rmij
3051           ggg(1)=aux*xj
3052           ggg(2)=aux*yj
3053           ggg(3)=aux*zj
3054           do l=1,3
3055             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3056      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3057      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3058             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3059             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3060 cgrad            ghalf=0.5d0*ggg(l)
3061 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3062 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3063           enddo
3064 cgrad          do k=i+1,j2
3065 cgrad            do l=1,3
3066 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3067 cgrad            enddo
3068 cgrad          enddo
3069 C Remaining derivatives of eello
3070           gel_loc_long(3,j)=gel_loc_long(3,j)+
3071      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
3072
3073           gel_loc_long(3,i)=gel_loc_long(3,i)+
3074      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
3075           do l=1,3
3076             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3077      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3078      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3079
3080             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3081      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3082      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3083
3084             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3085      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3086      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3087
3088             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3089      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3090      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3091
3092           enddo
3093           endif ! calc_grad
3094           ENDIF
3095
3096
3097 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3098 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3099 #ifdef FOURBODY
3100           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3101      &       .and. num_conti.le.maxconts) then
3102 c            write (iout,*) i,j," entered corr"
3103 C
3104 C Calculate the contact function. The ith column of the array JCONT will
3105 C contain the numbers of atoms that make contacts with the atom I (of numbers
3106 C greater than I). The arrays FACONT and GACONT will contain the values of
3107 C the contact function and its derivative.
3108 c           r0ij=1.02D0*rpp(iteli,itelj)
3109 c           r0ij=1.11D0*rpp(iteli,itelj)
3110             r0ij=2.20D0*rpp(iteli,itelj)
3111 c           r0ij=1.55D0*rpp(iteli,itelj)
3112             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3113             if (fcont.gt.0.0D0) then
3114               num_conti=num_conti+1
3115               if (num_conti.gt.maxconts) then
3116                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3117      &                         ' will skip next contacts for this conf.'
3118               else
3119                 jcont_hb(num_conti,i)=j
3120 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3121 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3122                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3123      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3124 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3125 C  terms.
3126                 d_cont(num_conti,i)=rij
3127 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3128 C     --- Electrostatic-interaction matrix ---
3129                 a_chuj(1,1,num_conti,i)=a22
3130                 a_chuj(1,2,num_conti,i)=a23
3131                 a_chuj(2,1,num_conti,i)=a32
3132                 a_chuj(2,2,num_conti,i)=a33
3133 C     --- Gradient of rij
3134                 if (calc_grad) then
3135                 do kkk=1,3
3136                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3137                 enddo
3138                 kkll=0
3139                 do k=1,2
3140                   do l=1,2
3141                     kkll=kkll+1
3142                     do m=1,3
3143                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3144                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3145                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3146                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3147                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3148                     enddo
3149                   enddo
3150                 enddo
3151                 endif ! calc_grad
3152                 ENDIF
3153                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3154 C Calculate contact energies
3155                 cosa4=4.0D0*cosa
3156                 wij=cosa-3.0D0*cosb*cosg
3157                 cosbg1=cosb+cosg
3158                 cosbg2=cosb-cosg
3159 c               fac3=dsqrt(-ael6i)/r0ij**3
3160                 fac3=dsqrt(-ael6i)*r3ij
3161 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3162                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3163                 if (ees0tmp.gt.0) then
3164                   ees0pij=dsqrt(ees0tmp)
3165                 else
3166                   ees0pij=0
3167                 endif
3168 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3169                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3170                 if (ees0tmp.gt.0) then
3171                   ees0mij=dsqrt(ees0tmp)
3172                 else
3173                   ees0mij=0
3174                 endif
3175 c               ees0mij=0.0D0
3176                 if (shield_mode.eq.0) then
3177                 fac_shield(i)=1.0d0
3178                 fac_shield(j)=1.0d0
3179                 else
3180                 ees0plist(num_conti,i)=j
3181 C                fac_shield(i)=0.4d0
3182 C                fac_shield(j)=0.6d0
3183                 endif
3184                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3185      &          *fac_shield(i)*fac_shield(j)
3186                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3187      &          *fac_shield(i)*fac_shield(j)
3188 C Diagnostics. Comment out or remove after debugging!
3189 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3190 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3191 c               ees0m(num_conti,i)=0.0D0
3192 C End diagnostics.
3193 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3194 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3195 C Angular derivatives of the contact function
3196
3197                 ees0pij1=fac3/ees0pij
3198                 ees0mij1=fac3/ees0mij
3199                 fac3p=-3.0D0*fac3*rrmij
3200                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3201                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3202 c               ees0mij1=0.0D0
3203                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3204                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3205                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3206                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3207                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3208                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3209                 ecosap=ecosa1+ecosa2
3210                 ecosbp=ecosb1+ecosb2
3211                 ecosgp=ecosg1+ecosg2
3212                 ecosam=ecosa1-ecosa2
3213                 ecosbm=ecosb1-ecosb2
3214                 ecosgm=ecosg1-ecosg2
3215 C Diagnostics
3216 c               ecosap=ecosa1
3217 c               ecosbp=ecosb1
3218 c               ecosgp=ecosg1
3219 c               ecosam=0.0D0
3220 c               ecosbm=0.0D0
3221 c               ecosgm=0.0D0
3222 C End diagnostics
3223                 facont_hb(num_conti,i)=fcont
3224
3225                 if (calc_grad) then
3226                 fprimcont=fprimcont/rij
3227 cd              facont_hb(num_conti,i)=1.0D0
3228 C Following line is for diagnostics.
3229 cd              fprimcont=0.0D0
3230                 do k=1,3
3231                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3232                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3233                 enddo
3234                 do k=1,3
3235                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3236                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3237                 enddo
3238                 gggp(1)=gggp(1)+ees0pijp*xj
3239      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3240                 gggp(2)=gggp(2)+ees0pijp*yj
3241      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3242                 gggp(3)=gggp(3)+ees0pijp*zj
3243      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3244                 gggm(1)=gggm(1)+ees0mijp*xj
3245      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3246                 gggm(2)=gggm(2)+ees0mijp*yj
3247      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3248                 gggm(3)=gggm(3)+ees0mijp*zj
3249      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3250 C Derivatives due to the contact function
3251                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3252                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3253                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3254                 do k=1,3
3255 c
3256 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3257 c          following the change of gradient-summation algorithm.
3258 c
3259 cgrad                  ghalfp=0.5D0*gggp(k)
3260 cgrad                  ghalfm=0.5D0*gggm(k)
3261                   gacontp_hb1(k,num_conti,i)=!ghalfp
3262      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3263      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3264      &          *fac_shield(i)*fac_shield(j)*sss
3265
3266                   gacontp_hb2(k,num_conti,i)=!ghalfp
3267      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3268      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3269      &          *fac_shield(i)*fac_shield(j)*sss
3270
3271                   gacontp_hb3(k,num_conti,i)=gggp(k)
3272      &          *fac_shield(i)*fac_shield(j)*sss
3273
3274                   gacontm_hb1(k,num_conti,i)=!ghalfm
3275      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3276      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3277      &          *fac_shield(i)*fac_shield(j)*sss
3278
3279                   gacontm_hb2(k,num_conti,i)=!ghalfm
3280      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3281      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3282      &          *fac_shield(i)*fac_shield(j)*sss
3283
3284                   gacontm_hb3(k,num_conti,i)=gggm(k)
3285      &          *fac_shield(i)*fac_shield(j)
3286 *sss
3287                 enddo
3288 C Diagnostics. Comment out or remove after debugging!
3289 cdiag           do k=1,3
3290 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3291 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3292 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3293 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3294 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3295 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3296 cdiag           enddo
3297
3298                  endif ! calc_grad
3299
3300               ENDIF ! wcorr
3301               endif  ! num_conti.le.maxconts
3302             endif  ! fcont.gt.0
3303           endif    ! j.gt.i+1
3304 #endif
3305           if (calc_grad) then
3306           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3307             do k=1,4
3308               do l=1,3
3309                 ghalf=0.5d0*agg(l,k)
3310                 aggi(l,k)=aggi(l,k)+ghalf
3311                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3312                 aggj(l,k)=aggj(l,k)+ghalf
3313               enddo
3314             enddo
3315             if (j.eq.nres-1 .and. i.lt.j-2) then
3316               do k=1,4
3317                 do l=1,3
3318                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3319                 enddo
3320               enddo
3321             endif
3322           endif
3323           endif ! calc_grad
3324 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3325       return
3326       end
3327 C-----------------------------------------------------------------------------
3328       subroutine eturn3(i,eello_turn3)
3329 C Third- and fourth-order contributions from turns
3330       implicit real*8 (a-h,o-z)
3331       include 'DIMENSIONS'
3332       include 'COMMON.IOUNITS'
3333       include 'COMMON.GEO'
3334       include 'COMMON.VAR'
3335       include 'COMMON.LOCAL'
3336       include 'COMMON.CHAIN'
3337       include 'COMMON.DERIV'
3338       include 'COMMON.INTERACT'
3339       include 'COMMON.CORRMAT'
3340       include 'COMMON.TORSION'
3341       include 'COMMON.VECTORS'
3342       include 'COMMON.FFIELD'
3343       include 'COMMON.CONTROL'
3344       include 'COMMON.SHIELD'
3345       dimension ggg(3)
3346       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3347      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3348      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3349      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3350      &  auxgmat2(2,2),auxgmatt2(2,2)
3351       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3352      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3353       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3354      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3355      &    num_conti,j1,j2
3356       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3357       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3358       j=i+2
3359 c      write (iout,*) "eturn3",i,j,j1,j2
3360       a_temp(1,1)=a22
3361       a_temp(1,2)=a23
3362       a_temp(2,1)=a32
3363       a_temp(2,2)=a33
3364 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3365 C
3366 C               Third-order contributions
3367 C
3368 C                 (i+2)o----(i+3)
3369 C                      | |
3370 C                      | |
3371 C                 (i+1)o----i
3372 C
3373 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3374 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3375         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3376 c auxalary matices for theta gradient
3377 c auxalary matrix for i+1 and constant i+2
3378         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3379 c auxalary matrix for i+2 and constant i+1
3380         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3381         call transpose2(auxmat(1,1),auxmat1(1,1))
3382         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3383         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3384         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3385         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3386         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3387         if (shield_mode.eq.0) then
3388         fac_shield(i)=1.0
3389         fac_shield(j)=1.0
3390 C        else
3391 C        fac_shield(i)=0.4
3392 C        fac_shield(j)=0.6
3393         endif
3394         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3395      &  *fac_shield(i)*fac_shield(j)*faclipij
3396         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3397      &  *fac_shield(i)*fac_shield(j)
3398         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3399      &    eello_t3
3400         if (calc_grad) then
3401 C#ifdef NEWCORR
3402 C Derivatives in theta
3403         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3404      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3405      &   *fac_shield(i)*fac_shield(j)*faclipij
3406         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3407      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3408      &   *fac_shield(i)*fac_shield(j)*faclipij
3409 C#endif
3410
3411 C Derivatives in shield mode
3412           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3413      &  (shield_mode.gt.0)) then
3414 C          print *,i,j
3415
3416           do ilist=1,ishield_list(i)
3417            iresshield=shield_list(ilist,i)
3418            do k=1,3
3419            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3420 C     &      *2.0
3421            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3422      &              rlocshield
3423      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3424             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3425      &      +rlocshield
3426            enddo
3427           enddo
3428           do ilist=1,ishield_list(j)
3429            iresshield=shield_list(ilist,j)
3430            do k=1,3
3431            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3432 C     &     *2.0
3433            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3434      &              rlocshield
3435      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3436            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3437      &             +rlocshield
3438
3439            enddo
3440           enddo
3441
3442           do k=1,3
3443             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3444      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3445             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3446      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3447             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3448      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3449             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3450      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3451            enddo
3452            endif
3453
3454 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3455 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3456 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3457 cd     &    ' eello_turn3_num',4*eello_turn3_num
3458 C Derivatives in gamma(i)
3459         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3460         call transpose2(auxmat2(1,1),auxmat3(1,1))
3461         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3462         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3463      &   *fac_shield(i)*fac_shield(j)*faclipij
3464 C Derivatives in gamma(i+1)
3465         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3466         call transpose2(auxmat2(1,1),auxmat3(1,1))
3467         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3468         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3469      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3470      &   *fac_shield(i)*fac_shield(j)*faclipij
3471 C Cartesian derivatives
3472         do l=1,3
3473 c            ghalf1=0.5d0*agg(l,1)
3474 c            ghalf2=0.5d0*agg(l,2)
3475 c            ghalf3=0.5d0*agg(l,3)
3476 c            ghalf4=0.5d0*agg(l,4)
3477           a_temp(1,1)=aggi(l,1)!+ghalf1
3478           a_temp(1,2)=aggi(l,2)!+ghalf2
3479           a_temp(2,1)=aggi(l,3)!+ghalf3
3480           a_temp(2,2)=aggi(l,4)!+ghalf4
3481           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3482           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3483      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3484      &   *fac_shield(i)*fac_shield(j)*faclipij
3485
3486           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3487           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3488           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3489           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3490           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3491           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3492      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3493      &   *fac_shield(i)*fac_shield(j)*faclipij
3494           a_temp(1,1)=aggj(l,1)!+ghalf1
3495           a_temp(1,2)=aggj(l,2)!+ghalf2
3496           a_temp(2,1)=aggj(l,3)!+ghalf3
3497           a_temp(2,2)=aggj(l,4)!+ghalf4
3498           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3499           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3500      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3501      &   *fac_shield(i)*fac_shield(j)*faclipij
3502           a_temp(1,1)=aggj1(l,1)
3503           a_temp(1,2)=aggj1(l,2)
3504           a_temp(2,1)=aggj1(l,3)
3505           a_temp(2,2)=aggj1(l,4)
3506           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3507           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3508      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3509      &   *fac_shield(i)*fac_shield(j)*faclipij
3510         enddo
3511
3512         endif ! calc_grad
3513
3514       return
3515       end
3516 C-------------------------------------------------------------------------------
3517       subroutine eturn4(i,eello_turn4)
3518 C Third- and fourth-order contributions from turns
3519       implicit real*8 (a-h,o-z)
3520       include 'DIMENSIONS'
3521       include 'COMMON.IOUNITS'
3522       include 'COMMON.GEO'
3523       include 'COMMON.VAR'
3524       include 'COMMON.LOCAL'
3525       include 'COMMON.CHAIN'
3526       include 'COMMON.DERIV'
3527       include 'COMMON.INTERACT'
3528       include 'COMMON.CORRMAT'
3529       include 'COMMON.TORSION'
3530       include 'COMMON.VECTORS'
3531       include 'COMMON.FFIELD'
3532       include 'COMMON.CONTROL'
3533       include 'COMMON.SHIELD'
3534       dimension ggg(3)
3535       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3536      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3537      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3538      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3539      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3540      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3541      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3542       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3543      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3544       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3545      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3546      &    num_conti,j1,j2
3547       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3548       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3549       j=i+3
3550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3551 C
3552 C               Fourth-order contributions
3553 C
3554 C                 (i+3)o----(i+4)
3555 C                     /  |
3556 C               (i+2)o   |
3557 C                     \  |
3558 C                 (i+1)o----i
3559 C
3560 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3561 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3562 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3563 c        write(iout,*)"WCHODZE W PROGRAM"
3564         a_temp(1,1)=a22
3565         a_temp(1,2)=a23
3566         a_temp(2,1)=a32
3567         a_temp(2,2)=a33
3568         iti1=itype2loc(itype(i+1))
3569         iti2=itype2loc(itype(i+2))
3570         iti3=itype2loc(itype(i+3))
3571 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3572         call transpose2(EUg(1,1,i+1),e1t(1,1))
3573         call transpose2(Eug(1,1,i+2),e2t(1,1))
3574         call transpose2(Eug(1,1,i+3),e3t(1,1))
3575 C Ematrix derivative in theta
3576         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3577         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3578         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3579         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3580 c       eta1 in derivative theta
3581         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3582         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3583 c       auxgvec is derivative of Ub2 so i+3 theta
3584         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3585 c       auxalary matrix of E i+1
3586         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3587 c        s1=0.0
3588 c        gs1=0.0
3589         s1=scalar2(b1(1,i+2),auxvec(1))
3590 c derivative of theta i+2 with constant i+3
3591         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3592 c derivative of theta i+2 with constant i+2
3593         gs32=scalar2(b1(1,i+2),auxgvec(1))
3594 c derivative of E matix in theta of i+1
3595         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3596
3597         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3598 c       ea31 in derivative theta
3599         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3601 c auxilary matrix auxgvec of Ub2 with constant E matirx
3602         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3603 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3604         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3605
3606 c        s2=0.0
3607 c        gs2=0.0
3608         s2=scalar2(b1(1,i+1),auxvec(1))
3609 c derivative of theta i+1 with constant i+3
3610         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3611 c derivative of theta i+2 with constant i+1
3612         gs21=scalar2(b1(1,i+1),auxgvec(1))
3613 c derivative of theta i+3 with constant i+1
3614         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3615 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3616 c     &  gtb1(1,i+1)
3617         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3618 c two derivatives over diffetent matrices
3619 c gtae3e2 is derivative over i+3
3620         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3621 c ae3gte2 is derivative over i+2
3622         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3623         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3624 c three possible derivative over theta E matices
3625 c i+1
3626         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3627 c i+2
3628         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3629 c i+3
3630         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3631         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3632
3633         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3634         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3635         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3636         if (shield_mode.eq.0) then
3637         fac_shield(i)=1.0
3638         fac_shield(j)=1.0
3639 C        else
3640 C        fac_shield(i)=0.6
3641 C        fac_shield(j)=0.4
3642         endif
3643         eello_turn4=eello_turn4-(s1+s2+s3)
3644      &  *fac_shield(i)*fac_shield(j)*faclipij
3645         eello_t4=-(s1+s2+s3)
3646      &  *fac_shield(i)*fac_shield(j)
3647 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3648         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3649      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3650 C Now derivative over shield:
3651           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3652      &  (shield_mode.gt.0)) then
3653 C          print *,i,j
3654
3655           do ilist=1,ishield_list(i)
3656            iresshield=shield_list(ilist,i)
3657            do k=1,3
3658            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3659 C     &      *2.0
3660            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3661      &              rlocshield
3662      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3663             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3664      &      +rlocshield
3665            enddo
3666           enddo
3667           do ilist=1,ishield_list(j)
3668            iresshield=shield_list(ilist,j)
3669            do k=1,3
3670            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3671 C     &     *2.0
3672            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3673      &              rlocshield
3674      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3675            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3676      &             +rlocshield
3677
3678            enddo
3679           enddo
3680
3681           do k=1,3
3682             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3683      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3684             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3685      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3686             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3687      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3688             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3689      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3690            enddo
3691            endif
3692 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3693 cd     &    ' eello_turn4_num',8*eello_turn4_num
3694 #ifdef NEWCORR
3695         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3696      &                  -(gs13+gsE13+gsEE1)*wturn4
3697      &  *fac_shield(i)*fac_shield(j)
3698         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3699      &                    -(gs23+gs21+gsEE2)*wturn4
3700      &  *fac_shield(i)*fac_shield(j)
3701
3702         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3703      &                    -(gs32+gsE31+gsEE3)*wturn4
3704      &  *fac_shield(i)*fac_shield(j)
3705
3706 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3707 c     &   gs2
3708 #endif
3709         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3710      &      'eturn4',i,j,-(s1+s2+s3)
3711 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3712 c     &    ' eello_turn4_num',8*eello_turn4_num
3713 C Derivatives in gamma(i)
3714         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3715         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3716         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3717         s1=scalar2(b1(1,i+2),auxvec(1))
3718         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3719         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3720         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3721      &  *fac_shield(i)*fac_shield(j)*faclipij
3722 C Derivatives in gamma(i+1)
3723         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3724         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3725         s2=scalar2(b1(1,i+1),auxvec(1))
3726         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3727         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3728         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3729         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3730      &  *fac_shield(i)*fac_shield(j)*faclipij
3731 C Derivatives in gamma(i+2)
3732         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3733         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3734         s1=scalar2(b1(1,i+2),auxvec(1))
3735         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3736         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3737         s2=scalar2(b1(1,i+1),auxvec(1))
3738         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3739         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3740         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3741         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3742      &  *fac_shield(i)*fac_shield(j)*faclipij
3743         if (calc_grad) then
3744 C Cartesian derivatives
3745 C Derivatives of this turn contributions in DC(i+2)
3746         if (j.lt.nres-1) then
3747           do l=1,3
3748             a_temp(1,1)=agg(l,1)
3749             a_temp(1,2)=agg(l,2)
3750             a_temp(2,1)=agg(l,3)
3751             a_temp(2,2)=agg(l,4)
3752             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754             s1=scalar2(b1(1,i+2),auxvec(1))
3755             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757             s2=scalar2(b1(1,i+1),auxvec(1))
3758             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761             ggg(l)=-(s1+s2+s3)
3762             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3763      &  *fac_shield(i)*fac_shield(j)*faclipij
3764           enddo
3765         endif
3766 C Remaining derivatives of this turn contribution
3767         do l=1,3
3768           a_temp(1,1)=aggi(l,1)
3769           a_temp(1,2)=aggi(l,2)
3770           a_temp(2,1)=aggi(l,3)
3771           a_temp(2,2)=aggi(l,4)
3772           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3773           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3774           s1=scalar2(b1(1,i+2),auxvec(1))
3775           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3776           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3777           s2=scalar2(b1(1,i+1),auxvec(1))
3778           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3779           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3780           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3781           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3782      &  *fac_shield(i)*fac_shield(j)*faclipij
3783           a_temp(1,1)=aggi1(l,1)
3784           a_temp(1,2)=aggi1(l,2)
3785           a_temp(2,1)=aggi1(l,3)
3786           a_temp(2,2)=aggi1(l,4)
3787           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3788           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3789           s1=scalar2(b1(1,i+2),auxvec(1))
3790           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3791           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3792           s2=scalar2(b1(1,i+1),auxvec(1))
3793           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3794           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3795           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3796           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3797      &  *fac_shield(i)*fac_shield(j)*faclipij
3798           a_temp(1,1)=aggj(l,1)
3799           a_temp(1,2)=aggj(l,2)
3800           a_temp(2,1)=aggj(l,3)
3801           a_temp(2,2)=aggj(l,4)
3802           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3803           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3804           s1=scalar2(b1(1,i+2),auxvec(1))
3805           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3806           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3807           s2=scalar2(b1(1,i+1),auxvec(1))
3808           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3809           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3810           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3811           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3812      &  *fac_shield(i)*fac_shield(j)*faclipij
3813           a_temp(1,1)=aggj1(l,1)
3814           a_temp(1,2)=aggj1(l,2)
3815           a_temp(2,1)=aggj1(l,3)
3816           a_temp(2,2)=aggj1(l,4)
3817           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3818           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3819           s1=scalar2(b1(1,i+2),auxvec(1))
3820           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3821           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3822           s2=scalar2(b1(1,i+1),auxvec(1))
3823           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3824           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3825           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3826 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3827           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3828      &  *fac_shield(i)*fac_shield(j)*faclipij
3829         enddo
3830
3831         endif ! calc_grad
3832
3833       return
3834       end
3835 C-----------------------------------------------------------------------------
3836       subroutine vecpr(u,v,w)
3837       implicit real*8(a-h,o-z)
3838       dimension u(3),v(3),w(3)
3839       w(1)=u(2)*v(3)-u(3)*v(2)
3840       w(2)=-u(1)*v(3)+u(3)*v(1)
3841       w(3)=u(1)*v(2)-u(2)*v(1)
3842       return
3843       end
3844 C-----------------------------------------------------------------------------
3845       subroutine unormderiv(u,ugrad,unorm,ungrad)
3846 C This subroutine computes the derivatives of a normalized vector u, given
3847 C the derivatives computed without normalization conditions, ugrad. Returns
3848 C ungrad.
3849       implicit none
3850       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3851       double precision vec(3)
3852       double precision scalar
3853       integer i,j
3854 c      write (2,*) 'ugrad',ugrad
3855 c      write (2,*) 'u',u
3856       do i=1,3
3857         vec(i)=scalar(ugrad(1,i),u(1))
3858       enddo
3859 c      write (2,*) 'vec',vec
3860       do i=1,3
3861         do j=1,3
3862           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3863         enddo
3864       enddo
3865 c      write (2,*) 'ungrad',ungrad
3866       return
3867       end
3868 C-----------------------------------------------------------------------------
3869       subroutine escp(evdw2,evdw2_14)
3870 C
3871 C This subroutine calculates the excluded-volume interaction energy between
3872 C peptide-group centers and side chains and its gradient in virtual-bond and
3873 C side-chain vectors.
3874 C
3875       implicit real*8 (a-h,o-z)
3876       include 'DIMENSIONS'
3877       include 'COMMON.GEO'
3878       include 'COMMON.VAR'
3879       include 'COMMON.LOCAL'
3880       include 'COMMON.CHAIN'
3881       include 'COMMON.DERIV'
3882       include 'COMMON.INTERACT'
3883       include 'COMMON.FFIELD'
3884       include 'COMMON.IOUNITS'
3885       dimension ggg(3)
3886       evdw2=0.0D0
3887       evdw2_14=0.0d0
3888 cd    print '(a)','Enter ESCP'
3889 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3890 c     &  ' scal14',scal14
3891       do i=iatscp_s,iatscp_e
3892         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3893         iteli=itel(i)
3894 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3895 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3896         if (iteli.eq.0) goto 1225
3897         xi=0.5D0*(c(1,i)+c(1,i+1))
3898         yi=0.5D0*(c(2,i)+c(2,i+1))
3899         zi=0.5D0*(c(3,i)+c(3,i+1))
3900 C Returning the ith atom to box
3901         call to_box(xi,yi,zi)
3902         do iint=1,nscp_gr(i)
3903
3904         do j=iscpstart(i,iint),iscpend(i,iint)
3905           itypj=iabs(itype(j))
3906           if (itypj.eq.ntyp1) cycle
3907 C Uncomment following three lines for SC-p interactions
3908 c         xj=c(1,nres+j)-xi
3909 c         yj=c(2,nres+j)-yi
3910 c         zj=c(3,nres+j)-zi
3911 C Uncomment following three lines for Ca-p interactions
3912           xj=c(1,j)
3913           yj=c(2,j)
3914           zj=c(3,j)
3915 C returning the jth atom to box
3916           call to_box(xj,yj,zj)
3917           xj=boxshift(xj-xi,boxxsize)
3918           yj=boxshift(yj-yi,boxysize)
3919           zj=boxshift(zj-zi,boxzsize)
3920           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3921 C sss is scaling function for smoothing the cutoff gradient otherwise
3922 C the gradient would not be continuouse
3923           sss=sscale(1.0d0/(dsqrt(rrij)))
3924           if (sss.le.0.0d0) cycle
3925           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3926           fac=rrij**expon2
3927           e1=fac*fac*aad(itypj,iteli)
3928           e2=fac*bad(itypj,iteli)
3929           if (iabs(j-i) .le. 2) then
3930             e1=scal14*e1
3931             e2=scal14*e2
3932             evdw2_14=evdw2_14+(e1+e2)*sss
3933           endif
3934           evdwij=e1+e2
3935 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3936 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3937 c     &       bad(itypj,iteli)
3938           evdw2=evdw2+evdwij*sss
3939           if (calc_grad) then
3940 C
3941 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3942 C
3943           fac=-(evdwij+e1)*rrij*sss
3944           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3945           ggg(1)=xj*fac
3946           ggg(2)=yj*fac
3947           ggg(3)=zj*fac
3948           if (j.lt.i) then
3949 cd          write (iout,*) 'j<i'
3950 C Uncomment following three lines for SC-p interactions
3951 c           do k=1,3
3952 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3953 c           enddo
3954           else
3955 cd          write (iout,*) 'j>i'
3956             do k=1,3
3957               ggg(k)=-ggg(k)
3958 C Uncomment following line for SC-p interactions
3959 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3960             enddo
3961           endif
3962           do k=1,3
3963             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3964           enddo
3965           kstart=min0(i+1,j)
3966           kend=max0(i-1,j-1)
3967 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3968 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3969           do k=kstart,kend
3970             do l=1,3
3971               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3972             enddo
3973           enddo
3974           endif ! calc_grad
3975         enddo
3976         enddo ! iint
3977  1225   continue
3978       enddo ! i
3979       do i=1,nct
3980         do j=1,3
3981           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3982           gradx_scp(j,i)=expon*gradx_scp(j,i)
3983         enddo
3984       enddo
3985 C******************************************************************************
3986 C
3987 C                              N O T E !!!
3988 C
3989 C To save time the factor EXPON has been extracted from ALL components
3990 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3991 C use!
3992 C
3993 C******************************************************************************
3994       return
3995       end
3996 C--------------------------------------------------------------------------
3997       subroutine edis(ehpb)
3998 C
3999 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4000 C
4001       implicit real*8 (a-h,o-z)
4002       include 'DIMENSIONS'
4003       include 'COMMON.SBRIDGE'
4004       include 'COMMON.CHAIN'
4005       include 'COMMON.DERIV'
4006       include 'COMMON.VAR'
4007       include 'COMMON.INTERACT'
4008       include 'COMMON.CONTROL'
4009       include 'COMMON.IOUNITS'
4010       dimension ggg(3),ggg_peak(3,1000)
4011       ehpb=0.0D0
4012       ggg=0.0d0
4013 c 8/21/18 AL: added explicit restraints on reference coords
4014 c      write (iout,*) "restr_on_coord",restr_on_coord
4015       if (restr_on_coord) then
4016
4017       do i=nnt,nct
4018         ecoor=0.0d0
4019         if (itype(i).eq.ntyp1) cycle
4020         do j=1,3
4021           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4022           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4023         enddo
4024         if (itype(i).ne.10) then
4025           do j=1,3
4026             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4027             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4028           enddo
4029         endif
4030         if (energy_dec) write (iout,*)
4031      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4032         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4033       enddo
4034
4035       endif
4036 C      write (iout,*) ,"link_end",link_end,constr_dist
4037 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4038 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4039 c     &  " constr_dist",constr_dist
4040       if (link_end.eq.0.and.link_end_peak.eq.0) return
4041       do i=link_start_peak,link_end_peak
4042         ehpb_peak=0.0d0
4043 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4044 c     &   ipeak(1,i),ipeak(2,i)
4045         do ip=ipeak(1,i),ipeak(2,i)
4046           ii=ihpb_peak(ip)
4047           jj=jhpb_peak(ip)
4048           dd=dist(ii,jj)
4049           iip=ip-ipeak(1,i)+1
4050 C iii and jjj point to the residues for which the distance is assigned.
4051 c          if (ii.gt.nres) then
4052 c            iii=ii-nres
4053 c            jjj=jj-nres
4054 c          else
4055 c            iii=ii
4056 c            jjj=jj
4057 c          endif
4058           if (ii.gt.nres) then
4059             iii=ii-nres
4060           else
4061             iii=ii
4062           endif
4063           if (jj.gt.nres) then
4064             jjj=jj-nres
4065           else
4066             jjj=jj
4067           endif
4068           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4069           aux=dexp(-scal_peak*aux)
4070           ehpb_peak=ehpb_peak+aux
4071           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4072      &      forcon_peak(ip))*aux/dd
4073           do j=1,3
4074             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4075           enddo
4076           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4077      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4078      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4079         enddo
4080 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4081         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4082         do ip=ipeak(1,i),ipeak(2,i)
4083           iip=ip-ipeak(1,i)+1
4084           do j=1,3
4085             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4086           enddo
4087           ii=ihpb_peak(ip)
4088           jj=jhpb_peak(ip)
4089 C iii and jjj point to the residues for which the distance is assigned.
4090 c          if (ii.gt.nres) then
4091 c            iii=ii-nres
4092 c            jjj=jj-nres
4093 c          else
4094 c            iii=ii
4095 c            jjj=jj
4096 c          endif
4097           if (ii.gt.nres) then
4098             iii=ii-nres
4099           else
4100             iii=ii
4101           endif
4102           if (jj.gt.nres) then
4103             jjj=jj-nres
4104           else
4105             jjj=jj
4106           endif
4107           if (iii.lt.ii) then
4108             do j=1,3
4109               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4110             enddo
4111           endif
4112           if (jjj.lt.jj) then
4113             do j=1,3
4114               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4115             enddo
4116           endif
4117           do k=1,3
4118             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4119             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4120           enddo
4121         enddo
4122       enddo
4123       do i=link_start,link_end
4124 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4125 C CA-CA distance used in regularization of structure.
4126         ii=ihpb(i)
4127         jj=jhpb(i)
4128 C iii and jjj point to the residues for which the distance is assigned.
4129 c        if (ii.gt.nres) then
4130 c          iii=ii-nres
4131 c          jjj=jj-nres
4132 c        else
4133 c          iii=ii
4134 c          jjj=jj
4135 c        endif
4136         if (ii.gt.nres) then
4137           iii=ii-nres
4138         else
4139           iii=ii
4140         endif
4141         if (jj.gt.nres) then
4142           jjj=jj-nres
4143         else
4144           jjj=jj
4145         endif
4146 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4147 c     &    dhpb(i),dhpb1(i),forcon(i)
4148 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4149 C    distance and angle dependent SS bond potential.
4150 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4151 C     & iabs(itype(jjj)).eq.1) then
4152 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4153 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4154         if (.not.dyn_ss .and. i.le.nss) then
4155 C 15/02/13 CC dynamic SSbond - additional check
4156           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4157      &        iabs(itype(jjj)).eq.1) then
4158            call ssbond_ene(iii,jjj,eij)
4159            ehpb=ehpb+2*eij
4160          endif
4161 cd          write (iout,*) "eij",eij
4162 cd   &   ' waga=',waga,' fac=',fac
4163 !        else if (ii.gt.nres .and. jj.gt.nres) then
4164         else
4165 C Calculate the distance between the two points and its difference from the
4166 C target distance.
4167           dd=dist(ii,jj)
4168           if (irestr_type(i).eq.11) then
4169             ehpb=ehpb+fordepth(i)!**4.0d0
4170      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4171             fac=fordepth(i)!**4.0d0
4172      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4173             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4174      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4175      &        ehpb,irestr_type(i)
4176           else if (irestr_type(i).eq.10) then
4177 c AL 6//19/2018 cross-link restraints
4178             xdis = 0.5d0*(dd/forcon(i))**2
4179             expdis = dexp(-xdis)
4180 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4181             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4182 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4183 c     &          " wboltzd",wboltzd
4184             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4185 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4186             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4187      &           *expdis/(aux*forcon(i)**2)
4188             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4189      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4190      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4191           else if (irestr_type(i).eq.2) then
4192 c Quartic restraints
4193             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4194             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4195      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4196      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4197             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4198           else
4199 c Quadratic restraints
4200             rdis=dd-dhpb(i)
4201 C Get the force constant corresponding to this distance.
4202             waga=forcon(i)
4203 C Calculate the contribution to energy.
4204             ehpb=ehpb+0.5d0*waga*rdis*rdis
4205             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4206      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4207      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4208 C
4209 C Evaluate gradient.
4210 C
4211             fac=waga*rdis/dd
4212           endif
4213 c Calculate Cartesian gradient
4214           do j=1,3
4215             ggg(j)=fac*(c(j,jj)-c(j,ii))
4216           enddo
4217 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4218 C If this is a SC-SC distance, we need to calculate the contributions to the
4219 C Cartesian gradient in the SC vectors (ghpbx).
4220           if (iii.lt.ii) then
4221             do j=1,3
4222               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4223             enddo
4224           endif
4225           if (jjj.lt.jj) then
4226             do j=1,3
4227               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4228             enddo
4229           endif
4230           do k=1,3
4231             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4232             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4233           enddo
4234         endif
4235       enddo
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine ssbond_ene(i,j,eij)
4240 C
4241 C Calculate the distance and angle dependent SS-bond potential energy
4242 C using a free-energy function derived based on RHF/6-31G** ab initio
4243 C calculations of diethyl disulfide.
4244 C
4245 C A. Liwo and U. Kozlowska, 11/24/03
4246 C
4247       implicit real*8 (a-h,o-z)
4248       include 'DIMENSIONS'
4249       include 'COMMON.SBRIDGE'
4250       include 'COMMON.CHAIN'
4251       include 'COMMON.DERIV'
4252       include 'COMMON.LOCAL'
4253       include 'COMMON.INTERACT'
4254       include 'COMMON.VAR'
4255       include 'COMMON.IOUNITS'
4256       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4257       itypi=iabs(itype(i))
4258       xi=c(1,nres+i)
4259       yi=c(2,nres+i)
4260       zi=c(3,nres+i)
4261       dxi=dc_norm(1,nres+i)
4262       dyi=dc_norm(2,nres+i)
4263       dzi=dc_norm(3,nres+i)
4264       dsci_inv=dsc_inv(itypi)
4265       itypj=iabs(itype(j))
4266       dscj_inv=dsc_inv(itypj)
4267       xj=c(1,nres+j)-xi
4268       yj=c(2,nres+j)-yi
4269       zj=c(3,nres+j)-zi
4270       dxj=dc_norm(1,nres+j)
4271       dyj=dc_norm(2,nres+j)
4272       dzj=dc_norm(3,nres+j)
4273       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4274       rij=dsqrt(rrij)
4275       erij(1)=xj*rij
4276       erij(2)=yj*rij
4277       erij(3)=zj*rij
4278       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4279       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4280       om12=dxi*dxj+dyi*dyj+dzi*dzj
4281       do k=1,3
4282         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4283         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4284       enddo
4285       rij=1.0d0/rij
4286       deltad=rij-d0cm
4287       deltat1=1.0d0-om1
4288       deltat2=1.0d0+om2
4289       deltat12=om2-om1+2.0d0
4290       cosphi=om12-om1*om2
4291       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4292      &  +akct*deltad*deltat12
4293      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4294 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4295 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4296 c     &  " deltat12",deltat12," eij",eij
4297       ed=2*akcm*deltad+akct*deltat12
4298       pom1=akct*deltad
4299       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4300       eom1=-2*akth*deltat1-pom1-om2*pom2
4301       eom2= 2*akth*deltat2+pom1-om1*pom2
4302       eom12=pom2
4303       do k=1,3
4304         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4305       enddo
4306       do k=1,3
4307         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4308      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4309         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4310      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4311       enddo
4312 C
4313 C Calculate the components of the gradient in DC and X
4314 C
4315       do k=i,j-1
4316         do l=1,3
4317           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4318         enddo
4319       enddo
4320       return
4321       end
4322 C--------------------------------------------------------------------------
4323       subroutine ebond(estr)
4324 c
4325 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4326 c
4327       implicit real*8 (a-h,o-z)
4328       include 'DIMENSIONS'
4329       include 'COMMON.LOCAL'
4330       include 'COMMON.GEO'
4331       include 'COMMON.INTERACT'
4332       include 'COMMON.DERIV'
4333       include 'COMMON.VAR'
4334       include 'COMMON.CHAIN'
4335       include 'COMMON.IOUNITS'
4336       include 'COMMON.NAMES'
4337       include 'COMMON.FFIELD'
4338       include 'COMMON.CONTROL'
4339       double precision u(3),ud(3)
4340       estr=0.0d0
4341       estr1=0.0d0
4342 c      write (iout,*) "distchainmax",distchainmax
4343       do i=nnt+1,nct
4344 #ifdef FIVEDIAG
4345         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4346         diff = vbld(i)-vbldp0
4347 #else
4348         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4349 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4350 C          do j=1,3
4351 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4352 C     &      *dc(j,i-1)/vbld(i)
4353 C          enddo
4354 C          if (energy_dec) write(iout,*)
4355 C     &       "estr1",i,vbld(i),distchainmax,
4356 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4357 C        else
4358          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4359         diff = vbld(i)-vbldpDUM
4360 C         write(iout,*) i,diff
4361          else
4362           diff = vbld(i)-vbldp0
4363 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4364          endif
4365 #endif
4366         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4367      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4368           estr=estr+diff*diff
4369           do j=1,3
4370             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4371           enddo
4372 C        endif
4373 C        write (iout,'(a7,i5,4f7.3)')
4374 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4375       enddo
4376       estr=0.5d0*AKP*estr+estr1
4377 c
4378 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4379 c
4380       do i=nnt,nct
4381         iti=iabs(itype(i))
4382         if (iti.ne.10 .and. iti.ne.ntyp1) then
4383           nbi=nbondterm(iti)
4384           if (nbi.eq.1) then
4385             diff=vbld(i+nres)-vbldsc0(1,iti)
4386             if (energy_dec) write (iout,*)
4387      &      i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4388      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4389             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4390             do j=1,3
4391               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4392             enddo
4393           else
4394             do j=1,nbi
4395               diff=vbld(i+nres)-vbldsc0(j,iti)
4396               ud(j)=aksc(j,iti)*diff
4397               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4398             enddo
4399             uprod=u(1)
4400             do j=2,nbi
4401               uprod=uprod*u(j)
4402             enddo
4403             usum=0.0d0
4404             usumsqder=0.0d0
4405             do j=1,nbi
4406               uprod1=1.0d0
4407               uprod2=1.0d0
4408               do k=1,nbi
4409                 if (k.ne.j) then
4410                   uprod1=uprod1*u(k)
4411                   uprod2=uprod2*u(k)*u(k)
4412                 endif
4413               enddo
4414               usum=usum+uprod1
4415               usumsqder=usumsqder+ud(j)*uprod2
4416             enddo
4417 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4418 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4419             estr=estr+uprod/usum
4420             do j=1,3
4421              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4422             enddo
4423           endif
4424         endif
4425       enddo
4426       return
4427       end
4428 #ifdef CRYST_THETA
4429 C--------------------------------------------------------------------------
4430       subroutine ebend(etheta,ethetacnstr)
4431 C
4432 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4433 C angles gamma and its derivatives in consecutive thetas and gammas.
4434 C
4435       implicit real*8 (a-h,o-z)
4436       include 'DIMENSIONS'
4437       include 'COMMON.LOCAL'
4438       include 'COMMON.GEO'
4439       include 'COMMON.INTERACT'
4440       include 'COMMON.DERIV'
4441       include 'COMMON.VAR'
4442       include 'COMMON.CHAIN'
4443       include 'COMMON.IOUNITS'
4444       include 'COMMON.NAMES'
4445       include 'COMMON.FFIELD'
4446       include 'COMMON.TORCNSTR'
4447       common /calcthet/ term1,term2,termm,diffak,ratak,
4448      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4449      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4450       double precision y(2),z(2)
4451       delta=0.02d0*pi
4452 c      time11=dexp(-2*time)
4453 c      time12=1.0d0
4454       etheta=0.0D0
4455 c      write (iout,*) "nres",nres
4456 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4457 c      write (iout,*) ithet_start,ithet_end
4458       do i=ithet_start,ithet_end
4459 C        if (itype(i-1).eq.ntyp1) cycle
4460         if (i.le.2) cycle
4461         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4462      &  .or.itype(i).eq.ntyp1) cycle
4463 C Zero the energy function and its derivative at 0 or pi.
4464         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4465         it=itype(i-1)
4466         ichir1=isign(1,itype(i-2))
4467         ichir2=isign(1,itype(i))
4468          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4469          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4470          if (itype(i-1).eq.10) then
4471           itype1=isign(10,itype(i-2))
4472           ichir11=isign(1,itype(i-2))
4473           ichir12=isign(1,itype(i-2))
4474           itype2=isign(10,itype(i))
4475           ichir21=isign(1,itype(i))
4476           ichir22=isign(1,itype(i))
4477          endif
4478          if (i.eq.3) then
4479           y(1)=0.0D0
4480           y(2)=0.0D0
4481           else
4482
4483         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4484 #ifdef OSF
4485           phii=phi(i)
4486 c          icrc=0
4487 c          call proc_proc(phii,icrc)
4488           if (icrc.eq.1) phii=150.0
4489 #else
4490           phii=phi(i)
4491 #endif
4492           y(1)=dcos(phii)
4493           y(2)=dsin(phii)
4494         else
4495           y(1)=0.0D0
4496           y(2)=0.0D0
4497         endif
4498         endif
4499         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4500 #ifdef OSF
4501           phii1=phi(i+1)
4502 c          icrc=0
4503 c          call proc_proc(phii1,icrc)
4504           if (icrc.eq.1) phii1=150.0
4505           phii1=pinorm(phii1)
4506           z(1)=cos(phii1)
4507 #else
4508           phii1=phi(i+1)
4509           z(1)=dcos(phii1)
4510 #endif
4511           z(2)=dsin(phii1)
4512         else
4513           z(1)=0.0D0
4514           z(2)=0.0D0
4515         endif
4516 C Calculate the "mean" value of theta from the part of the distribution
4517 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4518 C In following comments this theta will be referred to as t_c.
4519         thet_pred_mean=0.0d0
4520         do k=1,2
4521             athetk=athet(k,it,ichir1,ichir2)
4522             bthetk=bthet(k,it,ichir1,ichir2)
4523           if (it.eq.10) then
4524              athetk=athet(k,itype1,ichir11,ichir12)
4525              bthetk=bthet(k,itype2,ichir21,ichir22)
4526           endif
4527           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4528         enddo
4529 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4530         dthett=thet_pred_mean*ssd
4531         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4532 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4533 C Derivatives of the "mean" values in gamma1 and gamma2.
4534         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4535      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4536          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4537      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4538          if (it.eq.10) then
4539       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4540      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4541         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4542      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4543          endif
4544         if (theta(i).gt.pi-delta) then
4545           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4546      &         E_tc0)
4547           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4548           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4549           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4550      &        E_theta)
4551           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4552      &        E_tc)
4553         else if (theta(i).lt.delta) then
4554           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4555           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4556           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4557      &        E_theta)
4558           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4559           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4560      &        E_tc)
4561         else
4562           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4563      &        E_theta,E_tc)
4564         endif
4565         etheta=etheta+ethetai
4566 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4567 c     &      'ebend',i,ethetai,theta(i),itype(i)
4568 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4569 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4570         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4571         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4572         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4573 c 1215   continue
4574       enddo
4575       ethetacnstr=0.0d0
4576 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4577       do i=1,ntheta_constr
4578         itheta=itheta_constr(i)
4579         thetiii=theta(itheta)
4580         difi=pinorm(thetiii-theta_constr0(i))
4581         if (difi.gt.theta_drange(i)) then
4582           difi=difi-theta_drange(i)
4583           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4584           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4585      &    +for_thet_constr(i)*difi**3
4586         else if (difi.lt.-drange(i)) then
4587           difi=difi+drange(i)
4588           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4589           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4590      &    +for_thet_constr(i)*difi**3
4591         else
4592           difi=0.0
4593         endif
4594 C       if (energy_dec) then
4595 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4596 C     &    i,itheta,rad2deg*thetiii,
4597 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4598 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4599 C     &    gloc(itheta+nphi-2,icg)
4600 C        endif
4601       enddo
4602 C Ufff.... We've done all this!!!
4603       return
4604       end
4605 C---------------------------------------------------------------------------
4606       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4607      &     E_tc)
4608       implicit real*8 (a-h,o-z)
4609       include 'DIMENSIONS'
4610       include 'COMMON.LOCAL'
4611       include 'COMMON.IOUNITS'
4612       common /calcthet/ term1,term2,termm,diffak,ratak,
4613      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4614      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4615 C Calculate the contributions to both Gaussian lobes.
4616 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4617 C The "polynomial part" of the "standard deviation" of this part of
4618 C the distribution.
4619         sig=polthet(3,it)
4620         do j=2,0,-1
4621           sig=sig*thet_pred_mean+polthet(j,it)
4622         enddo
4623 C Derivative of the "interior part" of the "standard deviation of the"
4624 C gamma-dependent Gaussian lobe in t_c.
4625         sigtc=3*polthet(3,it)
4626         do j=2,1,-1
4627           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4628         enddo
4629         sigtc=sig*sigtc
4630 C Set the parameters of both Gaussian lobes of the distribution.
4631 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4632         fac=sig*sig+sigc0(it)
4633         sigcsq=fac+fac
4634         sigc=1.0D0/sigcsq
4635 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4636         sigsqtc=-4.0D0*sigcsq*sigtc
4637 c       print *,i,sig,sigtc,sigsqtc
4638 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4639         sigtc=-sigtc/(fac*fac)
4640 C Following variable is sigma(t_c)**(-2)
4641         sigcsq=sigcsq*sigcsq
4642         sig0i=sig0(it)
4643         sig0inv=1.0D0/sig0i**2
4644         delthec=thetai-thet_pred_mean
4645         delthe0=thetai-theta0i
4646         term1=-0.5D0*sigcsq*delthec*delthec
4647         term2=-0.5D0*sig0inv*delthe0*delthe0
4648 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4649 C NaNs in taking the logarithm. We extract the largest exponent which is added
4650 C to the energy (this being the log of the distribution) at the end of energy
4651 C term evaluation for this virtual-bond angle.
4652         if (term1.gt.term2) then
4653           termm=term1
4654           term2=dexp(term2-termm)
4655           term1=1.0d0
4656         else
4657           termm=term2
4658           term1=dexp(term1-termm)
4659           term2=1.0d0
4660         endif
4661 C The ratio between the gamma-independent and gamma-dependent lobes of
4662 C the distribution is a Gaussian function of thet_pred_mean too.
4663         diffak=gthet(2,it)-thet_pred_mean
4664         ratak=diffak/gthet(3,it)**2
4665         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4666 C Let's differentiate it in thet_pred_mean NOW.
4667         aktc=ak*ratak
4668 C Now put together the distribution terms to make complete distribution.
4669         termexp=term1+ak*term2
4670         termpre=sigc+ak*sig0i
4671 C Contribution of the bending energy from this theta is just the -log of
4672 C the sum of the contributions from the two lobes and the pre-exponential
4673 C factor. Simple enough, isn't it?
4674         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4675 C NOW the derivatives!!!
4676 C 6/6/97 Take into account the deformation.
4677         E_theta=(delthec*sigcsq*term1
4678      &       +ak*delthe0*sig0inv*term2)/termexp
4679         E_tc=((sigtc+aktc*sig0i)/termpre
4680      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4681      &       aktc*term2)/termexp)
4682       return
4683       end
4684 c-----------------------------------------------------------------------------
4685       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4686       implicit real*8 (a-h,o-z)
4687       include 'DIMENSIONS'
4688       include 'COMMON.LOCAL'
4689       include 'COMMON.IOUNITS'
4690       common /calcthet/ term1,term2,termm,diffak,ratak,
4691      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4692      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4693       delthec=thetai-thet_pred_mean
4694       delthe0=thetai-theta0i
4695 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4696       t3 = thetai-thet_pred_mean
4697       t6 = t3**2
4698       t9 = term1
4699       t12 = t3*sigcsq
4700       t14 = t12+t6*sigsqtc
4701       t16 = 1.0d0
4702       t21 = thetai-theta0i
4703       t23 = t21**2
4704       t26 = term2
4705       t27 = t21*t26
4706       t32 = termexp
4707       t40 = t32**2
4708       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4709      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4710      & *(-t12*t9-ak*sig0inv*t27)
4711       return
4712       end
4713 #else
4714 C--------------------------------------------------------------------------
4715       subroutine ebend(etheta)
4716 C
4717 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4718 C angles gamma and its derivatives in consecutive thetas and gammas.
4719 C ab initio-derived potentials from
4720 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4721 C
4722       implicit real*8 (a-h,o-z)
4723       include 'DIMENSIONS'
4724       include 'COMMON.LOCAL'
4725       include 'COMMON.GEO'
4726       include 'COMMON.INTERACT'
4727       include 'COMMON.DERIV'
4728       include 'COMMON.VAR'
4729       include 'COMMON.CHAIN'
4730       include 'COMMON.IOUNITS'
4731       include 'COMMON.NAMES'
4732       include 'COMMON.FFIELD'
4733       include 'COMMON.CONTROL'
4734       include 'COMMON.TORCNSTR'
4735       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4736      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4737      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4738      & sinph1ph2(maxdouble,maxdouble)
4739       logical lprn /.false./, lprn1 /.false./
4740       etheta=0.0D0
4741 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4742       do i=ithet_start,ithet_end
4743 C         if (i.eq.2) cycle
4744 C        if (itype(i-1).eq.ntyp1) cycle
4745         if (i.le.2) cycle
4746         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4747      &  .or.itype(i).eq.ntyp1) cycle
4748         if (iabs(itype(i+1)).eq.20) iblock=2
4749         if (iabs(itype(i+1)).ne.20) iblock=1
4750         dethetai=0.0d0
4751         dephii=0.0d0
4752         dephii1=0.0d0
4753         theti2=0.5d0*theta(i)
4754         ityp2=ithetyp((itype(i-1)))
4755         do k=1,nntheterm
4756           coskt(k)=dcos(k*theti2)
4757           sinkt(k)=dsin(k*theti2)
4758         enddo
4759 cu        if (i.eq.3) then
4760 cu          phii=0.0d0
4761 cu          ityp1=nthetyp+1
4762 cu          do k=1,nsingle
4763 cu            cosph1(k)=0.0d0
4764 cu            sinph1(k)=0.0d0
4765 cu          enddo
4766 cu        else
4767         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4768 #ifdef OSF
4769           phii=phi(i)
4770           if (phii.ne.phii) phii=150.0
4771 #else
4772           phii=phi(i)
4773 #endif
4774           ityp1=ithetyp((itype(i-2)))
4775           do k=1,nsingle
4776             cosph1(k)=dcos(k*phii)
4777             sinph1(k)=dsin(k*phii)
4778           enddo
4779         else
4780           phii=0.0d0
4781 c          ityp1=nthetyp+1
4782           do k=1,nsingle
4783             ityp1=ithetyp((itype(i-2)))
4784             cosph1(k)=0.0d0
4785             sinph1(k)=0.0d0
4786           enddo
4787         endif
4788         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4789 #ifdef OSF
4790           phii1=phi(i+1)
4791           if (phii1.ne.phii1) phii1=150.0
4792           phii1=pinorm(phii1)
4793 #else
4794           phii1=phi(i+1)
4795 #endif
4796           ityp3=ithetyp((itype(i)))
4797           do k=1,nsingle
4798             cosph2(k)=dcos(k*phii1)
4799             sinph2(k)=dsin(k*phii1)
4800           enddo
4801         else
4802           phii1=0.0d0
4803 c          ityp3=nthetyp+1
4804           ityp3=ithetyp((itype(i)))
4805           do k=1,nsingle
4806             cosph2(k)=0.0d0
4807             sinph2(k)=0.0d0
4808           enddo
4809         endif
4810 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4811 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4812 c        call flush(iout)
4813         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4814         do k=1,ndouble
4815           do l=1,k-1
4816             ccl=cosph1(l)*cosph2(k-l)
4817             ssl=sinph1(l)*sinph2(k-l)
4818             scl=sinph1(l)*cosph2(k-l)
4819             csl=cosph1(l)*sinph2(k-l)
4820             cosph1ph2(l,k)=ccl-ssl
4821             cosph1ph2(k,l)=ccl+ssl
4822             sinph1ph2(l,k)=scl+csl
4823             sinph1ph2(k,l)=scl-csl
4824           enddo
4825         enddo
4826         if (lprn) then
4827         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4828      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4829         write (iout,*) "coskt and sinkt"
4830         do k=1,nntheterm
4831           write (iout,*) k,coskt(k),sinkt(k)
4832         enddo
4833         endif
4834         do k=1,ntheterm
4835           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4836           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4837      &      *coskt(k)
4838           if (lprn)
4839      &    write (iout,*) "k",k,"
4840      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4841      &     " ethetai",ethetai
4842         enddo
4843         if (lprn) then
4844         write (iout,*) "cosph and sinph"
4845         do k=1,nsingle
4846           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4847         enddo
4848         write (iout,*) "cosph1ph2 and sinph2ph2"
4849         do k=2,ndouble
4850           do l=1,k-1
4851             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4852      &         sinph1ph2(l,k),sinph1ph2(k,l)
4853           enddo
4854         enddo
4855         write(iout,*) "ethetai",ethetai
4856         endif
4857         do m=1,ntheterm2
4858           do k=1,nsingle
4859             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4860      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4861      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4862      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4863             ethetai=ethetai+sinkt(m)*aux
4864             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4865             dephii=dephii+k*sinkt(m)*(
4866      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4867      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4868             dephii1=dephii1+k*sinkt(m)*(
4869      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4870      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4871             if (lprn)
4872      &      write (iout,*) "m",m," k",k," bbthet",
4873      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4874      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4875      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4876      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4877           enddo
4878         enddo
4879         if (lprn)
4880      &  write(iout,*) "ethetai",ethetai
4881         do m=1,ntheterm3
4882           do k=2,ndouble
4883             do l=1,k-1
4884               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4885      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4886      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4887      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4888               ethetai=ethetai+sinkt(m)*aux
4889               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4890               dephii=dephii+l*sinkt(m)*(
4891      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4892      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4893      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4894      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4895               dephii1=dephii1+(k-l)*sinkt(m)*(
4896      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4897      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4898      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4899      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4900               if (lprn) then
4901               write (iout,*) "m",m," k",k," l",l," ffthet",
4902      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4903      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4904      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4905      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4906      &            " ethetai",ethetai
4907               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4908      &            cosph1ph2(k,l)*sinkt(m),
4909      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4910               endif
4911             enddo
4912           enddo
4913         enddo
4914 10      continue
4915         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4916      &   i,theta(i)*rad2deg,phii*rad2deg,
4917      &   phii1*rad2deg,ethetai
4918         etheta=etheta+ethetai
4919         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4920         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4921 c        gloc(nphi+i-2,icg)=wang*dethetai
4922         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4923       enddo
4924       return
4925       end
4926 #endif
4927 #ifdef CRYST_SC
4928 c-----------------------------------------------------------------------------
4929       subroutine esc(escloc)
4930 C Calculate the local energy of a side chain and its derivatives in the
4931 C corresponding virtual-bond valence angles THETA and the spherical angles
4932 C ALPHA and OMEGA.
4933       implicit real*8 (a-h,o-z)
4934       include 'DIMENSIONS'
4935       include 'COMMON.GEO'
4936       include 'COMMON.LOCAL'
4937       include 'COMMON.VAR'
4938       include 'COMMON.INTERACT'
4939       include 'COMMON.DERIV'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.IOUNITS'
4942       include 'COMMON.NAMES'
4943       include 'COMMON.FFIELD'
4944       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4945      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4946       common /sccalc/ time11,time12,time112,theti,it,nlobit
4947       delta=0.02d0*pi
4948       escloc=0.0D0
4949 C      write (iout,*) 'ESC'
4950       do i=loc_start,loc_end
4951         it=itype(i)
4952         if (it.eq.ntyp1) cycle
4953         if (it.eq.10) goto 1
4954         nlobit=nlob(iabs(it))
4955 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4956 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4957         theti=theta(i+1)-pipol
4958         x(1)=dtan(theti)
4959         x(2)=alph(i)
4960         x(3)=omeg(i)
4961 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4962
4963         if (x(2).gt.pi-delta) then
4964           xtemp(1)=x(1)
4965           xtemp(2)=pi-delta
4966           xtemp(3)=x(3)
4967           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4968           xtemp(2)=pi
4969           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4970           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4971      &        escloci,dersc(2))
4972           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4973      &        ddersc0(1),dersc(1))
4974           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4975      &        ddersc0(3),dersc(3))
4976           xtemp(2)=pi-delta
4977           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4978           xtemp(2)=pi
4979           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4980           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4981      &            dersc0(2),esclocbi,dersc02)
4982           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4983      &            dersc12,dersc01)
4984           call splinthet(x(2),0.5d0*delta,ss,ssd)
4985           dersc0(1)=dersc01
4986           dersc0(2)=dersc02
4987           dersc0(3)=0.0d0
4988           do k=1,3
4989             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4990           enddo
4991           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4992           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4993      &             esclocbi,ss,ssd
4994           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4995 c         escloci=esclocbi
4996 c         write (iout,*) escloci
4997         else if (x(2).lt.delta) then
4998           xtemp(1)=x(1)
4999           xtemp(2)=delta
5000           xtemp(3)=x(3)
5001           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5002           xtemp(2)=0.0d0
5003           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5004           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5005      &        escloci,dersc(2))
5006           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5007      &        ddersc0(1),dersc(1))
5008           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5009      &        ddersc0(3),dersc(3))
5010           xtemp(2)=delta
5011           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5012           xtemp(2)=0.0d0
5013           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5014           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5015      &            dersc0(2),esclocbi,dersc02)
5016           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5017      &            dersc12,dersc01)
5018           dersc0(1)=dersc01
5019           dersc0(2)=dersc02
5020           dersc0(3)=0.0d0
5021           call splinthet(x(2),0.5d0*delta,ss,ssd)
5022           do k=1,3
5023             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5024           enddo
5025           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5026 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5027 c     &             esclocbi,ss,ssd
5028           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5029 C         write (iout,*) 'i=',i, escloci
5030         else
5031           call enesc(x,escloci,dersc,ddummy,.false.)
5032         endif
5033
5034         escloc=escloc+escloci
5035 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5036             write (iout,'(a6,i5,0pf7.3)')
5037      &     'escloc',i,escloci
5038
5039         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5040      &   wscloc*dersc(1)
5041         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5042         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5043     1   continue
5044       enddo
5045       return
5046       end
5047 C---------------------------------------------------------------------------
5048       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5049       implicit real*8 (a-h,o-z)
5050       include 'DIMENSIONS'
5051       include 'COMMON.GEO'
5052       include 'COMMON.LOCAL'
5053       include 'COMMON.IOUNITS'
5054       common /sccalc/ time11,time12,time112,theti,it,nlobit
5055       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5056       double precision contr(maxlob,-1:1)
5057       logical mixed
5058 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5059         escloc_i=0.0D0
5060         do j=1,3
5061           dersc(j)=0.0D0
5062           if (mixed) ddersc(j)=0.0d0
5063         enddo
5064         x3=x(3)
5065
5066 C Because of periodicity of the dependence of the SC energy in omega we have
5067 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5068 C To avoid underflows, first compute & store the exponents.
5069
5070         do iii=-1,1
5071
5072           x(3)=x3+iii*dwapi
5073
5074           do j=1,nlobit
5075             do k=1,3
5076               z(k)=x(k)-censc(k,j,it)
5077             enddo
5078             do k=1,3
5079               Axk=0.0D0
5080               do l=1,3
5081                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5082               enddo
5083               Ax(k,j,iii)=Axk
5084             enddo
5085             expfac=0.0D0
5086             do k=1,3
5087               expfac=expfac+Ax(k,j,iii)*z(k)
5088             enddo
5089             contr(j,iii)=expfac
5090           enddo ! j
5091
5092         enddo ! iii
5093
5094         x(3)=x3
5095 C As in the case of ebend, we want to avoid underflows in exponentiation and
5096 C subsequent NaNs and INFs in energy calculation.
5097 C Find the largest exponent
5098         emin=contr(1,-1)
5099         do iii=-1,1
5100           do j=1,nlobit
5101             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5102           enddo
5103         enddo
5104         emin=0.5D0*emin
5105 cd      print *,'it=',it,' emin=',emin
5106
5107 C Compute the contribution to SC energy and derivatives
5108         do iii=-1,1
5109
5110           do j=1,nlobit
5111             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5112 cd          print *,'j=',j,' expfac=',expfac
5113             escloc_i=escloc_i+expfac
5114             do k=1,3
5115               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5116             enddo
5117             if (mixed) then
5118               do k=1,3,2
5119                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5120      &            +gaussc(k,2,j,it))*expfac
5121               enddo
5122             endif
5123           enddo
5124
5125         enddo ! iii
5126
5127         dersc(1)=dersc(1)/cos(theti)**2
5128         ddersc(1)=ddersc(1)/cos(theti)**2
5129         ddersc(3)=ddersc(3)
5130
5131         escloci=-(dlog(escloc_i)-emin)
5132         do j=1,3
5133           dersc(j)=dersc(j)/escloc_i
5134         enddo
5135         if (mixed) then
5136           do j=1,3,2
5137             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5138           enddo
5139         endif
5140       return
5141       end
5142 C------------------------------------------------------------------------------
5143       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5144       implicit real*8 (a-h,o-z)
5145       include 'DIMENSIONS'
5146       include 'COMMON.GEO'
5147       include 'COMMON.LOCAL'
5148       include 'COMMON.IOUNITS'
5149       common /sccalc/ time11,time12,time112,theti,it,nlobit
5150       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5151       double precision contr(maxlob)
5152       logical mixed
5153
5154       escloc_i=0.0D0
5155
5156       do j=1,3
5157         dersc(j)=0.0D0
5158       enddo
5159
5160       do j=1,nlobit
5161         do k=1,2
5162           z(k)=x(k)-censc(k,j,it)
5163         enddo
5164         z(3)=dwapi
5165         do k=1,3
5166           Axk=0.0D0
5167           do l=1,3
5168             Axk=Axk+gaussc(l,k,j,it)*z(l)
5169           enddo
5170           Ax(k,j)=Axk
5171         enddo
5172         expfac=0.0D0
5173         do k=1,3
5174           expfac=expfac+Ax(k,j)*z(k)
5175         enddo
5176         contr(j)=expfac
5177       enddo ! j
5178
5179 C As in the case of ebend, we want to avoid underflows in exponentiation and
5180 C subsequent NaNs and INFs in energy calculation.
5181 C Find the largest exponent
5182       emin=contr(1)
5183       do j=1,nlobit
5184         if (emin.gt.contr(j)) emin=contr(j)
5185       enddo
5186       emin=0.5D0*emin
5187
5188 C Compute the contribution to SC energy and derivatives
5189
5190       dersc12=0.0d0
5191       do j=1,nlobit
5192         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5193         escloc_i=escloc_i+expfac
5194         do k=1,2
5195           dersc(k)=dersc(k)+Ax(k,j)*expfac
5196         enddo
5197         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5198      &            +gaussc(1,2,j,it))*expfac
5199         dersc(3)=0.0d0
5200       enddo
5201
5202       dersc(1)=dersc(1)/cos(theti)**2
5203       dersc12=dersc12/cos(theti)**2
5204       escloci=-(dlog(escloc_i)-emin)
5205       do j=1,2
5206         dersc(j)=dersc(j)/escloc_i
5207       enddo
5208       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5209       return
5210       end
5211 #else
5212 c----------------------------------------------------------------------------------
5213       subroutine esc(escloc)
5214 C Calculate the local energy of a side chain and its derivatives in the
5215 C corresponding virtual-bond valence angles THETA and the spherical angles
5216 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5217 C added by Urszula Kozlowska. 07/11/2007
5218 C
5219       implicit real*8 (a-h,o-z)
5220       include 'DIMENSIONS'
5221       include 'COMMON.GEO'
5222       include 'COMMON.LOCAL'
5223       include 'COMMON.VAR'
5224       include 'COMMON.SCROT'
5225       include 'COMMON.INTERACT'
5226       include 'COMMON.DERIV'
5227       include 'COMMON.CHAIN'
5228       include 'COMMON.IOUNITS'
5229       include 'COMMON.NAMES'
5230       include 'COMMON.FFIELD'
5231       include 'COMMON.CONTROL'
5232       include 'COMMON.VECTORS'
5233       double precision x_prime(3),y_prime(3),z_prime(3)
5234      &    , sumene,dsc_i,dp2_i,x(65),
5235      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5236      &    de_dxx,de_dyy,de_dzz,de_dt
5237       double precision s1_t,s1_6_t,s2_t,s2_6_t
5238       double precision
5239      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5240      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5241      & dt_dCi(3),dt_dCi1(3)
5242       common /sccalc/ time11,time12,time112,theti,it,nlobit
5243       delta=0.02d0*pi
5244       escloc=0.0D0
5245       do i=loc_start,loc_end
5246         if (itype(i).eq.ntyp1) cycle
5247         costtab(i+1) =dcos(theta(i+1))
5248         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5249         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5250         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5251         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5252         cosfac=dsqrt(cosfac2)
5253         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5254         sinfac=dsqrt(sinfac2)
5255         it=iabs(itype(i))
5256         if (it.eq.10) goto 1
5257 c
5258 C  Compute the axes of tghe local cartesian coordinates system; store in
5259 c   x_prime, y_prime and z_prime
5260 c
5261         do j=1,3
5262           x_prime(j) = 0.00
5263           y_prime(j) = 0.00
5264           z_prime(j) = 0.00
5265         enddo
5266 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5267 C     &   dc_norm(3,i+nres)
5268         do j = 1,3
5269           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5270           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5271         enddo
5272         do j = 1,3
5273           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5274         enddo
5275 c       write (2,*) "i",i
5276 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5277 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5278 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5279 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5280 c      & " xy",scalar(x_prime(1),y_prime(1)),
5281 c      & " xz",scalar(x_prime(1),z_prime(1)),
5282 c      & " yy",scalar(y_prime(1),y_prime(1)),
5283 c      & " yz",scalar(y_prime(1),z_prime(1)),
5284 c      & " zz",scalar(z_prime(1),z_prime(1))
5285 c
5286 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5287 C to local coordinate system. Store in xx, yy, zz.
5288 c
5289         xx=0.0d0
5290         yy=0.0d0
5291         zz=0.0d0
5292         do j = 1,3
5293           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5294           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5295           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5296         enddo
5297
5298         xxtab(i)=xx
5299         yytab(i)=yy
5300         zztab(i)=zz
5301 C
5302 C Compute the energy of the ith side cbain
5303 C
5304 c        write (2,*) "xx",xx," yy",yy," zz",zz
5305         it=iabs(itype(i))
5306         do j = 1,65
5307           x(j) = sc_parmin(j,it)
5308         enddo
5309 #ifdef CHECK_COORD
5310 Cc diagnostics - remove later
5311         xx1 = dcos(alph(2))
5312         yy1 = dsin(alph(2))*dcos(omeg(2))
5313         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5314         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5315      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5316      &    xx1,yy1,zz1
5317 C,"  --- ", xx_w,yy_w,zz_w
5318 c end diagnostics
5319 #endif
5320         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5321      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5322      &   + x(10)*yy*zz
5323         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5324      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5325      & + x(20)*yy*zz
5326         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5327      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5328      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5329      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5330      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5331      &  +x(40)*xx*yy*zz
5332         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5333      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5334      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5335      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5336      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5337      &  +x(60)*xx*yy*zz
5338         dsc_i   = 0.743d0+x(61)
5339         dp2_i   = 1.9d0+x(62)
5340         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5341      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5342         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5343      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5344         s1=(1+x(63))/(0.1d0 + dscp1)
5345         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5346         s2=(1+x(65))/(0.1d0 + dscp2)
5347         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5348         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5349      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5350 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5351 c     &   sumene4,
5352 c     &   dscp1,dscp2,sumene
5353 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5354         escloc = escloc + sumene
5355 c        write (2,*) "escloc",escloc
5356 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5357 c     &  zz,xx,yy
5358         if (.not. calc_grad) goto 1
5359 #ifdef DEBUG
5360 C
5361 C This section to check the numerical derivatives of the energy of ith side
5362 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5363 C #define DEBUG in the code to turn it on.
5364 C
5365         write (2,*) "sumene               =",sumene
5366         aincr=1.0d-7
5367         xxsave=xx
5368         xx=xx+aincr
5369         write (2,*) xx,yy,zz
5370         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5371         de_dxx_num=(sumenep-sumene)/aincr
5372         xx=xxsave
5373         write (2,*) "xx+ sumene from enesc=",sumenep
5374         yysave=yy
5375         yy=yy+aincr
5376         write (2,*) xx,yy,zz
5377         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         de_dyy_num=(sumenep-sumene)/aincr
5379         yy=yysave
5380         write (2,*) "yy+ sumene from enesc=",sumenep
5381         zzsave=zz
5382         zz=zz+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dzz_num=(sumenep-sumene)/aincr
5386         zz=zzsave
5387         write (2,*) "zz+ sumene from enesc=",sumenep
5388         costsave=cost2tab(i+1)
5389         sintsave=sint2tab(i+1)
5390         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5391         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5392         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5393         de_dt_num=(sumenep-sumene)/aincr
5394         write (2,*) " t+ sumene from enesc=",sumenep
5395         cost2tab(i+1)=costsave
5396         sint2tab(i+1)=sintsave
5397 C End of diagnostics section.
5398 #endif
5399 C
5400 C Compute the gradient of esc
5401 C
5402         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5403         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5404         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5405         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5406         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5407         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5408         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5409         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5410         pom1=(sumene3*sint2tab(i+1)+sumene1)
5411      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5412         pom2=(sumene4*cost2tab(i+1)+sumene2)
5413      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5414         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5415         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5416      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5417      &  +x(40)*yy*zz
5418         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5419         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5420      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5421      &  +x(60)*yy*zz
5422         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5423      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5424      &        +(pom1+pom2)*pom_dx
5425 #ifdef DEBUG
5426         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5427 #endif
5428 C
5429         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5430         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5431      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5432      &  +x(40)*xx*zz
5433         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5434         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5435      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5436      &  +x(59)*zz**2 +x(60)*xx*zz
5437         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5438      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5439      &        +(pom1-pom2)*pom_dy
5440 #ifdef DEBUG
5441         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5442 #endif
5443 C
5444         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5445      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5446      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5447      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5448      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5449      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5450      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5451      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5452 #ifdef DEBUG
5453         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5454 #endif
5455 C
5456         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5457      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5458      &  +pom1*pom_dt1+pom2*pom_dt2
5459 #ifdef DEBUG
5460         write(2,*), "de_dt = ", de_dt,de_dt_num
5461 #endif
5462 c
5463 C
5464        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5465        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5466        cosfac2xx=cosfac2*xx
5467        sinfac2yy=sinfac2*yy
5468        do k = 1,3
5469          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5470      &      vbld_inv(i+1)
5471          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5472      &      vbld_inv(i)
5473          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5474          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5475 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5476 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5477 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5478 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5479          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5480          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5481          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5482          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5483          dZZ_Ci1(k)=0.0d0
5484          dZZ_Ci(k)=0.0d0
5485          do j=1,3
5486            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5487      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5488            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5489      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5490          enddo
5491
5492          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5493          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5494          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5495 c
5496          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5497          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5498        enddo
5499
5500        do k=1,3
5501          dXX_Ctab(k,i)=dXX_Ci(k)
5502          dXX_C1tab(k,i)=dXX_Ci1(k)
5503          dYY_Ctab(k,i)=dYY_Ci(k)
5504          dYY_C1tab(k,i)=dYY_Ci1(k)
5505          dZZ_Ctab(k,i)=dZZ_Ci(k)
5506          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5507          dXX_XYZtab(k,i)=dXX_XYZ(k)
5508          dYY_XYZtab(k,i)=dYY_XYZ(k)
5509          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5510        enddo
5511
5512        do k = 1,3
5513 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5514 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5515 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5516 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5517 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5518 c     &    dt_dci(k)
5519 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5520 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5521          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5522      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5523          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5524      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5525          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5526      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5527        enddo
5528 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5529 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5530
5531 C to check gradient call subroutine check_grad
5532
5533     1 continue
5534       enddo
5535       return
5536       end
5537 #endif
5538 c------------------------------------------------------------------------------
5539       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5540 C
5541 C This procedure calculates two-body contact function g(rij) and its derivative:
5542 C
5543 C           eps0ij                                     !       x < -1
5544 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5545 C            0                                         !       x > 1
5546 C
5547 C where x=(rij-r0ij)/delta
5548 C
5549 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5550 C
5551       implicit none
5552       double precision rij,r0ij,eps0ij,fcont,fprimcont
5553       double precision x,x2,x4,delta
5554 c     delta=0.02D0*r0ij
5555 c      delta=0.2D0*r0ij
5556       x=(rij-r0ij)/delta
5557       if (x.lt.-1.0D0) then
5558         fcont=eps0ij
5559         fprimcont=0.0D0
5560       else if (x.le.1.0D0) then
5561         x2=x*x
5562         x4=x2*x2
5563         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5564         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5565       else
5566         fcont=0.0D0
5567         fprimcont=0.0D0
5568       endif
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       subroutine splinthet(theti,delta,ss,ssder)
5573       implicit real*8 (a-h,o-z)
5574       include 'DIMENSIONS'
5575       include 'COMMON.VAR'
5576       include 'COMMON.GEO'
5577       thetup=pi-delta
5578       thetlow=delta
5579       if (theti.gt.pipol) then
5580         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5581       else
5582         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5583         ssder=-ssder
5584       endif
5585       return
5586       end
5587 c------------------------------------------------------------------------------
5588       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5589       implicit none
5590       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5591       double precision ksi,ksi2,ksi3,a1,a2,a3
5592       a1=fprim0*delta/(f1-f0)
5593       a2=3.0d0-2.0d0*a1
5594       a3=a1-2.0d0
5595       ksi=(x-x0)/delta
5596       ksi2=ksi*ksi
5597       ksi3=ksi2*ksi
5598       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5599       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5600       return
5601       end
5602 c------------------------------------------------------------------------------
5603       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5604       implicit none
5605       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5606       double precision ksi,ksi2,ksi3,a1,a2,a3
5607       ksi=(x-x0)/delta
5608       ksi2=ksi*ksi
5609       ksi3=ksi2*ksi
5610       a1=fprim0x*delta
5611       a2=3*(f1x-f0x)-2*fprim0x*delta
5612       a3=fprim0x*delta-2*(f1x-f0x)
5613       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5614       return
5615       end
5616 C-----------------------------------------------------------------------------
5617 #ifdef CRYST_TOR
5618 C-----------------------------------------------------------------------------
5619       subroutine etor(etors,fact)
5620       implicit real*8 (a-h,o-z)
5621       include 'DIMENSIONS'
5622       include 'COMMON.VAR'
5623       include 'COMMON.GEO'
5624       include 'COMMON.LOCAL'
5625       include 'COMMON.TORSION'
5626       include 'COMMON.INTERACT'
5627       include 'COMMON.DERIV'
5628       include 'COMMON.CHAIN'
5629       include 'COMMON.NAMES'
5630       include 'COMMON.IOUNITS'
5631       include 'COMMON.FFIELD'
5632       include 'COMMON.TORCNSTR'
5633       logical lprn
5634 C Set lprn=.true. for debugging
5635       lprn=.false.
5636 c      lprn=.true.
5637       etors=0.0D0
5638       do i=iphi_start,iphi_end
5639         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5640      &      .or. itype(i).eq.ntyp1) cycle
5641         itori=itortyp(itype(i-2))
5642         itori1=itortyp(itype(i-1))
5643         phii=phi(i)
5644         gloci=0.0D0
5645 C Proline-Proline pair is a special case...
5646         if (itori.eq.3 .and. itori1.eq.3) then
5647           if (phii.gt.-dwapi3) then
5648             cosphi=dcos(3*phii)
5649             fac=1.0D0/(1.0D0-cosphi)
5650             etorsi=v1(1,3,3)*fac
5651             etorsi=etorsi+etorsi
5652             etors=etors+etorsi-v1(1,3,3)
5653             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5654           endif
5655           do j=1,3
5656             v1ij=v1(j+1,itori,itori1)
5657             v2ij=v2(j+1,itori,itori1)
5658             cosphi=dcos(j*phii)
5659             sinphi=dsin(j*phii)
5660             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5661             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5662           enddo
5663         else
5664           do j=1,nterm_old
5665             v1ij=v1(j,itori,itori1)
5666             v2ij=v2(j,itori,itori1)
5667             cosphi=dcos(j*phii)
5668             sinphi=dsin(j*phii)
5669             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5670             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5671           enddo
5672         endif
5673         if (lprn)
5674      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5675      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5676      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5677         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5678 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5679       enddo
5680       return
5681       end
5682 c------------------------------------------------------------------------------
5683 #else
5684       subroutine etor(etors,fact)
5685       implicit real*8 (a-h,o-z)
5686       include 'DIMENSIONS'
5687       include 'COMMON.VAR'
5688       include 'COMMON.GEO'
5689       include 'COMMON.LOCAL'
5690       include 'COMMON.TORSION'
5691       include 'COMMON.INTERACT'
5692       include 'COMMON.DERIV'
5693       include 'COMMON.CHAIN'
5694       include 'COMMON.NAMES'
5695       include 'COMMON.IOUNITS'
5696       include 'COMMON.FFIELD'
5697       include 'COMMON.TORCNSTR'
5698       logical lprn
5699 C Set lprn=.true. for debugging
5700       lprn=.false.
5701 c      lprn=.true.
5702       etors=0.0D0
5703       do i=iphi_start,iphi_end
5704         if (i.le.2) cycle
5705         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5706      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5707 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5708 C     &       .or. itype(i).eq.ntyp1) cycle
5709         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5710          if (iabs(itype(i)).eq.20) then
5711          iblock=2
5712          else
5713          iblock=1
5714          endif
5715         itori=itortyp(itype(i-2))
5716         itori1=itortyp(itype(i-1))
5717         phii=phi(i)
5718         gloci=0.0D0
5719 C Regular cosine and sine terms
5720         do j=1,nterm(itori,itori1,iblock)
5721           v1ij=v1(j,itori,itori1,iblock)
5722           v2ij=v2(j,itori,itori1,iblock)
5723           cosphi=dcos(j*phii)
5724           sinphi=dsin(j*phii)
5725           etors=etors+v1ij*cosphi+v2ij*sinphi
5726           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5727         enddo
5728 C Lorentz terms
5729 C                         v1
5730 C  E = SUM ----------------------------------- - v1
5731 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5732 C
5733         cosphi=dcos(0.5d0*phii)
5734         sinphi=dsin(0.5d0*phii)
5735         do j=1,nlor(itori,itori1,iblock)
5736           vl1ij=vlor1(j,itori,itori1)
5737           vl2ij=vlor2(j,itori,itori1)
5738           vl3ij=vlor3(j,itori,itori1)
5739           pom=vl2ij*cosphi+vl3ij*sinphi
5740           pom1=1.0d0/(pom*pom+1.0d0)
5741           etors=etors+vl1ij*pom1
5742 c          if (energy_dec) etors_ii=etors_ii+
5743 c     &                vl1ij*pom1
5744           pom=-pom*pom1*pom1
5745           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5746         enddo
5747 C Subtract the constant term
5748         etors=etors-v0(itori,itori1,iblock)
5749         if (lprn)
5750      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5751      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5752      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5754 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5755  1215   continue
5756       enddo
5757       return
5758       end
5759 c----------------------------------------------------------------------------
5760       subroutine etor_d(etors_d,fact2)
5761 C 6/23/01 Compute double torsional energy
5762       implicit real*8 (a-h,o-z)
5763       include 'DIMENSIONS'
5764       include 'COMMON.VAR'
5765       include 'COMMON.GEO'
5766       include 'COMMON.LOCAL'
5767       include 'COMMON.TORSION'
5768       include 'COMMON.INTERACT'
5769       include 'COMMON.DERIV'
5770       include 'COMMON.CHAIN'
5771       include 'COMMON.NAMES'
5772       include 'COMMON.IOUNITS'
5773       include 'COMMON.FFIELD'
5774       include 'COMMON.TORCNSTR'
5775       logical lprn
5776 C Set lprn=.true. for debugging
5777       lprn=.false.
5778 c     lprn=.true.
5779       etors_d=0.0D0
5780       do i=iphi_start,iphi_end-1
5781         if (i.le.3) cycle
5782 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5783 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5784          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5785      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5786      &  (itype(i+1).eq.ntyp1)) cycle
5787         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5788      &     goto 1215
5789         itori=itortyp(itype(i-2))
5790         itori1=itortyp(itype(i-1))
5791         itori2=itortyp(itype(i))
5792         phii=phi(i)
5793         phii1=phi(i+1)
5794         gloci1=0.0D0
5795         gloci2=0.0D0
5796         iblock=1
5797         if (iabs(itype(i+1)).eq.20) iblock=2
5798 C Regular cosine and sine terms
5799         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5800           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5801           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5802           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5803           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5804           cosphi1=dcos(j*phii)
5805           sinphi1=dsin(j*phii)
5806           cosphi2=dcos(j*phii1)
5807           sinphi2=dsin(j*phii1)
5808           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5809      &     v2cij*cosphi2+v2sij*sinphi2
5810           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5811           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5812         enddo
5813         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5814           do l=1,k-1
5815             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5816             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5817             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5818             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5819             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5820             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5821             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5822             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5823             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5824      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5825             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5826      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5827             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5828      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5829           enddo
5830         enddo
5831         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5832         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5833  1215   continue
5834       enddo
5835       return
5836       end
5837 #endif
5838 c---------------------------------------------------------------------------
5839 C The rigorous attempt to derive energy function
5840       subroutine etor_kcc(etors,fact)
5841       implicit real*8 (a-h,o-z)
5842       include 'DIMENSIONS'
5843       include 'COMMON.VAR'
5844       include 'COMMON.GEO'
5845       include 'COMMON.LOCAL'
5846       include 'COMMON.TORSION'
5847       include 'COMMON.INTERACT'
5848       include 'COMMON.DERIV'
5849       include 'COMMON.CHAIN'
5850       include 'COMMON.NAMES'
5851       include 'COMMON.IOUNITS'
5852       include 'COMMON.FFIELD'
5853       include 'COMMON.TORCNSTR'
5854       include 'COMMON.CONTROL'
5855       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5856       logical lprn
5857 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5858 C Set lprn=.true. for debugging
5859       lprn=energy_dec
5860 c     lprn=.true.
5861 C      print *,"wchodze kcc"
5862       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5863       etors=0.0D0
5864       do i=iphi_start,iphi_end
5865 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5866 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5867 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5868 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5869         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5870      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5871         itori=itortyp(itype(i-2))
5872         itori1=itortyp(itype(i-1))
5873         phii=phi(i)
5874         glocig=0.0D0
5875         glocit1=0.0d0
5876         glocit2=0.0d0
5877 C to avoid multiple devision by 2
5878 c        theti22=0.5d0*theta(i)
5879 C theta 12 is the theta_1 /2
5880 C theta 22 is theta_2 /2
5881 c        theti12=0.5d0*theta(i-1)
5882 C and appropriate sinus function
5883         sinthet1=dsin(theta(i-1))
5884         sinthet2=dsin(theta(i))
5885         costhet1=dcos(theta(i-1))
5886         costhet2=dcos(theta(i))
5887 C to speed up lets store its mutliplication
5888         sint1t2=sinthet2*sinthet1
5889         sint1t2n=1.0d0
5890 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5891 C +d_n*sin(n*gamma)) *
5892 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5893 C we have two sum 1) Non-Chebyshev which is with n and gamma
5894         nval=nterm_kcc_Tb(itori,itori1)
5895         c1(0)=0.0d0
5896         c2(0)=0.0d0
5897         c1(1)=1.0d0
5898         c2(1)=1.0d0
5899         do j=2,nval
5900           c1(j)=c1(j-1)*costhet1
5901           c2(j)=c2(j-1)*costhet2
5902         enddo
5903         etori=0.0d0
5904         do j=1,nterm_kcc(itori,itori1)
5905           cosphi=dcos(j*phii)
5906           sinphi=dsin(j*phii)
5907           sint1t2n1=sint1t2n
5908           sint1t2n=sint1t2n*sint1t2
5909           sumvalc=0.0d0
5910           gradvalct1=0.0d0
5911           gradvalct2=0.0d0
5912           do k=1,nval
5913             do l=1,nval
5914               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5915               gradvalct1=gradvalct1+
5916      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5917               gradvalct2=gradvalct2+
5918      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5919             enddo
5920           enddo
5921           gradvalct1=-gradvalct1*sinthet1
5922           gradvalct2=-gradvalct2*sinthet2
5923           sumvals=0.0d0
5924           gradvalst1=0.0d0
5925           gradvalst2=0.0d0
5926           do k=1,nval
5927             do l=1,nval
5928               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5929               gradvalst1=gradvalst1+
5930      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5931               gradvalst2=gradvalst2+
5932      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5933             enddo
5934           enddo
5935           gradvalst1=-gradvalst1*sinthet1
5936           gradvalst2=-gradvalst2*sinthet2
5937           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5938 C glocig is the gradient local i site in gamma
5939           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5940 C now gradient over theta_1
5941           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5942      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5943           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5944      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5945         enddo ! j
5946         etors=etors+etori
5947 C derivative over gamma
5948         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5949 C derivative over theta1
5950         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5951 C now derivative over theta2
5952         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5953         if (lprn)
5954      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5955      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5956       enddo
5957       return
5958       end
5959 c---------------------------------------------------------------------------------------------
5960       subroutine etor_constr(edihcnstr)
5961       implicit real*8 (a-h,o-z)
5962       include 'DIMENSIONS'
5963       include 'COMMON.VAR'
5964       include 'COMMON.GEO'
5965       include 'COMMON.LOCAL'
5966       include 'COMMON.TORSION'
5967       include 'COMMON.INTERACT'
5968       include 'COMMON.DERIV'
5969       include 'COMMON.CHAIN'
5970       include 'COMMON.NAMES'
5971       include 'COMMON.IOUNITS'
5972       include 'COMMON.FFIELD'
5973       include 'COMMON.TORCNSTR'
5974       include 'COMMON.CONTROL'
5975 ! 6/20/98 - dihedral angle constraints
5976       edihcnstr=0.0d0
5977 c      do i=1,ndih_constr
5978 c      write (iout,*) "idihconstr_start",idihconstr_start,
5979 c     &  " idihconstr_end",idihconstr_end
5980       if (raw_psipred) then
5981         do i=idihconstr_start,idihconstr_end
5982           itori=idih_constr(i)
5983           phii=phi(itori)
5984           gaudih_i=vpsipred(1,i)
5985           gauder_i=0.0d0
5986           do j=1,2
5987             s = sdihed(j,i)
5988             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
5989             dexpcos_i=dexp(-cos_i*cos_i)
5990             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
5991             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
5992      &            *cos_i*dexpcos_i/s**2
5993           enddo
5994           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
5995           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
5996           if (energy_dec)
5997      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
5998      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
5999      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6000      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6001      &     -wdihc*dlog(gaudih_i)
6002         enddo
6003       else
6004         do i=idihconstr_start,idihconstr_end
6005           itori=idih_constr(i)
6006           phii=phi(itori)
6007           difi=pinorm(phii-phi0(i))
6008           if (difi.gt.drange(i)) then
6009             difi=difi-drange(i)
6010             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6011             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6012           else if (difi.lt.-drange(i)) then
6013             difi=difi+drange(i)
6014             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6015             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6016           else
6017             difi=0.0
6018           endif
6019         enddo
6020       endif
6021       return
6022       end
6023 c----------------------------------------------------------------------------
6024 C The rigorous attempt to derive energy function
6025       subroutine ebend_kcc(etheta)
6026
6027       implicit real*8 (a-h,o-z)
6028       include 'DIMENSIONS'
6029       include 'COMMON.VAR'
6030       include 'COMMON.GEO'
6031       include 'COMMON.LOCAL'
6032       include 'COMMON.TORSION'
6033       include 'COMMON.INTERACT'
6034       include 'COMMON.DERIV'
6035       include 'COMMON.CHAIN'
6036       include 'COMMON.NAMES'
6037       include 'COMMON.IOUNITS'
6038       include 'COMMON.FFIELD'
6039       include 'COMMON.TORCNSTR'
6040       include 'COMMON.CONTROL'
6041       logical lprn
6042       double precision thybt1(maxang_kcc)
6043 C Set lprn=.true. for debugging
6044       lprn=energy_dec
6045 c     lprn=.true.
6046 C      print *,"wchodze kcc"
6047       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6048       etheta=0.0D0
6049       do i=ithet_start,ithet_end
6050 c        print *,i,itype(i-1),itype(i),itype(i-2)
6051         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6052      &  .or.itype(i).eq.ntyp1) cycle
6053         iti=iabs(itortyp(itype(i-1)))
6054         sinthet=dsin(theta(i))
6055         costhet=dcos(theta(i))
6056         do j=1,nbend_kcc_Tb(iti)
6057           thybt1(j)=v1bend_chyb(j,iti)
6058         enddo
6059         sumth1thyb=v1bend_chyb(0,iti)+
6060      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6061         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6062      &    sumth1thyb
6063         ihelp=nbend_kcc_Tb(iti)-1
6064         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6065         etheta=etheta+sumth1thyb
6066 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6067         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6068       enddo
6069       return
6070       end
6071 c-------------------------------------------------------------------------------------
6072       subroutine etheta_constr(ethetacnstr)
6073
6074       implicit real*8 (a-h,o-z)
6075       include 'DIMENSIONS'
6076       include 'COMMON.VAR'
6077       include 'COMMON.GEO'
6078       include 'COMMON.LOCAL'
6079       include 'COMMON.TORSION'
6080       include 'COMMON.INTERACT'
6081       include 'COMMON.DERIV'
6082       include 'COMMON.CHAIN'
6083       include 'COMMON.NAMES'
6084       include 'COMMON.IOUNITS'
6085       include 'COMMON.FFIELD'
6086       include 'COMMON.TORCNSTR'
6087       include 'COMMON.CONTROL'
6088       ethetacnstr=0.0d0
6089 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6090       do i=ithetaconstr_start,ithetaconstr_end
6091         itheta=itheta_constr(i)
6092         thetiii=theta(itheta)
6093         difi=pinorm(thetiii-theta_constr0(i))
6094         if (difi.gt.theta_drange(i)) then
6095           difi=difi-theta_drange(i)
6096           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6097           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6098      &    +for_thet_constr(i)*difi**3
6099         else if (difi.lt.-drange(i)) then
6100           difi=difi+drange(i)
6101           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6102           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6103      &    +for_thet_constr(i)*difi**3
6104         else
6105           difi=0.0
6106         endif
6107        if (energy_dec) then
6108         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6109      &    i,itheta,rad2deg*thetiii,
6110      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6111      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6112      &    gloc(itheta+nphi-2,icg)
6113         endif
6114       enddo
6115       return
6116       end
6117 c------------------------------------------------------------------------------
6118 c------------------------------------------------------------------------------
6119       subroutine eback_sc_corr(esccor)
6120 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6121 c        conformational states; temporarily implemented as differences
6122 c        between UNRES torsional potentials (dependent on three types of
6123 c        residues) and the torsional potentials dependent on all 20 types
6124 c        of residues computed from AM1 energy surfaces of terminally-blocked
6125 c        amino-acid residues.
6126       implicit real*8 (a-h,o-z)
6127       include 'DIMENSIONS'
6128       include 'COMMON.VAR'
6129       include 'COMMON.GEO'
6130       include 'COMMON.LOCAL'
6131       include 'COMMON.TORSION'
6132       include 'COMMON.SCCOR'
6133       include 'COMMON.INTERACT'
6134       include 'COMMON.DERIV'
6135       include 'COMMON.CHAIN'
6136       include 'COMMON.NAMES'
6137       include 'COMMON.IOUNITS'
6138       include 'COMMON.FFIELD'
6139       include 'COMMON.CONTROL'
6140       logical lprn
6141 C Set lprn=.true. for debugging
6142       lprn=.false.
6143 c      lprn=.true.
6144 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6145       esccor=0.0D0
6146       do i=itau_start,itau_end
6147         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6148         esccor_ii=0.0D0
6149         isccori=isccortyp(itype(i-2))
6150         isccori1=isccortyp(itype(i-1))
6151         phii=phi(i)
6152         do intertyp=1,3 !intertyp
6153 cc Added 09 May 2012 (Adasko)
6154 cc  Intertyp means interaction type of backbone mainchain correlation:
6155 c   1 = SC...Ca...Ca...Ca
6156 c   2 = Ca...Ca...Ca...SC
6157 c   3 = SC...Ca...Ca...SCi
6158         gloci=0.0D0
6159         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6160      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6161      &      (itype(i-1).eq.ntyp1)))
6162      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6163      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6164      &     .or.(itype(i).eq.ntyp1)))
6165      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6166      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6167      &      (itype(i-3).eq.ntyp1)))) cycle
6168         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6169         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6170      & cycle
6171        do j=1,nterm_sccor(isccori,isccori1)
6172           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6173           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6174           cosphi=dcos(j*tauangle(intertyp,i))
6175           sinphi=dsin(j*tauangle(intertyp,i))
6176            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6177            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6178          enddo
6179 C      write (iout,*)"EBACK_SC_COR",esccor,i
6180 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6181 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6182 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6183         if (lprn)
6184      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6185      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6186      &  (v1sccor(j,1,itori,itori1),j=1,6)
6187      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6188 c        gsccor_loc(i-3)=gloci
6189        enddo !intertyp
6190       enddo
6191       return
6192       end
6193 #ifdef FOURBODY
6194 c------------------------------------------------------------------------------
6195       subroutine multibody(ecorr)
6196 C This subroutine calculates multi-body contributions to energy following
6197 C the idea of Skolnick et al. If side chains I and J make a contact and
6198 C at the same time side chains I+1 and J+1 make a contact, an extra
6199 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.IOUNITS'
6203       include 'COMMON.DERIV'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.CONTACTS'
6206       include 'COMMON.CONTMAT'
6207       include 'COMMON.CORRMAT'
6208       double precision gx(3),gx1(3)
6209       logical lprn
6210
6211 C Set lprn=.true. for debugging
6212       lprn=.false.
6213
6214       if (lprn) then
6215         write (iout,'(a)') 'Contact function values:'
6216         do i=nnt,nct-2
6217           write (iout,'(i2,20(1x,i2,f10.5))')
6218      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6219         enddo
6220       endif
6221       ecorr=0.0D0
6222       do i=nnt,nct
6223         do j=1,3
6224           gradcorr(j,i)=0.0D0
6225           gradxorr(j,i)=0.0D0
6226         enddo
6227       enddo
6228       do i=nnt,nct-2
6229
6230         DO ISHIFT = 3,4
6231
6232         i1=i+ishift
6233         num_conti=num_cont(i)
6234         num_conti1=num_cont(i1)
6235         do jj=1,num_conti
6236           j=jcont(jj,i)
6237           do kk=1,num_conti1
6238             j1=jcont(kk,i1)
6239             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6240 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6241 cd   &                   ' ishift=',ishift
6242 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6243 C The system gains extra energy.
6244               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6245             endif   ! j1==j+-ishift
6246           enddo     ! kk
6247         enddo       ! jj
6248
6249         ENDDO ! ISHIFT
6250
6251       enddo         ! i
6252       return
6253       end
6254 c------------------------------------------------------------------------------
6255       double precision function esccorr(i,j,k,l,jj,kk)
6256       implicit real*8 (a-h,o-z)
6257       include 'DIMENSIONS'
6258       include 'COMMON.IOUNITS'
6259       include 'COMMON.DERIV'
6260       include 'COMMON.INTERACT'
6261       include 'COMMON.CONTACTS'
6262       include 'COMMON.CONTMAT'
6263       include 'COMMON.CORRMAT'
6264       double precision gx(3),gx1(3)
6265       logical lprn
6266       lprn=.false.
6267       eij=facont(jj,i)
6268       ekl=facont(kk,k)
6269 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6270 C Calculate the multi-body contribution to energy.
6271 C Calculate multi-body contributions to the gradient.
6272 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6273 cd   & k,l,(gacont(m,kk,k),m=1,3)
6274       do m=1,3
6275         gx(m) =ekl*gacont(m,jj,i)
6276         gx1(m)=eij*gacont(m,kk,k)
6277         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6278         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6279         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6280         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6281       enddo
6282       do m=i,j-1
6283         do ll=1,3
6284           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6285         enddo
6286       enddo
6287       do m=k,l-1
6288         do ll=1,3
6289           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6290         enddo
6291       enddo
6292       esccorr=-eij*ekl
6293       return
6294       end
6295 c------------------------------------------------------------------------------
6296       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6297 C This subroutine calculates multi-body contributions to hydrogen-bonding
6298       implicit real*8 (a-h,o-z)
6299       include 'DIMENSIONS'
6300       include 'COMMON.IOUNITS'
6301       include 'COMMON.FFIELD'
6302       include 'COMMON.DERIV'
6303       include 'COMMON.INTERACT'
6304       include 'COMMON.CONTACTS'
6305       include 'COMMON.CONTMAT'
6306       include 'COMMON.CORRMAT'
6307       double precision gx(3),gx1(3)
6308       logical lprn,ldone
6309
6310 C Set lprn=.true. for debugging
6311       lprn=.false.
6312       if (lprn) then
6313         write (iout,'(a)') 'Contact function values:'
6314         do i=nnt,nct-2
6315           write (iout,'(2i3,50(1x,i2,f5.2))')
6316      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6317      &    j=1,num_cont_hb(i))
6318         enddo
6319       endif
6320       ecorr=0.0D0
6321 C Remove the loop below after debugging !!!
6322       do i=nnt,nct
6323         do j=1,3
6324           gradcorr(j,i)=0.0D0
6325           gradxorr(j,i)=0.0D0
6326         enddo
6327       enddo
6328 C Calculate the local-electrostatic correlation terms
6329       do i=iatel_s,iatel_e+1
6330         i1=i+1
6331         num_conti=num_cont_hb(i)
6332         num_conti1=num_cont_hb(i+1)
6333         do jj=1,num_conti
6334           j=jcont_hb(jj,i)
6335           do kk=1,num_conti1
6336             j1=jcont_hb(kk,i1)
6337 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6338 c     &         ' jj=',jj,' kk=',kk
6339             if (j1.eq.j+1 .or. j1.eq.j-1) then
6340 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6341 C The system gains extra energy.
6342               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6343               n_corr=n_corr+1
6344             else if (j1.eq.j) then
6345 C Contacts I-J and I-(J+1) occur simultaneously.
6346 C The system loses extra energy.
6347 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6348             endif
6349           enddo ! kk
6350           do kk=1,num_conti
6351             j1=jcont_hb(kk,i)
6352 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6353 c    &         ' jj=',jj,' kk=',kk
6354             if (j1.eq.j+1) then
6355 C Contacts I-J and (I+1)-J occur simultaneously.
6356 C The system loses extra energy.
6357 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6358             endif ! j1==j+1
6359           enddo ! kk
6360         enddo ! jj
6361       enddo ! i
6362       return
6363       end
6364 c------------------------------------------------------------------------------
6365       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6366      &  n_corr1)
6367 C This subroutine calculates multi-body contributions to hydrogen-bonding
6368       implicit real*8 (a-h,o-z)
6369       include 'DIMENSIONS'
6370       include 'COMMON.IOUNITS'
6371 #ifdef MPI
6372       include "mpif.h"
6373 #endif
6374       include 'COMMON.FFIELD'
6375       include 'COMMON.DERIV'
6376       include 'COMMON.LOCAL'
6377       include 'COMMON.INTERACT'
6378       include 'COMMON.CONTACTS'
6379       include 'COMMON.CONTMAT'
6380       include 'COMMON.CORRMAT'
6381       include 'COMMON.CHAIN'
6382       include 'COMMON.CONTROL'
6383       include 'COMMON.SHIELD'
6384       double precision gx(3),gx1(3)
6385       integer num_cont_hb_old(maxres)
6386       logical lprn,ldone
6387       double precision eello4,eello5,eelo6,eello_turn6
6388       external eello4,eello5,eello6,eello_turn6
6389 C Set lprn=.true. for debugging
6390       lprn=.false.
6391       eturn6=0.0d0
6392       if (lprn) then
6393         write (iout,'(a)') 'Contact function values:'
6394         do i=nnt,nct-2
6395           write (iout,'(2i3,50(1x,i2,5f6.3))')
6396      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6397      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6398         enddo
6399       endif
6400       ecorr=0.0D0
6401       ecorr5=0.0d0
6402       ecorr6=0.0d0
6403 C Remove the loop below after debugging !!!
6404       do i=nnt,nct
6405         do j=1,3
6406           gradcorr(j,i)=0.0D0
6407           gradxorr(j,i)=0.0D0
6408         enddo
6409       enddo
6410 C Calculate the dipole-dipole interaction energies
6411       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6412       do i=iatel_s,iatel_e+1
6413         num_conti=num_cont_hb(i)
6414         do jj=1,num_conti
6415           j=jcont_hb(jj,i)
6416 #ifdef MOMENT
6417           call dipole(i,j,jj)
6418 #endif
6419         enddo
6420       enddo
6421       endif
6422 C Calculate the local-electrostatic correlation terms
6423 c                write (iout,*) "gradcorr5 in eello5 before loop"
6424 c                do iii=1,nres
6425 c                  write (iout,'(i5,3f10.5)')
6426 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6427 c                enddo
6428       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6429 c        write (iout,*) "corr loop i",i
6430         i1=i+1
6431         num_conti=num_cont_hb(i)
6432         num_conti1=num_cont_hb(i+1)
6433         do jj=1,num_conti
6434           j=jcont_hb(jj,i)
6435           jp=iabs(j)
6436           do kk=1,num_conti1
6437             j1=jcont_hb(kk,i1)
6438             jp1=iabs(j1)
6439 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6440 c     &         ' jj=',jj,' kk=',kk
6441 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6442             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6443      &          .or. j.lt.0 .and. j1.gt.0) .and.
6444      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6445 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6446 C The system gains extra energy.
6447               n_corr=n_corr+1
6448               sqd1=dsqrt(d_cont(jj,i))
6449               sqd2=dsqrt(d_cont(kk,i1))
6450               sred_geom = sqd1*sqd2
6451               IF (sred_geom.lt.cutoff_corr) THEN
6452                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6453      &            ekont,fprimcont)
6454 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6455 cd     &         ' jj=',jj,' kk=',kk
6456                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6457                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6458                 do l=1,3
6459                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6460                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6461                 enddo
6462                 n_corr1=n_corr1+1
6463 cd               write (iout,*) 'sred_geom=',sred_geom,
6464 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6465 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6466 cd               write (iout,*) "g_contij",g_contij
6467 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6468 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6469                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6470                 if (wcorr4.gt.0.0d0)
6471      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6472 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6473                   if (energy_dec.and.wcorr4.gt.0.0d0)
6474      1                 write (iout,'(a6,4i5,0pf7.3)')
6475      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6476 c                write (iout,*) "gradcorr5 before eello5"
6477 c                do iii=1,nres
6478 c                  write (iout,'(i5,3f10.5)')
6479 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6480 c                enddo
6481                 if (wcorr5.gt.0.0d0)
6482      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6483 c                write (iout,*) "gradcorr5 after eello5"
6484 c                do iii=1,nres
6485 c                  write (iout,'(i5,3f10.5)')
6486 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6487 c                enddo
6488                   if (energy_dec.and.wcorr5.gt.0.0d0)
6489      1                 write (iout,'(a6,4i5,0pf7.3)')
6490      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6491 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6492 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6493                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6494      &               .or. wturn6.eq.0.0d0))then
6495 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6496                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6497                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6498      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6499 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6500 cd     &            'ecorr6=',ecorr6
6501 cd                write (iout,'(4e15.5)') sred_geom,
6502 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6503 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6504 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6505                 else if (wturn6.gt.0.0d0
6506      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6507 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6508                   eturn6=eturn6+eello_turn6(i,jj,kk)
6509                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6510      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6511 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6512                 endif
6513               ENDIF
6514 1111          continue
6515             endif
6516           enddo ! kk
6517         enddo ! jj
6518       enddo ! i
6519       do i=1,nres
6520         num_cont_hb(i)=num_cont_hb_old(i)
6521       enddo
6522 c                write (iout,*) "gradcorr5 in eello5"
6523 c                do iii=1,nres
6524 c                  write (iout,'(i5,3f10.5)')
6525 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6526 c                enddo
6527       return
6528       end
6529 c------------------------------------------------------------------------------
6530       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6531       implicit real*8 (a-h,o-z)
6532       include 'DIMENSIONS'
6533       include 'COMMON.IOUNITS'
6534       include 'COMMON.DERIV'
6535       include 'COMMON.INTERACT'
6536       include 'COMMON.CONTACTS'
6537       include 'COMMON.CONTMAT'
6538       include 'COMMON.CORRMAT'
6539       include 'COMMON.SHIELD'
6540       include 'COMMON.CONTROL'
6541       double precision gx(3),gx1(3)
6542       logical lprn
6543       lprn=.false.
6544 C      print *,"wchodze",fac_shield(i),shield_mode
6545       eij=facont_hb(jj,i)
6546       ekl=facont_hb(kk,k)
6547       ees0pij=ees0p(jj,i)
6548       ees0pkl=ees0p(kk,k)
6549       ees0mij=ees0m(jj,i)
6550       ees0mkl=ees0m(kk,k)
6551       ekont=eij*ekl
6552       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6553 C*
6554 C     & fac_shield(i)**2*fac_shield(j)**2
6555 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6556 C Following 4 lines for diagnostics.
6557 cd    ees0pkl=0.0D0
6558 cd    ees0pij=1.0D0
6559 cd    ees0mkl=0.0D0
6560 cd    ees0mij=1.0D0
6561 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6562 c     & 'Contacts ',i,j,
6563 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6564 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6565 c     & 'gradcorr_long'
6566 C Calculate the multi-body contribution to energy.
6567 C      ecorr=ecorr+ekont*ees
6568 C Calculate multi-body contributions to the gradient.
6569       coeffpees0pij=coeffp*ees0pij
6570       coeffmees0mij=coeffm*ees0mij
6571       coeffpees0pkl=coeffp*ees0pkl
6572       coeffmees0mkl=coeffm*ees0mkl
6573       do ll=1,3
6574 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6575         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6576      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6577      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6578         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6579      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6580      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6581 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6582         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6583      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6584      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6585         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6586      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6587      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6588         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6589      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6590      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6591         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6592         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6593         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6594      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6595      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6596         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6597         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6598 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6599       enddo
6600 c      write (iout,*)
6601 cgrad      do m=i+1,j-1
6602 cgrad        do ll=1,3
6603 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6604 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6605 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6606 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6607 cgrad        enddo
6608 cgrad      enddo
6609 cgrad      do m=k+1,l-1
6610 cgrad        do ll=1,3
6611 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6612 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6613 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6614 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6615 cgrad        enddo
6616 cgrad      enddo
6617 c      write (iout,*) "ehbcorr",ekont*ees
6618 C      print *,ekont,ees,i,k
6619       ehbcorr=ekont*ees
6620 C now gradient over shielding
6621 C      return
6622       if (shield_mode.gt.0) then
6623        j=ees0plist(jj,i)
6624        l=ees0plist(kk,k)
6625 C        print *,i,j,fac_shield(i),fac_shield(j),
6626 C     &fac_shield(k),fac_shield(l)
6627         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6628      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6629           do ilist=1,ishield_list(i)
6630            iresshield=shield_list(ilist,i)
6631            do m=1,3
6632            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6633 C     &      *2.0
6634            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6635      &              rlocshield
6636      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6637             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6638      &+rlocshield
6639            enddo
6640           enddo
6641           do ilist=1,ishield_list(j)
6642            iresshield=shield_list(ilist,j)
6643            do m=1,3
6644            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6645 C     &     *2.0
6646            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6647      &              rlocshield
6648      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6649            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6650      &     +rlocshield
6651            enddo
6652           enddo
6653
6654           do ilist=1,ishield_list(k)
6655            iresshield=shield_list(ilist,k)
6656            do m=1,3
6657            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6658 C     &     *2.0
6659            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6660      &              rlocshield
6661      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6662            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6663      &     +rlocshield
6664            enddo
6665           enddo
6666           do ilist=1,ishield_list(l)
6667            iresshield=shield_list(ilist,l)
6668            do m=1,3
6669            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6670 C     &     *2.0
6671            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6672      &              rlocshield
6673      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6674            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6675      &     +rlocshield
6676            enddo
6677           enddo
6678 C          print *,gshieldx(m,iresshield)
6679           do m=1,3
6680             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6681      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6682             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6683      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6684             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6685      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6686             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6687      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6688
6689             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6690      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6691             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6692      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6693             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6694      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6695             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6696      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6697
6698            enddo
6699       endif
6700       endif
6701       return
6702       end
6703 #ifdef MOMENT
6704 C---------------------------------------------------------------------------
6705       subroutine dipole(i,j,jj)
6706       implicit real*8 (a-h,o-z)
6707       include 'DIMENSIONS'
6708       include 'COMMON.IOUNITS'
6709       include 'COMMON.CHAIN'
6710       include 'COMMON.FFIELD'
6711       include 'COMMON.DERIV'
6712       include 'COMMON.INTERACT'
6713       include 'COMMON.CONTACTS'
6714       include 'COMMON.CONTMAT'
6715       include 'COMMON.CORRMAT'
6716       include 'COMMON.TORSION'
6717       include 'COMMON.VAR'
6718       include 'COMMON.GEO'
6719       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6720      &  auxmat(2,2)
6721       iti1 = itortyp(itype(i+1))
6722       if (j.lt.nres-1) then
6723         itj1 = itype2loc(itype(j+1))
6724       else
6725         itj1=nloctyp
6726       endif
6727       do iii=1,2
6728         dipi(iii,1)=Ub2(iii,i)
6729         dipderi(iii)=Ub2der(iii,i)
6730         dipi(iii,2)=b1(iii,i+1)
6731         dipj(iii,1)=Ub2(iii,j)
6732         dipderj(iii)=Ub2der(iii,j)
6733         dipj(iii,2)=b1(iii,j+1)
6734       enddo
6735       kkk=0
6736       do iii=1,2
6737         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6738         do jjj=1,2
6739           kkk=kkk+1
6740           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6741         enddo
6742       enddo
6743       do kkk=1,5
6744         do lll=1,3
6745           mmm=0
6746           do iii=1,2
6747             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6748      &        auxvec(1))
6749             do jjj=1,2
6750               mmm=mmm+1
6751               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6752             enddo
6753           enddo
6754         enddo
6755       enddo
6756       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6757       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6758       do iii=1,2
6759         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6760       enddo
6761       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6762       do iii=1,2
6763         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6764       enddo
6765       return
6766       end
6767 #endif
6768 C---------------------------------------------------------------------------
6769       subroutine calc_eello(i,j,k,l,jj,kk)
6770 C
6771 C This subroutine computes matrices and vectors needed to calculate
6772 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6773 C
6774       implicit real*8 (a-h,o-z)
6775       include 'DIMENSIONS'
6776       include 'COMMON.IOUNITS'
6777       include 'COMMON.CHAIN'
6778       include 'COMMON.DERIV'
6779       include 'COMMON.INTERACT'
6780       include 'COMMON.CONTACTS'
6781       include 'COMMON.CONTMAT'
6782       include 'COMMON.CORRMAT'
6783       include 'COMMON.TORSION'
6784       include 'COMMON.VAR'
6785       include 'COMMON.GEO'
6786       include 'COMMON.FFIELD'
6787       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6788      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6789       logical lprn
6790       common /kutas/ lprn
6791 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6792 cd     & ' jj=',jj,' kk=',kk
6793 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6794 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6795 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6796       do iii=1,2
6797         do jjj=1,2
6798           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6799           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6800         enddo
6801       enddo
6802       call transpose2(aa1(1,1),aa1t(1,1))
6803       call transpose2(aa2(1,1),aa2t(1,1))
6804       do kkk=1,5
6805         do lll=1,3
6806           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6807      &      aa1tder(1,1,lll,kkk))
6808           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6809      &      aa2tder(1,1,lll,kkk))
6810         enddo
6811       enddo
6812       if (l.eq.j+1) then
6813 C parallel orientation of the two CA-CA-CA frames.
6814         if (i.gt.1) then
6815           iti=itype2loc(itype(i))
6816         else
6817           iti=nloctyp
6818         endif
6819         itk1=itype2loc(itype(k+1))
6820         itj=itype2loc(itype(j))
6821         if (l.lt.nres-1) then
6822           itl1=itype2loc(itype(l+1))
6823         else
6824           itl1=nloctyp
6825         endif
6826 C A1 kernel(j+1) A2T
6827 cd        do iii=1,2
6828 cd          write (iout,'(3f10.5,5x,3f10.5)')
6829 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6830 cd        enddo
6831         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6832      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6833      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6834 C Following matrices are needed only for 6-th order cumulants
6835         IF (wcorr6.gt.0.0d0) THEN
6836         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6837      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6838      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6839         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6840      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6841      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6842      &   ADtEAderx(1,1,1,1,1,1))
6843         lprn=.false.
6844         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6845      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6846      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6847      &   ADtEA1derx(1,1,1,1,1,1))
6848         ENDIF
6849 C End 6-th order cumulants
6850 cd        lprn=.false.
6851 cd        if (lprn) then
6852 cd        write (2,*) 'In calc_eello6'
6853 cd        do iii=1,2
6854 cd          write (2,*) 'iii=',iii
6855 cd          do kkk=1,5
6856 cd            write (2,*) 'kkk=',kkk
6857 cd            do jjj=1,2
6858 cd              write (2,'(3(2f10.5),5x)')
6859 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6860 cd            enddo
6861 cd          enddo
6862 cd        enddo
6863 cd        endif
6864         call transpose2(EUgder(1,1,k),auxmat(1,1))
6865         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6866         call transpose2(EUg(1,1,k),auxmat(1,1))
6867         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6868         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6869         do iii=1,2
6870           do kkk=1,5
6871             do lll=1,3
6872               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6873      &          EAEAderx(1,1,lll,kkk,iii,1))
6874             enddo
6875           enddo
6876         enddo
6877 C A1T kernel(i+1) A2
6878         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6879      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6880      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6881 C Following matrices are needed only for 6-th order cumulants
6882         IF (wcorr6.gt.0.0d0) THEN
6883         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6884      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6885      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6886         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6887      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6888      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6889      &   ADtEAderx(1,1,1,1,1,2))
6890         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6891      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6892      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6893      &   ADtEA1derx(1,1,1,1,1,2))
6894         ENDIF
6895 C End 6-th order cumulants
6896         call transpose2(EUgder(1,1,l),auxmat(1,1))
6897         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6898         call transpose2(EUg(1,1,l),auxmat(1,1))
6899         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6900         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6901         do iii=1,2
6902           do kkk=1,5
6903             do lll=1,3
6904               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6905      &          EAEAderx(1,1,lll,kkk,iii,2))
6906             enddo
6907           enddo
6908         enddo
6909 C AEAb1 and AEAb2
6910 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6911 C They are needed only when the fifth- or the sixth-order cumulants are
6912 C indluded.
6913         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6914         call transpose2(AEA(1,1,1),auxmat(1,1))
6915         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6916         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6917         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6918         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6919         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6920         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6921         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6922         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6923         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6924         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6925         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6926         call transpose2(AEA(1,1,2),auxmat(1,1))
6927         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6928         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6929         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6930         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6931         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6932         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6933         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6934         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6935         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6936         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6937         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6938 C Calculate the Cartesian derivatives of the vectors.
6939         do iii=1,2
6940           do kkk=1,5
6941             do lll=1,3
6942               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6943               call matvec2(auxmat(1,1),b1(1,i),
6944      &          AEAb1derx(1,lll,kkk,iii,1,1))
6945               call matvec2(auxmat(1,1),Ub2(1,i),
6946      &          AEAb2derx(1,lll,kkk,iii,1,1))
6947               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6948      &          AEAb1derx(1,lll,kkk,iii,2,1))
6949               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6950      &          AEAb2derx(1,lll,kkk,iii,2,1))
6951               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6952               call matvec2(auxmat(1,1),b1(1,j),
6953      &          AEAb1derx(1,lll,kkk,iii,1,2))
6954               call matvec2(auxmat(1,1),Ub2(1,j),
6955      &          AEAb2derx(1,lll,kkk,iii,1,2))
6956               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6957      &          AEAb1derx(1,lll,kkk,iii,2,2))
6958               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6959      &          AEAb2derx(1,lll,kkk,iii,2,2))
6960             enddo
6961           enddo
6962         enddo
6963         ENDIF
6964 C End vectors
6965       else
6966 C Antiparallel orientation of the two CA-CA-CA frames.
6967         if (i.gt.1) then
6968           iti=itype2loc(itype(i))
6969         else
6970           iti=nloctyp
6971         endif
6972         itk1=itype2loc(itype(k+1))
6973         itl=itype2loc(itype(l))
6974         itj=itype2loc(itype(j))
6975         if (j.lt.nres-1) then
6976           itj1=itype2loc(itype(j+1))
6977         else
6978           itj1=nloctyp
6979         endif
6980 C A2 kernel(j-1)T A1T
6981         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6982      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6983      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6984 C Following matrices are needed only for 6-th order cumulants
6985         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6986      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6987         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6988      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6989      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6990         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6991      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6992      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6993      &   ADtEAderx(1,1,1,1,1,1))
6994         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6995      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6996      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6997      &   ADtEA1derx(1,1,1,1,1,1))
6998         ENDIF
6999 C End 6-th order cumulants
7000         call transpose2(EUgder(1,1,k),auxmat(1,1))
7001         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7002         call transpose2(EUg(1,1,k),auxmat(1,1))
7003         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7004         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7005         do iii=1,2
7006           do kkk=1,5
7007             do lll=1,3
7008               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7009      &          EAEAderx(1,1,lll,kkk,iii,1))
7010             enddo
7011           enddo
7012         enddo
7013 C A2T kernel(i+1)T A1
7014         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7015      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7016      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7017 C Following matrices are needed only for 6-th order cumulants
7018         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7019      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7020         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7021      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7022      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7023         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7024      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7025      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7026      &   ADtEAderx(1,1,1,1,1,2))
7027         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7028      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7029      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7030      &   ADtEA1derx(1,1,1,1,1,2))
7031         ENDIF
7032 C End 6-th order cumulants
7033         call transpose2(EUgder(1,1,j),auxmat(1,1))
7034         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7035         call transpose2(EUg(1,1,j),auxmat(1,1))
7036         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7037         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7038         do iii=1,2
7039           do kkk=1,5
7040             do lll=1,3
7041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7042      &          EAEAderx(1,1,lll,kkk,iii,2))
7043             enddo
7044           enddo
7045         enddo
7046 C AEAb1 and AEAb2
7047 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7048 C They are needed only when the fifth- or the sixth-order cumulants are
7049 C indluded.
7050         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7051      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7052         call transpose2(AEA(1,1,1),auxmat(1,1))
7053         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7054         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7055         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7056         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7057         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7058         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7059         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7060         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7061         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7062         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7063         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7064         call transpose2(AEA(1,1,2),auxmat(1,1))
7065         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7066         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7067         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7068         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7069         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7070         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7071         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7072         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7073         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7074         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7075         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7076 C Calculate the Cartesian derivatives of the vectors.
7077         do iii=1,2
7078           do kkk=1,5
7079             do lll=1,3
7080               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7081               call matvec2(auxmat(1,1),b1(1,i),
7082      &          AEAb1derx(1,lll,kkk,iii,1,1))
7083               call matvec2(auxmat(1,1),Ub2(1,i),
7084      &          AEAb2derx(1,lll,kkk,iii,1,1))
7085               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7086      &          AEAb1derx(1,lll,kkk,iii,2,1))
7087               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7088      &          AEAb2derx(1,lll,kkk,iii,2,1))
7089               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7090               call matvec2(auxmat(1,1),b1(1,l),
7091      &          AEAb1derx(1,lll,kkk,iii,1,2))
7092               call matvec2(auxmat(1,1),Ub2(1,l),
7093      &          AEAb2derx(1,lll,kkk,iii,1,2))
7094               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7095      &          AEAb1derx(1,lll,kkk,iii,2,2))
7096               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7097      &          AEAb2derx(1,lll,kkk,iii,2,2))
7098             enddo
7099           enddo
7100         enddo
7101         ENDIF
7102 C End vectors
7103       endif
7104       return
7105       end
7106 C---------------------------------------------------------------------------
7107       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7108      &  KK,KKderg,AKA,AKAderg,AKAderx)
7109       implicit none
7110       integer nderg
7111       logical transp
7112       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7113      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7114      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7115       integer iii,kkk,lll
7116       integer jjj,mmm
7117       logical lprn
7118       common /kutas/ lprn
7119       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7120       do iii=1,nderg
7121         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7122      &    AKAderg(1,1,iii))
7123       enddo
7124 cd      if (lprn) write (2,*) 'In kernel'
7125       do kkk=1,5
7126 cd        if (lprn) write (2,*) 'kkk=',kkk
7127         do lll=1,3
7128           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7129      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7130 cd          if (lprn) then
7131 cd            write (2,*) 'lll=',lll
7132 cd            write (2,*) 'iii=1'
7133 cd            do jjj=1,2
7134 cd              write (2,'(3(2f10.5),5x)')
7135 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7136 cd            enddo
7137 cd          endif
7138           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7139      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7140 cd          if (lprn) then
7141 cd            write (2,*) 'lll=',lll
7142 cd            write (2,*) 'iii=2'
7143 cd            do jjj=1,2
7144 cd              write (2,'(3(2f10.5),5x)')
7145 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7146 cd            enddo
7147 cd          endif
7148         enddo
7149       enddo
7150       return
7151       end
7152 C---------------------------------------------------------------------------
7153       double precision function eello4(i,j,k,l,jj,kk)
7154       implicit real*8 (a-h,o-z)
7155       include 'DIMENSIONS'
7156       include 'COMMON.IOUNITS'
7157       include 'COMMON.CHAIN'
7158       include 'COMMON.DERIV'
7159       include 'COMMON.INTERACT'
7160       include 'COMMON.CONTACTS'
7161       include 'COMMON.CONTMAT'
7162       include 'COMMON.CORRMAT'
7163       include 'COMMON.TORSION'
7164       include 'COMMON.VAR'
7165       include 'COMMON.GEO'
7166       double precision pizda(2,2),ggg1(3),ggg2(3)
7167 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7168 cd        eello4=0.0d0
7169 cd        return
7170 cd      endif
7171 cd      print *,'eello4:',i,j,k,l,jj,kk
7172 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7173 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7174 cold      eij=facont_hb(jj,i)
7175 cold      ekl=facont_hb(kk,k)
7176 cold      ekont=eij*ekl
7177       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7178       if (calc_grad) then
7179 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7180       gcorr_loc(k-1)=gcorr_loc(k-1)
7181      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7182       if (l.eq.j+1) then
7183         gcorr_loc(l-1)=gcorr_loc(l-1)
7184      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7185       else
7186         gcorr_loc(j-1)=gcorr_loc(j-1)
7187      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7188       endif
7189       do iii=1,2
7190         do kkk=1,5
7191           do lll=1,3
7192             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7193      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7194 cd            derx(lll,kkk,iii)=0.0d0
7195           enddo
7196         enddo
7197       enddo
7198 cd      gcorr_loc(l-1)=0.0d0
7199 cd      gcorr_loc(j-1)=0.0d0
7200 cd      gcorr_loc(k-1)=0.0d0
7201 cd      eel4=1.0d0
7202 cd      write (iout,*)'Contacts have occurred for peptide groups',
7203 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7204 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7205       if (j.lt.nres-1) then
7206         j1=j+1
7207         j2=j-1
7208       else
7209         j1=j-1
7210         j2=j-2
7211       endif
7212       if (l.lt.nres-1) then
7213         l1=l+1
7214         l2=l-1
7215       else
7216         l1=l-1
7217         l2=l-2
7218       endif
7219       do ll=1,3
7220 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7221 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7222         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7223         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7224 cgrad        ghalf=0.5d0*ggg1(ll)
7225         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7226         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7227         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7228         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7229         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7230         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7231 cgrad        ghalf=0.5d0*ggg2(ll)
7232         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7233         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7234         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7235         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7236         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7237         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7238       enddo
7239 cgrad      do m=i+1,j-1
7240 cgrad        do ll=1,3
7241 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7242 cgrad        enddo
7243 cgrad      enddo
7244 cgrad      do m=k+1,l-1
7245 cgrad        do ll=1,3
7246 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7247 cgrad        enddo
7248 cgrad      enddo
7249 cgrad      do m=i+2,j2
7250 cgrad        do ll=1,3
7251 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7252 cgrad        enddo
7253 cgrad      enddo
7254 cgrad      do m=k+2,l2
7255 cgrad        do ll=1,3
7256 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7257 cgrad        enddo
7258 cgrad      enddo
7259 cd      do iii=1,nres-3
7260 cd        write (2,*) iii,gcorr_loc(iii)
7261 cd      enddo
7262       endif ! calc_grad
7263       eello4=ekont*eel4
7264 cd      write (2,*) 'ekont',ekont
7265 cd      write (iout,*) 'eello4',ekont*eel4
7266       return
7267       end
7268 C---------------------------------------------------------------------------
7269       double precision function eello5(i,j,k,l,jj,kk)
7270       implicit real*8 (a-h,o-z)
7271       include 'DIMENSIONS'
7272       include 'COMMON.IOUNITS'
7273       include 'COMMON.CHAIN'
7274       include 'COMMON.DERIV'
7275       include 'COMMON.INTERACT'
7276       include 'COMMON.CONTACTS'
7277       include 'COMMON.CONTMAT'
7278       include 'COMMON.CORRMAT'
7279       include 'COMMON.TORSION'
7280       include 'COMMON.VAR'
7281       include 'COMMON.GEO'
7282       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7283       double precision ggg1(3),ggg2(3)
7284 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7285 C                                                                              C
7286 C                            Parallel chains                                   C
7287 C                                                                              C
7288 C          o             o                   o             o                   C
7289 C         /l\           / \             \   / \           / \   /              C
7290 C        /   \         /   \             \ /   \         /   \ /               C
7291 C       j| o |l1       | o |              o| o |         | o |o                C
7292 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7293 C      \i/   \         /   \ /             /   \         /   \                 C
7294 C       o    k1             o                                                  C
7295 C         (I)          (II)                (III)          (IV)                 C
7296 C                                                                              C
7297 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7298 C                                                                              C
7299 C                            Antiparallel chains                               C
7300 C                                                                              C
7301 C          o             o                   o             o                   C
7302 C         /j\           / \             \   / \           / \   /              C
7303 C        /   \         /   \             \ /   \         /   \ /               C
7304 C      j1| o |l        | o |              o| o |         | o |o                C
7305 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7306 C      \i/   \         /   \ /             /   \         /   \                 C
7307 C       o     k1            o                                                  C
7308 C         (I)          (II)                (III)          (IV)                 C
7309 C                                                                              C
7310 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7311 C                                                                              C
7312 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7313 C                                                                              C
7314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7315 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7316 cd        eello5=0.0d0
7317 cd        return
7318 cd      endif
7319 cd      write (iout,*)
7320 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7321 cd     &   ' and',k,l
7322       itk=itype2loc(itype(k))
7323       itl=itype2loc(itype(l))
7324       itj=itype2loc(itype(j))
7325       eello5_1=0.0d0
7326       eello5_2=0.0d0
7327       eello5_3=0.0d0
7328       eello5_4=0.0d0
7329 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7330 cd     &   eel5_3_num,eel5_4_num)
7331       do iii=1,2
7332         do kkk=1,5
7333           do lll=1,3
7334             derx(lll,kkk,iii)=0.0d0
7335           enddo
7336         enddo
7337       enddo
7338 cd      eij=facont_hb(jj,i)
7339 cd      ekl=facont_hb(kk,k)
7340 cd      ekont=eij*ekl
7341 cd      write (iout,*)'Contacts have occurred for peptide groups',
7342 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7343 cd      goto 1111
7344 C Contribution from the graph I.
7345 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7346 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7347       call transpose2(EUg(1,1,k),auxmat(1,1))
7348       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7349       vv(1)=pizda(1,1)-pizda(2,2)
7350       vv(2)=pizda(1,2)+pizda(2,1)
7351       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7352      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7353       if (calc_grad) then
7354 C Explicit gradient in virtual-dihedral angles.
7355       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7356      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7357      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7358       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7359       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7360       vv(1)=pizda(1,1)-pizda(2,2)
7361       vv(2)=pizda(1,2)+pizda(2,1)
7362       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7363      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7364      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7365       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7366       vv(1)=pizda(1,1)-pizda(2,2)
7367       vv(2)=pizda(1,2)+pizda(2,1)
7368       if (l.eq.j+1) then
7369         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7370      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7371      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7372       else
7373         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7374      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7375      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7376       endif
7377 C Cartesian gradient
7378       do iii=1,2
7379         do kkk=1,5
7380           do lll=1,3
7381             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7382      &        pizda(1,1))
7383             vv(1)=pizda(1,1)-pizda(2,2)
7384             vv(2)=pizda(1,2)+pizda(2,1)
7385             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7386      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7387      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7388           enddo
7389         enddo
7390       enddo
7391       endif ! calc_grad
7392 c      goto 1112
7393 c1111  continue
7394 C Contribution from graph II
7395       call transpose2(EE(1,1,k),auxmat(1,1))
7396       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7397       vv(1)=pizda(1,1)+pizda(2,2)
7398       vv(2)=pizda(2,1)-pizda(1,2)
7399       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7400      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7401       if (calc_grad) then
7402 C Explicit gradient in virtual-dihedral angles.
7403       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7404      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7405       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7406       vv(1)=pizda(1,1)+pizda(2,2)
7407       vv(2)=pizda(2,1)-pizda(1,2)
7408       if (l.eq.j+1) then
7409         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7410      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7411      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7412       else
7413         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7414      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7415      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7416       endif
7417 C Cartesian gradient
7418       do iii=1,2
7419         do kkk=1,5
7420           do lll=1,3
7421             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7422      &        pizda(1,1))
7423             vv(1)=pizda(1,1)+pizda(2,2)
7424             vv(2)=pizda(2,1)-pizda(1,2)
7425             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7426      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7427      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7428           enddo
7429         enddo
7430       enddo
7431       endif ! calc_grad
7432 cd      goto 1112
7433 cd1111  continue
7434       if (l.eq.j+1) then
7435 cd        goto 1110
7436 C Parallel orientation
7437 C Contribution from graph III
7438         call transpose2(EUg(1,1,l),auxmat(1,1))
7439         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7440         vv(1)=pizda(1,1)-pizda(2,2)
7441         vv(2)=pizda(1,2)+pizda(2,1)
7442         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7444         if (calc_grad) then
7445 C Explicit gradient in virtual-dihedral angles.
7446         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7447      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7448      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7449         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7450         vv(1)=pizda(1,1)-pizda(2,2)
7451         vv(2)=pizda(1,2)+pizda(2,1)
7452         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7453      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7454      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7455         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7456         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7457         vv(1)=pizda(1,1)-pizda(2,2)
7458         vv(2)=pizda(1,2)+pizda(2,1)
7459         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7460      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7461      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7462 C Cartesian gradient
7463         do iii=1,2
7464           do kkk=1,5
7465             do lll=1,3
7466               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7467      &          pizda(1,1))
7468               vv(1)=pizda(1,1)-pizda(2,2)
7469               vv(2)=pizda(1,2)+pizda(2,1)
7470               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7471      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7472      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7473             enddo
7474           enddo
7475         enddo
7476 cd        goto 1112
7477 C Contribution from graph IV
7478 cd1110    continue
7479         call transpose2(EE(1,1,l),auxmat(1,1))
7480         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7481         vv(1)=pizda(1,1)+pizda(2,2)
7482         vv(2)=pizda(2,1)-pizda(1,2)
7483         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7484      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7485 C Explicit gradient in virtual-dihedral angles.
7486         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7487      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7488         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7489         vv(1)=pizda(1,1)+pizda(2,2)
7490         vv(2)=pizda(2,1)-pizda(1,2)
7491         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7492      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7493      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7494 C Cartesian gradient
7495         do iii=1,2
7496           do kkk=1,5
7497             do lll=1,3
7498               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7499      &          pizda(1,1))
7500               vv(1)=pizda(1,1)+pizda(2,2)
7501               vv(2)=pizda(2,1)-pizda(1,2)
7502               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7503      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7504      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7505             enddo
7506           enddo
7507         enddo
7508         endif ! calc_grad
7509       else
7510 C Antiparallel orientation
7511 C Contribution from graph III
7512 c        goto 1110
7513         call transpose2(EUg(1,1,j),auxmat(1,1))
7514         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7515         vv(1)=pizda(1,1)-pizda(2,2)
7516         vv(2)=pizda(1,2)+pizda(2,1)
7517         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7518      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7519         if (calc_grad) then
7520 C Explicit gradient in virtual-dihedral angles.
7521         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7522      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7523      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7524         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7525         vv(1)=pizda(1,1)-pizda(2,2)
7526         vv(2)=pizda(1,2)+pizda(2,1)
7527         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7528      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7529      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7530         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7531         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7532         vv(1)=pizda(1,1)-pizda(2,2)
7533         vv(2)=pizda(1,2)+pizda(2,1)
7534         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7535      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7536      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7537 C Cartesian gradient
7538         do iii=1,2
7539           do kkk=1,5
7540             do lll=1,3
7541               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7542      &          pizda(1,1))
7543               vv(1)=pizda(1,1)-pizda(2,2)
7544               vv(2)=pizda(1,2)+pizda(2,1)
7545               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7546      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7547      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7548             enddo
7549           enddo
7550         enddo
7551         endif ! calc_grad
7552 cd        goto 1112
7553 C Contribution from graph IV
7554 1110    continue
7555         call transpose2(EE(1,1,j),auxmat(1,1))
7556         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7557         vv(1)=pizda(1,1)+pizda(2,2)
7558         vv(2)=pizda(2,1)-pizda(1,2)
7559         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7560      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7561         if (calc_grad) then
7562 C Explicit gradient in virtual-dihedral angles.
7563         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7564      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7565         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7566         vv(1)=pizda(1,1)+pizda(2,2)
7567         vv(2)=pizda(2,1)-pizda(1,2)
7568         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7569      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7570      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7571 C Cartesian gradient
7572         do iii=1,2
7573           do kkk=1,5
7574             do lll=1,3
7575               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7576      &          pizda(1,1))
7577               vv(1)=pizda(1,1)+pizda(2,2)
7578               vv(2)=pizda(2,1)-pizda(1,2)
7579               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7580      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7581      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7582             enddo
7583           enddo
7584         enddo
7585         endif ! calc_grad
7586       endif
7587 1112  continue
7588       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7589 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7590 cd        write (2,*) 'ijkl',i,j,k,l
7591 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7592 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7593 cd      endif
7594 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7595 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7596 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7597 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7598       if (calc_grad) then
7599       if (j.lt.nres-1) then
7600         j1=j+1
7601         j2=j-1
7602       else
7603         j1=j-1
7604         j2=j-2
7605       endif
7606       if (l.lt.nres-1) then
7607         l1=l+1
7608         l2=l-1
7609       else
7610         l1=l-1
7611         l2=l-2
7612       endif
7613 cd      eij=1.0d0
7614 cd      ekl=1.0d0
7615 cd      ekont=1.0d0
7616 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7617 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7618 C        summed up outside the subrouine as for the other subroutines
7619 C        handling long-range interactions. The old code is commented out
7620 C        with "cgrad" to keep track of changes.
7621       do ll=1,3
7622 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7623 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7624         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7625         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7626 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7627 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7628 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7629 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7630 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7631 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7632 c     &   gradcorr5ij,
7633 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7634 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7635 cgrad        ghalf=0.5d0*ggg1(ll)
7636 cd        ghalf=0.0d0
7637         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7638         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7639         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7640         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7641         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7642         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7643 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7644 cgrad        ghalf=0.5d0*ggg2(ll)
7645 cd        ghalf=0.0d0
7646         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7647         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7648         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7649         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7650         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7651         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7652       enddo
7653       endif ! calc_grad
7654 cd      goto 1112
7655 cgrad      do m=i+1,j-1
7656 cgrad        do ll=1,3
7657 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7658 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7659 cgrad        enddo
7660 cgrad      enddo
7661 cgrad      do m=k+1,l-1
7662 cgrad        do ll=1,3
7663 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7664 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7665 cgrad        enddo
7666 cgrad      enddo
7667 c1112  continue
7668 cgrad      do m=i+2,j2
7669 cgrad        do ll=1,3
7670 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7671 cgrad        enddo
7672 cgrad      enddo
7673 cgrad      do m=k+2,l2
7674 cgrad        do ll=1,3
7675 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7676 cgrad        enddo
7677 cgrad      enddo
7678 cd      do iii=1,nres-3
7679 cd        write (2,*) iii,g_corr5_loc(iii)
7680 cd      enddo
7681       eello5=ekont*eel5
7682 cd      write (2,*) 'ekont',ekont
7683 cd      write (iout,*) 'eello5',ekont*eel5
7684       return
7685       end
7686 c--------------------------------------------------------------------------
7687       double precision function eello6(i,j,k,l,jj,kk)
7688       implicit real*8 (a-h,o-z)
7689       include 'DIMENSIONS'
7690       include 'COMMON.IOUNITS'
7691       include 'COMMON.CHAIN'
7692       include 'COMMON.DERIV'
7693       include 'COMMON.INTERACT'
7694       include 'COMMON.CONTACTS'
7695       include 'COMMON.CONTMAT'
7696       include 'COMMON.CORRMAT'
7697       include 'COMMON.TORSION'
7698       include 'COMMON.VAR'
7699       include 'COMMON.GEO'
7700       include 'COMMON.FFIELD'
7701       double precision ggg1(3),ggg2(3)
7702 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7703 cd        eello6=0.0d0
7704 cd        return
7705 cd      endif
7706 cd      write (iout,*)
7707 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7708 cd     &   ' and',k,l
7709       eello6_1=0.0d0
7710       eello6_2=0.0d0
7711       eello6_3=0.0d0
7712       eello6_4=0.0d0
7713       eello6_5=0.0d0
7714       eello6_6=0.0d0
7715 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7716 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7717       do iii=1,2
7718         do kkk=1,5
7719           do lll=1,3
7720             derx(lll,kkk,iii)=0.0d0
7721           enddo
7722         enddo
7723       enddo
7724 cd      eij=facont_hb(jj,i)
7725 cd      ekl=facont_hb(kk,k)
7726 cd      ekont=eij*ekl
7727 cd      eij=1.0d0
7728 cd      ekl=1.0d0
7729 cd      ekont=1.0d0
7730       if (l.eq.j+1) then
7731         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7732         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7733         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7734         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7735         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7736         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7737       else
7738         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7739         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7740         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7741         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7742         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7743           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7744         else
7745           eello6_5=0.0d0
7746         endif
7747         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7748       endif
7749 C If turn contributions are considered, they will be handled separately.
7750       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7751 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7752 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7753 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7754 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7755 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7756 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7757 cd      goto 1112
7758       if (calc_grad) then
7759       if (j.lt.nres-1) then
7760         j1=j+1
7761         j2=j-1
7762       else
7763         j1=j-1
7764         j2=j-2
7765       endif
7766       if (l.lt.nres-1) then
7767         l1=l+1
7768         l2=l-1
7769       else
7770         l1=l-1
7771         l2=l-2
7772       endif
7773       do ll=1,3
7774 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7775 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7776 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7777 cgrad        ghalf=0.5d0*ggg1(ll)
7778 cd        ghalf=0.0d0
7779         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7780         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7781         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7782         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7783         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7784         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7785         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7786         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7787 cgrad        ghalf=0.5d0*ggg2(ll)
7788 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7789 cd        ghalf=0.0d0
7790         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7791         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7792         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7793         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7794         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7795         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7796       enddo
7797       endif ! calc_grad
7798 cd      goto 1112
7799 cgrad      do m=i+1,j-1
7800 cgrad        do ll=1,3
7801 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7802 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7803 cgrad        enddo
7804 cgrad      enddo
7805 cgrad      do m=k+1,l-1
7806 cgrad        do ll=1,3
7807 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7808 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7809 cgrad        enddo
7810 cgrad      enddo
7811 cgrad1112  continue
7812 cgrad      do m=i+2,j2
7813 cgrad        do ll=1,3
7814 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7815 cgrad        enddo
7816 cgrad      enddo
7817 cgrad      do m=k+2,l2
7818 cgrad        do ll=1,3
7819 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7820 cgrad        enddo
7821 cgrad      enddo
7822 cd      do iii=1,nres-3
7823 cd        write (2,*) iii,g_corr6_loc(iii)
7824 cd      enddo
7825       eello6=ekont*eel6
7826 cd      write (2,*) 'ekont',ekont
7827 cd      write (iout,*) 'eello6',ekont*eel6
7828       return
7829       end
7830 c--------------------------------------------------------------------------
7831       double precision function eello6_graph1(i,j,k,l,imat,swap)
7832       implicit real*8 (a-h,o-z)
7833       include 'DIMENSIONS'
7834       include 'COMMON.IOUNITS'
7835       include 'COMMON.CHAIN'
7836       include 'COMMON.DERIV'
7837       include 'COMMON.INTERACT'
7838       include 'COMMON.CONTACTS'
7839       include 'COMMON.CONTMAT'
7840       include 'COMMON.CORRMAT'
7841       include 'COMMON.TORSION'
7842       include 'COMMON.VAR'
7843       include 'COMMON.GEO'
7844       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7845       logical swap
7846       logical lprn
7847       common /kutas/ lprn
7848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7849 C                                                                              C
7850 C      Parallel       Antiparallel                                             C
7851 C                                                                              C
7852 C          o             o                                                     C
7853 C         /l\           /j\                                                    C
7854 C        /   \         /   \                                                   C
7855 C       /| o |         | o |\                                                  C
7856 C     \ j|/k\|  /   \  |/k\|l /                                                C
7857 C      \ /   \ /     \ /   \ /                                                 C
7858 C       o     o       o     o                                                  C
7859 C       i             i                                                        C
7860 C                                                                              C
7861 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7862       itk=itype2loc(itype(k))
7863       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7864       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7865       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7866       call transpose2(EUgC(1,1,k),auxmat(1,1))
7867       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7868       vv1(1)=pizda1(1,1)-pizda1(2,2)
7869       vv1(2)=pizda1(1,2)+pizda1(2,1)
7870       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7871       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7872       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7873       s5=scalar2(vv(1),Dtobr2(1,i))
7874 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7875       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7876       if (calc_grad) then
7877       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7878      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7879      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7880      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7881      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7882      & +scalar2(vv(1),Dtobr2der(1,i)))
7883       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7884       vv1(1)=pizda1(1,1)-pizda1(2,2)
7885       vv1(2)=pizda1(1,2)+pizda1(2,1)
7886       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7887       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7888       if (l.eq.j+1) then
7889         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7890      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7891      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7892      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7893      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7894       else
7895         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7896      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7897      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7898      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7899      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7900       endif
7901       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7902       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7903       vv1(1)=pizda1(1,1)-pizda1(2,2)
7904       vv1(2)=pizda1(1,2)+pizda1(2,1)
7905       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7906      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7907      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7908      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7909       do iii=1,2
7910         if (swap) then
7911           ind=3-iii
7912         else
7913           ind=iii
7914         endif
7915         do kkk=1,5
7916           do lll=1,3
7917             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7918             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7919             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7920             call transpose2(EUgC(1,1,k),auxmat(1,1))
7921             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7922      &        pizda1(1,1))
7923             vv1(1)=pizda1(1,1)-pizda1(2,2)
7924             vv1(2)=pizda1(1,2)+pizda1(2,1)
7925             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7926             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7927      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7928             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7929      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7930             s5=scalar2(vv(1),Dtobr2(1,i))
7931             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7932           enddo
7933         enddo
7934       enddo
7935       endif ! calc_grad
7936       return
7937       end
7938 c----------------------------------------------------------------------------
7939       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7940       implicit real*8 (a-h,o-z)
7941       include 'DIMENSIONS'
7942       include 'COMMON.IOUNITS'
7943       include 'COMMON.CHAIN'
7944       include 'COMMON.DERIV'
7945       include 'COMMON.INTERACT'
7946       include 'COMMON.CONTACTS'
7947       include 'COMMON.CONTMAT'
7948       include 'COMMON.CORRMAT'
7949       include 'COMMON.TORSION'
7950       include 'COMMON.VAR'
7951       include 'COMMON.GEO'
7952       logical swap
7953       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7954      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7955       logical lprn
7956       common /kutas/ lprn
7957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7958 C                                                                              C
7959 C      Parallel       Antiparallel                                             C
7960 C                                                                              C
7961 C          o             o                                                     C
7962 C     \   /l\           /j\   /                                                C
7963 C      \ /   \         /   \ /                                                 C
7964 C       o| o |         | o |o                                                  C
7965 C     \ j|/k\|      \  |/k\|l                                                  C
7966 C      \ /   \       \ /   \                                                   C
7967 C       o             o                                                        C
7968 C       i             i                                                        C
7969 C                                                                              C
7970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7971 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7972 C AL 7/4/01 s1 would occur in the sixth-order moment,
7973 C           but not in a cluster cumulant
7974 #ifdef MOMENT
7975       s1=dip(1,jj,i)*dip(1,kk,k)
7976 #endif
7977       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7978       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7979       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7980       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7981       call transpose2(EUg(1,1,k),auxmat(1,1))
7982       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7983       vv(1)=pizda(1,1)-pizda(2,2)
7984       vv(2)=pizda(1,2)+pizda(2,1)
7985       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7986 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7987 #ifdef MOMENT
7988       eello6_graph2=-(s1+s2+s3+s4)
7989 #else
7990       eello6_graph2=-(s2+s3+s4)
7991 #endif
7992 c      eello6_graph2=-s3
7993 C Derivatives in gamma(i-1)
7994       if (calc_grad) then
7995       if (i.gt.1) then
7996 #ifdef MOMENT
7997         s1=dipderg(1,jj,i)*dip(1,kk,k)
7998 #endif
7999         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8000         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8001         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8002         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8003 #ifdef MOMENT
8004         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8005 #else
8006         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8007 #endif
8008 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8009       endif
8010 C Derivatives in gamma(k-1)
8011 #ifdef MOMENT
8012       s1=dip(1,jj,i)*dipderg(1,kk,k)
8013 #endif
8014       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8015       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8016       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8017       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8018       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8019       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8020       vv(1)=pizda(1,1)-pizda(2,2)
8021       vv(2)=pizda(1,2)+pizda(2,1)
8022       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8023 #ifdef MOMENT
8024       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8025 #else
8026       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8027 #endif
8028 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8029 C Derivatives in gamma(j-1) or gamma(l-1)
8030       if (j.gt.1) then
8031 #ifdef MOMENT
8032         s1=dipderg(3,jj,i)*dip(1,kk,k)
8033 #endif
8034         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8035         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8036         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8037         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8038         vv(1)=pizda(1,1)-pizda(2,2)
8039         vv(2)=pizda(1,2)+pizda(2,1)
8040         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8041 #ifdef MOMENT
8042         if (swap) then
8043           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8044         else
8045           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8046         endif
8047 #endif
8048         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8049 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8050       endif
8051 C Derivatives in gamma(l-1) or gamma(j-1)
8052       if (l.gt.1) then
8053 #ifdef MOMENT
8054         s1=dip(1,jj,i)*dipderg(3,kk,k)
8055 #endif
8056         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8057         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8058         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8059         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8060         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8061         vv(1)=pizda(1,1)-pizda(2,2)
8062         vv(2)=pizda(1,2)+pizda(2,1)
8063         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8064 #ifdef MOMENT
8065         if (swap) then
8066           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8067         else
8068           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8069         endif
8070 #endif
8071         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8072 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8073       endif
8074 C Cartesian derivatives.
8075       if (lprn) then
8076         write (2,*) 'In eello6_graph2'
8077         do iii=1,2
8078           write (2,*) 'iii=',iii
8079           do kkk=1,5
8080             write (2,*) 'kkk=',kkk
8081             do jjj=1,2
8082               write (2,'(3(2f10.5),5x)')
8083      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8084             enddo
8085           enddo
8086         enddo
8087       endif
8088       do iii=1,2
8089         do kkk=1,5
8090           do lll=1,3
8091 #ifdef MOMENT
8092             if (iii.eq.1) then
8093               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8094             else
8095               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8096             endif
8097 #endif
8098             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8099      &        auxvec(1))
8100             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8101             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8102      &        auxvec(1))
8103             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8104             call transpose2(EUg(1,1,k),auxmat(1,1))
8105             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8106      &        pizda(1,1))
8107             vv(1)=pizda(1,1)-pizda(2,2)
8108             vv(2)=pizda(1,2)+pizda(2,1)
8109             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8110 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8111 #ifdef MOMENT
8112             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8113 #else
8114             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8115 #endif
8116             if (swap) then
8117               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8118             else
8119               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8120             endif
8121           enddo
8122         enddo
8123       enddo
8124       endif ! calc_grad
8125       return
8126       end
8127 c----------------------------------------------------------------------------
8128       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8129       implicit real*8 (a-h,o-z)
8130       include 'DIMENSIONS'
8131       include 'COMMON.IOUNITS'
8132       include 'COMMON.CHAIN'
8133       include 'COMMON.DERIV'
8134       include 'COMMON.INTERACT'
8135       include 'COMMON.CONTACTS'
8136       include 'COMMON.CONTMAT'
8137       include 'COMMON.CORRMAT'
8138       include 'COMMON.TORSION'
8139       include 'COMMON.VAR'
8140       include 'COMMON.GEO'
8141       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8142       logical swap
8143 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8144 C                                                                              C
8145 C      Parallel       Antiparallel                                             C
8146 C                                                                              C
8147 C          o             o                                                     C
8148 C         /l\   /   \   /j\                                                    C
8149 C        /   \ /     \ /   \                                                   C
8150 C       /| o |o       o| o |\                                                  C
8151 C       j|/k\|  /      |/k\|l /                                                C
8152 C        /   \ /       /   \ /                                                 C
8153 C       /     o       /     o                                                  C
8154 C       i             i                                                        C
8155 C                                                                              C
8156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8157 C
8158 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8159 C           energy moment and not to the cluster cumulant.
8160       iti=itortyp(itype(i))
8161       if (j.lt.nres-1) then
8162         itj1=itype2loc(itype(j+1))
8163       else
8164         itj1=nloctyp
8165       endif
8166       itk=itype2loc(itype(k))
8167       itk1=itype2loc(itype(k+1))
8168       if (l.lt.nres-1) then
8169         itl1=itype2loc(itype(l+1))
8170       else
8171         itl1=nloctyp
8172       endif
8173 #ifdef MOMENT
8174       s1=dip(4,jj,i)*dip(4,kk,k)
8175 #endif
8176       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8177       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8178       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8179       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8180       call transpose2(EE(1,1,k),auxmat(1,1))
8181       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8182       vv(1)=pizda(1,1)+pizda(2,2)
8183       vv(2)=pizda(2,1)-pizda(1,2)
8184       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8185 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8186 cd     & "sum",-(s2+s3+s4)
8187 #ifdef MOMENT
8188       eello6_graph3=-(s1+s2+s3+s4)
8189 #else
8190       eello6_graph3=-(s2+s3+s4)
8191 #endif
8192 c      eello6_graph3=-s4
8193 C Derivatives in gamma(k-1)
8194       if (calc_grad) then
8195       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8196       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8197       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8198       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8199 C Derivatives in gamma(l-1)
8200       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8201       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8202       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8203       vv(1)=pizda(1,1)+pizda(2,2)
8204       vv(2)=pizda(2,1)-pizda(1,2)
8205       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8206       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8207 C Cartesian derivatives.
8208       do iii=1,2
8209         do kkk=1,5
8210           do lll=1,3
8211 #ifdef MOMENT
8212             if (iii.eq.1) then
8213               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8214             else
8215               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8216             endif
8217 #endif
8218             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8219      &        auxvec(1))
8220             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8221             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8222      &        auxvec(1))
8223             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8224             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8225      &        pizda(1,1))
8226             vv(1)=pizda(1,1)+pizda(2,2)
8227             vv(2)=pizda(2,1)-pizda(1,2)
8228             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8229 #ifdef MOMENT
8230             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8231 #else
8232             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8233 #endif
8234             if (swap) then
8235               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8236             else
8237               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8238             endif
8239 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8240           enddo
8241         enddo
8242       enddo
8243       endif ! calc_grad
8244       return
8245       end
8246 c----------------------------------------------------------------------------
8247       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8248       implicit real*8 (a-h,o-z)
8249       include 'DIMENSIONS'
8250       include 'COMMON.IOUNITS'
8251       include 'COMMON.CHAIN'
8252       include 'COMMON.DERIV'
8253       include 'COMMON.INTERACT'
8254       include 'COMMON.CONTACTS'
8255       include 'COMMON.CONTMAT'
8256       include 'COMMON.CORRMAT'
8257       include 'COMMON.TORSION'
8258       include 'COMMON.VAR'
8259       include 'COMMON.GEO'
8260       include 'COMMON.FFIELD'
8261       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8262      & auxvec1(2),auxmat1(2,2)
8263       logical swap
8264 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8265 C                                                                              C
8266 C      Parallel       Antiparallel                                             C
8267 C                                                                              C
8268 C          o             o                                                     C
8269 C         /l\   /   \   /j\                                                    C
8270 C        /   \ /     \ /   \                                                   C
8271 C       /| o |o       o| o |\                                                  C
8272 C     \ j|/k\|      \  |/k\|l                                                  C
8273 C      \ /   \       \ /   \                                                   C
8274 C       o     \       o     \                                                  C
8275 C       i             i                                                        C
8276 C                                                                              C
8277 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8278 C
8279 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8280 C           energy moment and not to the cluster cumulant.
8281 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8282       iti=itype2loc(itype(i))
8283       itj=itype2loc(itype(j))
8284       if (j.lt.nres-1) then
8285         itj1=itype2loc(itype(j+1))
8286       else
8287         itj1=nloctyp
8288       endif
8289       itk=itype2loc(itype(k))
8290       if (k.lt.nres-1) then
8291         itk1=itype2loc(itype(k+1))
8292       else
8293         itk1=nloctyp
8294       endif
8295       itl=itype2loc(itype(l))
8296       if (l.lt.nres-1) then
8297         itl1=itype2loc(itype(l+1))
8298       else
8299         itl1=nloctyp
8300       endif
8301 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8302 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8303 cd     & ' itl',itl,' itl1',itl1
8304 #ifdef MOMENT
8305       if (imat.eq.1) then
8306         s1=dip(3,jj,i)*dip(3,kk,k)
8307       else
8308         s1=dip(2,jj,j)*dip(2,kk,l)
8309       endif
8310 #endif
8311       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8312       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8313       if (j.eq.l+1) then
8314         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8315         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8316       else
8317         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8318         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8319       endif
8320       call transpose2(EUg(1,1,k),auxmat(1,1))
8321       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8322       vv(1)=pizda(1,1)-pizda(2,2)
8323       vv(2)=pizda(2,1)+pizda(1,2)
8324       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8325 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8326 #ifdef MOMENT
8327       eello6_graph4=-(s1+s2+s3+s4)
8328 #else
8329       eello6_graph4=-(s2+s3+s4)
8330 #endif
8331 C Derivatives in gamma(i-1)
8332       if (calc_grad) then
8333       if (i.gt.1) then
8334 #ifdef MOMENT
8335         if (imat.eq.1) then
8336           s1=dipderg(2,jj,i)*dip(3,kk,k)
8337         else
8338           s1=dipderg(4,jj,j)*dip(2,kk,l)
8339         endif
8340 #endif
8341         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8342         if (j.eq.l+1) then
8343           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8344           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8345         else
8346           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8347           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8348         endif
8349         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8350         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8351 cd          write (2,*) 'turn6 derivatives'
8352 #ifdef MOMENT
8353           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8354 #else
8355           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8356 #endif
8357         else
8358 #ifdef MOMENT
8359           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8360 #else
8361           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8362 #endif
8363         endif
8364       endif
8365 C Derivatives in gamma(k-1)
8366 #ifdef MOMENT
8367       if (imat.eq.1) then
8368         s1=dip(3,jj,i)*dipderg(2,kk,k)
8369       else
8370         s1=dip(2,jj,j)*dipderg(4,kk,l)
8371       endif
8372 #endif
8373       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8374       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8375       if (j.eq.l+1) then
8376         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8377         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8378       else
8379         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8380         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8381       endif
8382       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8383       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8384       vv(1)=pizda(1,1)-pizda(2,2)
8385       vv(2)=pizda(2,1)+pizda(1,2)
8386       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8387       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8388 #ifdef MOMENT
8389         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8390 #else
8391         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8392 #endif
8393       else
8394 #ifdef MOMENT
8395         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8396 #else
8397         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8398 #endif
8399       endif
8400 C Derivatives in gamma(j-1) or gamma(l-1)
8401       if (l.eq.j+1 .and. l.gt.1) then
8402         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8403         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8404         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8405         vv(1)=pizda(1,1)-pizda(2,2)
8406         vv(2)=pizda(2,1)+pizda(1,2)
8407         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8409       else if (j.gt.1) then
8410         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8411         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8412         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8413         vv(1)=pizda(1,1)-pizda(2,2)
8414         vv(2)=pizda(2,1)+pizda(1,2)
8415         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8416         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8417           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8418         else
8419           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8420         endif
8421       endif
8422 C Cartesian derivatives.
8423       do iii=1,2
8424         do kkk=1,5
8425           do lll=1,3
8426 #ifdef MOMENT
8427             if (iii.eq.1) then
8428               if (imat.eq.1) then
8429                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8430               else
8431                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8432               endif
8433             else
8434               if (imat.eq.1) then
8435                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8436               else
8437                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8438               endif
8439             endif
8440 #endif
8441             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8442      &        auxvec(1))
8443             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8444             if (j.eq.l+1) then
8445               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8446      &          b1(1,j+1),auxvec(1))
8447               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8448             else
8449               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8450      &          b1(1,l+1),auxvec(1))
8451               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8452             endif
8453             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8454      &        pizda(1,1))
8455             vv(1)=pizda(1,1)-pizda(2,2)
8456             vv(2)=pizda(2,1)+pizda(1,2)
8457             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8458             if (swap) then
8459               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8460 #ifdef MOMENT
8461                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8462      &             -(s1+s2+s4)
8463 #else
8464                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8465      &             -(s2+s4)
8466 #endif
8467                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8468               else
8469 #ifdef MOMENT
8470                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8471 #else
8472                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8473 #endif
8474                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8475               endif
8476             else
8477 #ifdef MOMENT
8478               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8479 #else
8480               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8481 #endif
8482               if (l.eq.j+1) then
8483                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8484               else
8485                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8486               endif
8487             endif
8488           enddo
8489         enddo
8490       enddo
8491       endif ! calc_grad
8492       return
8493       end
8494 c----------------------------------------------------------------------------
8495       double precision function eello_turn6(i,jj,kk)
8496       implicit real*8 (a-h,o-z)
8497       include 'DIMENSIONS'
8498       include 'COMMON.IOUNITS'
8499       include 'COMMON.CHAIN'
8500       include 'COMMON.DERIV'
8501       include 'COMMON.INTERACT'
8502       include 'COMMON.CONTACTS'
8503       include 'COMMON.CONTMAT'
8504       include 'COMMON.CORRMAT'
8505       include 'COMMON.TORSION'
8506       include 'COMMON.VAR'
8507       include 'COMMON.GEO'
8508       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8509      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8510      &  ggg1(3),ggg2(3)
8511       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8512      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8513 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8514 C           the respective energy moment and not to the cluster cumulant.
8515       s1=0.0d0
8516       s8=0.0d0
8517       s13=0.0d0
8518 c
8519       eello_turn6=0.0d0
8520       j=i+4
8521       k=i+1
8522       l=i+3
8523       iti=itype2loc(itype(i))
8524       itk=itype2loc(itype(k))
8525       itk1=itype2loc(itype(k+1))
8526       itl=itype2loc(itype(l))
8527       itj=itype2loc(itype(j))
8528 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8529 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8530 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8531 cd        eello6=0.0d0
8532 cd        return
8533 cd      endif
8534 cd      write (iout,*)
8535 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8536 cd     &   ' and',k,l
8537 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8538       do iii=1,2
8539         do kkk=1,5
8540           do lll=1,3
8541             derx_turn(lll,kkk,iii)=0.0d0
8542           enddo
8543         enddo
8544       enddo
8545 cd      eij=1.0d0
8546 cd      ekl=1.0d0
8547 cd      ekont=1.0d0
8548       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8549 cd      eello6_5=0.0d0
8550 cd      write (2,*) 'eello6_5',eello6_5
8551 #ifdef MOMENT
8552       call transpose2(AEA(1,1,1),auxmat(1,1))
8553       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8554       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8555       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8556 #endif
8557       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8558       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8559       s2 = scalar2(b1(1,k),vtemp1(1))
8560 #ifdef MOMENT
8561       call transpose2(AEA(1,1,2),atemp(1,1))
8562       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8563       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8564       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8565 #endif
8566       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8567       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8568       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8569 #ifdef MOMENT
8570       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8571       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8572       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8573       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8574       ss13 = scalar2(b1(1,k),vtemp4(1))
8575       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8576 #endif
8577 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8578 c      s1=0.0d0
8579 c      s2=0.0d0
8580 c      s8=0.0d0
8581 c      s12=0.0d0
8582 c      s13=0.0d0
8583       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8584 C Derivatives in gamma(i+2)
8585       if (calc_grad) then
8586       s1d =0.0d0
8587       s8d =0.0d0
8588 #ifdef MOMENT
8589       call transpose2(AEA(1,1,1),auxmatd(1,1))
8590       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8591       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8592       call transpose2(AEAderg(1,1,2),atempd(1,1))
8593       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8594       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8595 #endif
8596       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8597       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8598       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8599 c      s1d=0.0d0
8600 c      s2d=0.0d0
8601 c      s8d=0.0d0
8602 c      s12d=0.0d0
8603 c      s13d=0.0d0
8604       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8605 C Derivatives in gamma(i+3)
8606 #ifdef MOMENT
8607       call transpose2(AEA(1,1,1),auxmatd(1,1))
8608       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8609       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8610       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8611 #endif
8612       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8613       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8614       s2d = scalar2(b1(1,k),vtemp1d(1))
8615 #ifdef MOMENT
8616       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8617       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8618 #endif
8619       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8620 #ifdef MOMENT
8621       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8622       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8623       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8624 #endif
8625 c      s1d=0.0d0
8626 c      s2d=0.0d0
8627 c      s8d=0.0d0
8628 c      s12d=0.0d0
8629 c      s13d=0.0d0
8630 #ifdef MOMENT
8631       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8632      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8633 #else
8634       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8635      &               -0.5d0*ekont*(s2d+s12d)
8636 #endif
8637 C Derivatives in gamma(i+4)
8638       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8639       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8640       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8641 #ifdef MOMENT
8642       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8643       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8644       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8645 #endif
8646 c      s1d=0.0d0
8647 c      s2d=0.0d0
8648 c      s8d=0.0d0
8649 C      s12d=0.0d0
8650 c      s13d=0.0d0
8651 #ifdef MOMENT
8652       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8653 #else
8654       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8655 #endif
8656 C Derivatives in gamma(i+5)
8657 #ifdef MOMENT
8658       call transpose2(AEAderg(1,1,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),vtemp1d(1))
8663       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8664       s2d = scalar2(b1(1,k),vtemp1d(1))
8665 #ifdef MOMENT
8666       call transpose2(AEA(1,1,2),atempd(1,1))
8667       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8668       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8669 #endif
8670       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8671       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8672 #ifdef MOMENT
8673       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8674       ss13d = scalar2(b1(1,k),vtemp4d(1))
8675       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8676 #endif
8677 c      s1d=0.0d0
8678 c      s2d=0.0d0
8679 c      s8d=0.0d0
8680 c      s12d=0.0d0
8681 c      s13d=0.0d0
8682 #ifdef MOMENT
8683       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8684      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8685 #else
8686       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8687      &               -0.5d0*ekont*(s2d+s12d)
8688 #endif
8689 C Cartesian derivatives
8690       do iii=1,2
8691         do kkk=1,5
8692           do lll=1,3
8693 #ifdef MOMENT
8694             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8695             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8696             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8697 #endif
8698             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8699             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8700      &          vtemp1d(1))
8701             s2d = scalar2(b1(1,k),vtemp1d(1))
8702 #ifdef MOMENT
8703             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8704             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8705             s8d = -(atempd(1,1)+atempd(2,2))*
8706      &           scalar2(cc(1,1,l),vtemp2(1))
8707 #endif
8708             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8709      &           auxmatd(1,1))
8710             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8711             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8712 c      s1d=0.0d0
8713 c      s2d=0.0d0
8714 c      s8d=0.0d0
8715 c      s12d=0.0d0
8716 c      s13d=0.0d0
8717 #ifdef MOMENT
8718             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8719      &        - 0.5d0*(s1d+s2d)
8720 #else
8721             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8722      &        - 0.5d0*s2d
8723 #endif
8724 #ifdef MOMENT
8725             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8726      &        - 0.5d0*(s8d+s12d)
8727 #else
8728             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8729      &        - 0.5d0*s12d
8730 #endif
8731           enddo
8732         enddo
8733       enddo
8734 #ifdef MOMENT
8735       do kkk=1,5
8736         do lll=1,3
8737           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8738      &      achuj_tempd(1,1))
8739           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8740           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8741           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8742           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8743           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8744      &      vtemp4d(1))
8745           ss13d = scalar2(b1(1,k),vtemp4d(1))
8746           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8747           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8748         enddo
8749       enddo
8750 #endif
8751 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8752 cd     &  16*eel_turn6_num
8753 cd      goto 1112
8754       if (j.lt.nres-1) then
8755         j1=j+1
8756         j2=j-1
8757       else
8758         j1=j-1
8759         j2=j-2
8760       endif
8761       if (l.lt.nres-1) then
8762         l1=l+1
8763         l2=l-1
8764       else
8765         l1=l-1
8766         l2=l-2
8767       endif
8768       do ll=1,3
8769 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8770 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8771 cgrad        ghalf=0.5d0*ggg1(ll)
8772 cd        ghalf=0.0d0
8773         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8774         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8775         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8776      &    +ekont*derx_turn(ll,2,1)
8777         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8778         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8779      &    +ekont*derx_turn(ll,4,1)
8780         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8781         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8782         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8783 cgrad        ghalf=0.5d0*ggg2(ll)
8784 cd        ghalf=0.0d0
8785         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8786      &    +ekont*derx_turn(ll,2,2)
8787         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8788         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8789      &    +ekont*derx_turn(ll,4,2)
8790         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8791         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8792         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8793       enddo
8794 cd      goto 1112
8795 cgrad      do m=i+1,j-1
8796 cgrad        do ll=1,3
8797 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8798 cgrad        enddo
8799 cgrad      enddo
8800 cgrad      do m=k+1,l-1
8801 cgrad        do ll=1,3
8802 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8803 cgrad        enddo
8804 cgrad      enddo
8805 cgrad1112  continue
8806 cgrad      do m=i+2,j2
8807 cgrad        do ll=1,3
8808 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8809 cgrad        enddo
8810 cgrad      enddo
8811 cgrad      do m=k+2,l2
8812 cgrad        do ll=1,3
8813 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8814 cgrad        enddo
8815 cgrad      enddo
8816 cd      do iii=1,nres-3
8817 cd        write (2,*) iii,g_corr6_loc(iii)
8818 cd      enddo
8819       endif ! calc_grad
8820       eello_turn6=ekont*eel_turn6
8821 cd      write (2,*) 'ekont',ekont
8822 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8823       return
8824       end
8825 #endif
8826 crc-------------------------------------------------
8827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8828       subroutine Eliptransfer(eliptran)
8829       implicit real*8 (a-h,o-z)
8830       include 'DIMENSIONS'
8831       include 'COMMON.GEO'
8832       include 'COMMON.VAR'
8833       include 'COMMON.LOCAL'
8834       include 'COMMON.CHAIN'
8835       include 'COMMON.DERIV'
8836       include 'COMMON.INTERACT'
8837       include 'COMMON.IOUNITS'
8838       include 'COMMON.CALC'
8839       include 'COMMON.CONTROL'
8840       include 'COMMON.SPLITELE'
8841       include 'COMMON.SBRIDGE'
8842 C this is done by Adasko
8843 C      print *,"wchodze"
8844 C structure of box:
8845 C      water
8846 C--bordliptop-- buffore starts
8847 C--bufliptop--- here true lipid starts
8848 C      lipid
8849 C--buflipbot--- lipid ends buffore starts
8850 C--bordlipbot--buffore ends
8851       eliptran=0.0
8852       do i=1,nres
8853 C       do i=1,1
8854         if (itype(i).eq.ntyp1) cycle
8855
8856         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8857         if (positi.le.0) positi=positi+boxzsize
8858 C        print *,i
8859 C first for peptide groups
8860 c for each residue check if it is in lipid or lipid water border area
8861        if ((positi.gt.bordlipbot)
8862      &.and.(positi.lt.bordliptop)) then
8863 C the energy transfer exist
8864         if (positi.lt.buflipbot) then
8865 C what fraction I am in
8866          fracinbuf=1.0d0-
8867      &        ((positi-bordlipbot)/lipbufthick)
8868 C lipbufthick is thickenes of lipid buffore
8869          sslip=sscalelip(fracinbuf)
8870          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8871          eliptran=eliptran+sslip*pepliptran
8872          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8873          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8874 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8875         elseif (positi.gt.bufliptop) then
8876          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8877          sslip=sscalelip(fracinbuf)
8878          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8879          eliptran=eliptran+sslip*pepliptran
8880          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8881          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8882 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8883 C          print *, "doing sscalefor top part"
8884 C         print *,i,sslip,fracinbuf,ssgradlip
8885         else
8886          eliptran=eliptran+pepliptran
8887 C         print *,"I am in true lipid"
8888         endif
8889 C       else
8890 C       eliptran=elpitran+0.0 ! I am in water
8891        endif
8892        enddo
8893 C       print *, "nic nie bylo w lipidzie?"
8894 C now multiply all by the peptide group transfer factor
8895 C       eliptran=eliptran*pepliptran
8896 C now the same for side chains
8897 CV       do i=1,1
8898        do i=1,nres
8899         if (itype(i).eq.ntyp1) cycle
8900         positi=(mod(c(3,i+nres),boxzsize))
8901         if (positi.le.0) positi=positi+boxzsize
8902 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8903 c for each residue check if it is in lipid or lipid water border area
8904 C       respos=mod(c(3,i+nres),boxzsize)
8905 C       print *,positi,bordlipbot,buflipbot
8906        if ((positi.gt.bordlipbot)
8907      & .and.(positi.lt.bordliptop)) then
8908 C the energy transfer exist
8909         if (positi.lt.buflipbot) then
8910          fracinbuf=1.0d0-
8911      &     ((positi-bordlipbot)/lipbufthick)
8912 C lipbufthick is thickenes of lipid buffore
8913          sslip=sscalelip(fracinbuf)
8914          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8915          eliptran=eliptran+sslip*liptranene(itype(i))
8916          gliptranx(3,i)=gliptranx(3,i)
8917      &+ssgradlip*liptranene(itype(i))
8918          gliptranc(3,i-1)= gliptranc(3,i-1)
8919      &+ssgradlip*liptranene(itype(i))
8920 C         print *,"doing sccale for lower part"
8921         elseif (positi.gt.bufliptop) then
8922          fracinbuf=1.0d0-
8923      &((bordliptop-positi)/lipbufthick)
8924          sslip=sscalelip(fracinbuf)
8925          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8926          eliptran=eliptran+sslip*liptranene(itype(i))
8927          gliptranx(3,i)=gliptranx(3,i)
8928      &+ssgradlip*liptranene(itype(i))
8929          gliptranc(3,i-1)= gliptranc(3,i-1)
8930      &+ssgradlip*liptranene(itype(i))
8931 C          print *, "doing sscalefor top part",sslip,fracinbuf
8932         else
8933          eliptran=eliptran+liptranene(itype(i))
8934 C         print *,"I am in true lipid"
8935         endif
8936         endif ! if in lipid or buffor
8937 C       else
8938 C       eliptran=elpitran+0.0 ! I am in water
8939        enddo
8940        return
8941        end
8942
8943
8944 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8945
8946       SUBROUTINE MATVEC2(A1,V1,V2)
8947       implicit real*8 (a-h,o-z)
8948       include 'DIMENSIONS'
8949       DIMENSION A1(2,2),V1(2),V2(2)
8950 c      DO 1 I=1,2
8951 c        VI=0.0
8952 c        DO 3 K=1,2
8953 c    3     VI=VI+A1(I,K)*V1(K)
8954 c        Vaux(I)=VI
8955 c    1 CONTINUE
8956
8957       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8958       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8959
8960       v2(1)=vaux1
8961       v2(2)=vaux2
8962       END
8963 C---------------------------------------
8964       SUBROUTINE MATMAT2(A1,A2,A3)
8965       implicit real*8 (a-h,o-z)
8966       include 'DIMENSIONS'
8967       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8968 c      DIMENSION AI3(2,2)
8969 c        DO  J=1,2
8970 c          A3IJ=0.0
8971 c          DO K=1,2
8972 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8973 c          enddo
8974 c          A3(I,J)=A3IJ
8975 c       enddo
8976 c      enddo
8977
8978       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8979       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8980       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8981       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8982
8983       A3(1,1)=AI3_11
8984       A3(2,1)=AI3_21
8985       A3(1,2)=AI3_12
8986       A3(2,2)=AI3_22
8987       END
8988
8989 c-------------------------------------------------------------------------
8990       double precision function scalar2(u,v)
8991       implicit none
8992       double precision u(2),v(2)
8993       double precision sc
8994       integer i
8995       scalar2=u(1)*v(1)+u(2)*v(2)
8996       return
8997       end
8998
8999 C-----------------------------------------------------------------------------
9000
9001       subroutine transpose2(a,at)
9002       implicit none
9003       double precision a(2,2),at(2,2)
9004       at(1,1)=a(1,1)
9005       at(1,2)=a(2,1)
9006       at(2,1)=a(1,2)
9007       at(2,2)=a(2,2)
9008       return
9009       end
9010 c--------------------------------------------------------------------------
9011       subroutine transpose(n,a,at)
9012       implicit none
9013       integer n,i,j
9014       double precision a(n,n),at(n,n)
9015       do i=1,n
9016         do j=1,n
9017           at(j,i)=a(i,j)
9018         enddo
9019       enddo
9020       return
9021       end
9022 C---------------------------------------------------------------------------
9023       subroutine prodmat3(a1,a2,kk,transp,prod)
9024       implicit none
9025       integer i,j
9026       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9027       logical transp
9028 crc      double precision auxmat(2,2),prod_(2,2)
9029
9030       if (transp) then
9031 crc        call transpose2(kk(1,1),auxmat(1,1))
9032 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9033 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9034
9035            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9036      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9037            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9038      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9039            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9040      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9041            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9042      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9043
9044       else
9045 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9046 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9047
9048            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9049      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9050            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9051      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9052            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9053      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9054            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9055      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9056
9057       endif
9058 c      call transpose2(a2(1,1),a2t(1,1))
9059
9060 crc      print *,transp
9061 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9062 crc      print *,((prod(i,j),i=1,2),j=1,2)
9063
9064       return
9065       end
9066 C-----------------------------------------------------------------------------
9067       double precision function scalar(u,v)
9068       implicit none
9069       double precision u(3),v(3)
9070       double precision sc
9071       integer i
9072       sc=0.0d0
9073       do i=1,3
9074         sc=sc+u(i)*v(i)
9075       enddo
9076       scalar=sc
9077       return
9078       end
9079 C-----------------------------------------------------------------------
9080       double precision function sscale(r)
9081       double precision r,gamm
9082       include "COMMON.SPLITELE"
9083       if(r.lt.r_cut-rlamb) then
9084         sscale=1.0d0
9085       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9086         gamm=(r-(r_cut-rlamb))/rlamb
9087         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9088       else
9089         sscale=0d0
9090       endif
9091       return
9092       end
9093 C-----------------------------------------------------------------------
9094 C-----------------------------------------------------------------------
9095       double precision function sscagrad(r)
9096       double precision r,gamm
9097       include "COMMON.SPLITELE"
9098       if(r.lt.r_cut-rlamb) then
9099         sscagrad=0.0d0
9100       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9101         gamm=(r-(r_cut-rlamb))/rlamb
9102         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9103       else
9104         sscagrad=0.0d0
9105       endif
9106       return
9107       end
9108 C-----------------------------------------------------------------------
9109 C-----------------------------------------------------------------------
9110       double precision function sscalelip(r)
9111       double precision r,gamm
9112       include "COMMON.SPLITELE"
9113 C      if(r.lt.r_cut-rlamb) then
9114 C        sscale=1.0d0
9115 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9116 C        gamm=(r-(r_cut-rlamb))/rlamb
9117         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9118 C      else
9119 C        sscale=0d0
9120 C      endif
9121       return
9122       end
9123 C-----------------------------------------------------------------------
9124       double precision function sscagradlip(r)
9125       double precision r,gamm
9126       include "COMMON.SPLITELE"
9127 C     if(r.lt.r_cut-rlamb) then
9128 C        sscagrad=0.0d0
9129 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9130 C        gamm=(r-(r_cut-rlamb))/rlamb
9131         sscagradlip=r*(6*r-6.0d0)
9132 C      else
9133 C        sscagrad=0.0d0
9134 C      endif
9135       return
9136       end
9137
9138 C-----------------------------------------------------------------------
9139        subroutine set_shield_fac
9140       implicit real*8 (a-h,o-z)
9141       include 'DIMENSIONS'
9142       include 'COMMON.CHAIN'
9143       include 'COMMON.DERIV'
9144       include 'COMMON.IOUNITS'
9145       include 'COMMON.SHIELD'
9146       include 'COMMON.INTERACT'
9147 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9148       double precision div77_81/0.974996043d0/,
9149      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9150
9151 C the vector between center of side_chain and peptide group
9152        double precision pep_side(3),long,side_calf(3),
9153      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9154      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9155 C the line belowe needs to be changed for FGPROC>1
9156       do i=1,nres-1
9157       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9158       ishield_list(i)=0
9159 Cif there two consequtive dummy atoms there is no peptide group between them
9160 C the line below has to be changed for FGPROC>1
9161       VolumeTotal=0.0
9162       do k=1,nres
9163        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9164        dist_pep_side=0.0
9165        dist_side_calf=0.0
9166        do j=1,3
9167 C first lets set vector conecting the ithe side-chain with kth side-chain
9168       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9169 C      pep_side(j)=2.0d0
9170 C and vector conecting the side-chain with its proper calfa
9171       side_calf(j)=c(j,k+nres)-c(j,k)
9172 C      side_calf(j)=2.0d0
9173       pept_group(j)=c(j,i)-c(j,i+1)
9174 C lets have their lenght
9175       dist_pep_side=pep_side(j)**2+dist_pep_side
9176       dist_side_calf=dist_side_calf+side_calf(j)**2
9177       dist_pept_group=dist_pept_group+pept_group(j)**2
9178       enddo
9179        dist_pep_side=dsqrt(dist_pep_side)
9180        dist_pept_group=dsqrt(dist_pept_group)
9181        dist_side_calf=dsqrt(dist_side_calf)
9182       do j=1,3
9183         pep_side_norm(j)=pep_side(j)/dist_pep_side
9184         side_calf_norm(j)=dist_side_calf
9185       enddo
9186 C now sscale fraction
9187        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9188 C       print *,buff_shield,"buff"
9189 C now sscale
9190         if (sh_frac_dist.le.0.0) cycle
9191 C If we reach here it means that this side chain reaches the shielding sphere
9192 C Lets add him to the list for gradient
9193         ishield_list(i)=ishield_list(i)+1
9194 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9195 C this list is essential otherwise problem would be O3
9196         shield_list(ishield_list(i),i)=k
9197 C Lets have the sscale value
9198         if (sh_frac_dist.gt.1.0) then
9199          scale_fac_dist=1.0d0
9200          do j=1,3
9201          sh_frac_dist_grad(j)=0.0d0
9202          enddo
9203         else
9204          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9205      &                   *(2.0*sh_frac_dist-3.0d0)
9206          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9207      &                  /dist_pep_side/buff_shield*0.5
9208 C remember for the final gradient multiply sh_frac_dist_grad(j)
9209 C for side_chain by factor -2 !
9210          do j=1,3
9211          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9212 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9213 C     &                    sh_frac_dist_grad(j)
9214          enddo
9215         endif
9216 C        if ((i.eq.3).and.(k.eq.2)) then
9217 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9218 C     & ,"TU"
9219 C        endif
9220
9221 C this is what is now we have the distance scaling now volume...
9222       short=short_r_sidechain(itype(k))
9223       long=long_r_sidechain(itype(k))
9224       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9225 C now costhet_grad
9226 C       costhet=0.0d0
9227        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9228 C       costhet_fac=0.0d0
9229        do j=1,3
9230          costhet_grad(j)=costhet_fac*pep_side(j)
9231        enddo
9232 C remember for the final gradient multiply costhet_grad(j)
9233 C for side_chain by factor -2 !
9234 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9235 C pep_side0pept_group is vector multiplication
9236       pep_side0pept_group=0.0
9237       do j=1,3
9238       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9239       enddo
9240       cosalfa=(pep_side0pept_group/
9241      & (dist_pep_side*dist_side_calf))
9242       fac_alfa_sin=1.0-cosalfa**2
9243       fac_alfa_sin=dsqrt(fac_alfa_sin)
9244       rkprim=fac_alfa_sin*(long-short)+short
9245 C now costhet_grad
9246        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9247        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9248
9249        do j=1,3
9250          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9251      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9252      &*(long-short)/fac_alfa_sin*cosalfa/
9253      &((dist_pep_side*dist_side_calf))*
9254      &((side_calf(j))-cosalfa*
9255      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9256
9257         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9258      &*(long-short)/fac_alfa_sin*cosalfa
9259      &/((dist_pep_side*dist_side_calf))*
9260      &(pep_side(j)-
9261      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9262        enddo
9263
9264       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9265      &                    /VSolvSphere_div
9266      &                    *wshield
9267 C now the gradient...
9268 C grad_shield is gradient of Calfa for peptide groups
9269 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9270 C     &               costhet,cosphi
9271 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9272 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9273       do j=1,3
9274       grad_shield(j,i)=grad_shield(j,i)
9275 C gradient po skalowaniu
9276      &                +(sh_frac_dist_grad(j)
9277 C  gradient po costhet
9278      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9279      &-scale_fac_dist*(cosphi_grad_long(j))
9280      &/(1.0-cosphi) )*div77_81
9281      &*VofOverlap
9282 C grad_shield_side is Cbeta sidechain gradient
9283       grad_shield_side(j,ishield_list(i),i)=
9284      &        (sh_frac_dist_grad(j)*(-2.0d0)
9285      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9286      &       +scale_fac_dist*(cosphi_grad_long(j))
9287      &        *2.0d0/(1.0-cosphi))
9288      &        *div77_81*VofOverlap
9289
9290        grad_shield_loc(j,ishield_list(i),i)=
9291      &   scale_fac_dist*cosphi_grad_loc(j)
9292      &        *2.0d0/(1.0-cosphi)
9293      &        *div77_81*VofOverlap
9294       enddo
9295       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9296       enddo
9297       fac_shield(i)=VolumeTotal*div77_81+div4_81
9298 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9299       enddo
9300       return
9301       end
9302 C--------------------------------------------------------------------------
9303 C first for shielding is setting of function of side-chains
9304        subroutine set_shield_fac2
9305       implicit real*8 (a-h,o-z)
9306       include 'DIMENSIONS'
9307       include 'COMMON.CHAIN'
9308       include 'COMMON.DERIV'
9309       include 'COMMON.IOUNITS'
9310       include 'COMMON.SHIELD'
9311       include 'COMMON.INTERACT'
9312 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9313       double precision div77_81/0.974996043d0/,
9314      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9315
9316 C the vector between center of side_chain and peptide group
9317        double precision pep_side(3),long,side_calf(3),
9318      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9319      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9320 C the line belowe needs to be changed for FGPROC>1
9321       do i=1,nres-1
9322       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9323       ishield_list(i)=0
9324 Cif there two consequtive dummy atoms there is no peptide group between them
9325 C the line below has to be changed for FGPROC>1
9326       VolumeTotal=0.0
9327       do k=1,nres
9328        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9329        dist_pep_side=0.0
9330        dist_side_calf=0.0
9331        do j=1,3
9332 C first lets set vector conecting the ithe side-chain with kth side-chain
9333       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9334 C      pep_side(j)=2.0d0
9335 C and vector conecting the side-chain with its proper calfa
9336       side_calf(j)=c(j,k+nres)-c(j,k)
9337 C      side_calf(j)=2.0d0
9338       pept_group(j)=c(j,i)-c(j,i+1)
9339 C lets have their lenght
9340       dist_pep_side=pep_side(j)**2+dist_pep_side
9341       dist_side_calf=dist_side_calf+side_calf(j)**2
9342       dist_pept_group=dist_pept_group+pept_group(j)**2
9343       enddo
9344        dist_pep_side=dsqrt(dist_pep_side)
9345        dist_pept_group=dsqrt(dist_pept_group)
9346        dist_side_calf=dsqrt(dist_side_calf)
9347       do j=1,3
9348         pep_side_norm(j)=pep_side(j)/dist_pep_side
9349         side_calf_norm(j)=dist_side_calf
9350       enddo
9351 C now sscale fraction
9352        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9353 C       print *,buff_shield,"buff"
9354 C now sscale
9355         if (sh_frac_dist.le.0.0) cycle
9356 C If we reach here it means that this side chain reaches the shielding sphere
9357 C Lets add him to the list for gradient
9358         ishield_list(i)=ishield_list(i)+1
9359 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9360 C this list is essential otherwise problem would be O3
9361         shield_list(ishield_list(i),i)=k
9362 C Lets have the sscale value
9363         if (sh_frac_dist.gt.1.0) then
9364          scale_fac_dist=1.0d0
9365          do j=1,3
9366          sh_frac_dist_grad(j)=0.0d0
9367          enddo
9368         else
9369          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9370      &                   *(2.0d0*sh_frac_dist-3.0d0)
9371          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9372      &                  /dist_pep_side/buff_shield*0.5d0
9373 C remember for the final gradient multiply sh_frac_dist_grad(j)
9374 C for side_chain by factor -2 !
9375          do j=1,3
9376          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9377 C         sh_frac_dist_grad(j)=0.0d0
9378 C         scale_fac_dist=1.0d0
9379 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9380 C     &                    sh_frac_dist_grad(j)
9381          enddo
9382         endif
9383 C this is what is now we have the distance scaling now volume...
9384       short=short_r_sidechain(itype(k))
9385       long=long_r_sidechain(itype(k))
9386       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9387       sinthet=short/dist_pep_side*costhet
9388 C now costhet_grad
9389 C       costhet=0.6d0
9390 C       sinthet=0.8
9391        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9392 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9393 C     &             -short/dist_pep_side**2/costhet)
9394 C       costhet_fac=0.0d0
9395        do j=1,3
9396          costhet_grad(j)=costhet_fac*pep_side(j)
9397        enddo
9398 C remember for the final gradient multiply costhet_grad(j)
9399 C for side_chain by factor -2 !
9400 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9401 C pep_side0pept_group is vector multiplication
9402       pep_side0pept_group=0.0d0
9403       do j=1,3
9404       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9405       enddo
9406       cosalfa=(pep_side0pept_group/
9407      & (dist_pep_side*dist_side_calf))
9408       fac_alfa_sin=1.0d0-cosalfa**2
9409       fac_alfa_sin=dsqrt(fac_alfa_sin)
9410       rkprim=fac_alfa_sin*(long-short)+short
9411 C      rkprim=short
9412
9413 C now costhet_grad
9414        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9415 C       cosphi=0.6
9416        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9417        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9418      &      dist_pep_side**2)
9419 C       sinphi=0.8
9420        do j=1,3
9421          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9422      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9423      &*(long-short)/fac_alfa_sin*cosalfa/
9424      &((dist_pep_side*dist_side_calf))*
9425      &((side_calf(j))-cosalfa*
9426      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9427 C       cosphi_grad_long(j)=0.0d0
9428         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9429      &*(long-short)/fac_alfa_sin*cosalfa
9430      &/((dist_pep_side*dist_side_calf))*
9431      &(pep_side(j)-
9432      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9433 C       cosphi_grad_loc(j)=0.0d0
9434        enddo
9435 C      print *,sinphi,sinthet
9436       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9437      &                    /VSolvSphere_div
9438 C     &                    *wshield
9439 C now the gradient...
9440       do j=1,3
9441       grad_shield(j,i)=grad_shield(j,i)
9442 C gradient po skalowaniu
9443      &                +(sh_frac_dist_grad(j)*VofOverlap
9444 C  gradient po costhet
9445      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9446      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9447      &       sinphi/sinthet*costhet*costhet_grad(j)
9448      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9449      & )*wshield
9450 C grad_shield_side is Cbeta sidechain gradient
9451       grad_shield_side(j,ishield_list(i),i)=
9452      &        (sh_frac_dist_grad(j)*(-2.0d0)
9453      &        *VofOverlap
9454      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9455      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9456      &       sinphi/sinthet*costhet*costhet_grad(j)
9457      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9458      &       )*wshield
9459
9460        grad_shield_loc(j,ishield_list(i),i)=
9461      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9462      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9463      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9464      &        ))
9465      &        *wshield
9466       enddo
9467       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9468       enddo
9469       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9470 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9471 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9472       enddo
9473       return
9474       end
9475 C--------------------------------------------------------------------------
9476       double precision function tschebyshev(m,n,x,y)
9477       implicit none
9478       include "DIMENSIONS"
9479       integer i,m,n
9480       double precision x(n),y,yy(0:maxvar),aux
9481 c Tschebyshev polynomial. Note that the first term is omitted
9482 c m=0: the constant term is included
9483 c m=1: the constant term is not included
9484       yy(0)=1.0d0
9485       yy(1)=y
9486       do i=2,n
9487         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9488       enddo
9489       aux=0.0d0
9490       do i=m,n
9491         aux=aux+x(i)*yy(i)
9492       enddo
9493       tschebyshev=aux
9494       return
9495       end
9496 C--------------------------------------------------------------------------
9497       double precision function gradtschebyshev(m,n,x,y)
9498       implicit none
9499       include "DIMENSIONS"
9500       integer i,m,n
9501       double precision x(n+1),y,yy(0:maxvar),aux
9502 c Tschebyshev polynomial. Note that the first term is omitted
9503 c m=0: the constant term is included
9504 c m=1: the constant term is not included
9505       yy(0)=1.0d0
9506       yy(1)=2.0d0*y
9507       do i=2,n
9508         yy(i)=2*y*yy(i-1)-yy(i-2)
9509       enddo
9510       aux=0.0d0
9511       do i=m,n
9512         aux=aux+x(i+1)*yy(i)*(i+1)
9513 C        print *, x(i+1),yy(i),i
9514       enddo
9515       gradtschebyshev=aux
9516       return
9517       end
9518 c----------------------------------------------------------------------------
9519       double precision function sscale2(r,r_cut,r0,rlamb)
9520       implicit none
9521       double precision r,gamm,r_cut,r0,rlamb,rr
9522       rr = dabs(r-r0)
9523 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9524 c      write (2,*) "rr",rr
9525       if(rr.lt.r_cut-rlamb) then
9526         sscale2=1.0d0
9527       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9528         gamm=(rr-(r_cut-rlamb))/rlamb
9529         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9530       else
9531         sscale2=0d0
9532       endif
9533       return
9534       end
9535 C-----------------------------------------------------------------------
9536       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9537       implicit none
9538       double precision r,gamm,r_cut,r0,rlamb,rr
9539       rr = dabs(r-r0)
9540       if(rr.lt.r_cut-rlamb) then
9541         sscalgrad2=0.0d0
9542       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9543         gamm=(rr-(r_cut-rlamb))/rlamb
9544         if (r.ge.r0) then
9545           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9546         else
9547           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9548         endif
9549       else
9550         sscalgrad2=0.0d0
9551       endif
9552       return
9553       end
9554 c----------------------------------------------------------------------------
9555       subroutine e_saxs(Esaxs_constr)
9556       implicit none
9557       include 'DIMENSIONS'
9558 #ifdef MPI
9559       include "mpif.h"
9560       include "COMMON.SETUP"
9561       integer IERR
9562 #endif
9563       include 'COMMON.SBRIDGE'
9564       include 'COMMON.CHAIN'
9565       include 'COMMON.GEO'
9566       include 'COMMON.LOCAL'
9567       include 'COMMON.INTERACT'
9568       include 'COMMON.VAR'
9569       include 'COMMON.IOUNITS'
9570       include 'COMMON.DERIV'
9571       include 'COMMON.CONTROL'
9572       include 'COMMON.NAMES'
9573       include 'COMMON.FFIELD'
9574       include 'COMMON.LANGEVIN'
9575       include 'COMMON.SAXS'
9576 c
9577       double precision Esaxs_constr
9578       integer i,iint,j,k,l
9579       double precision PgradC(maxSAXS,3,maxres),
9580      &  PgradX(maxSAXS,3,maxres)
9581 #ifdef MPI
9582       double precision PgradC_(maxSAXS,3,maxres),
9583      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9584 #endif
9585       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9586      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9587      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9588      & auxX,auxX1,CACAgrad,Cnorm
9589       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9590       double precision dist
9591       external dist
9592 c  SAXS restraint penalty function
9593 #ifdef DEBUG
9594       write(iout,*) "------- SAXS penalty function start -------"
9595       write (iout,*) "nsaxs",nsaxs
9596       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9597       write (iout,*) "Psaxs"
9598       do i=1,nsaxs
9599         write (iout,'(i5,e15.5)') i, Psaxs(i)
9600       enddo
9601 #endif
9602       Esaxs_constr = 0.0d0
9603       do k=1,nsaxs
9604         Pcalc(k)=0.0d0
9605         do j=1,nres
9606           do l=1,3
9607             PgradC(k,l,j)=0.0d0
9608             PgradX(k,l,j)=0.0d0
9609           enddo
9610         enddo
9611       enddo
9612       do i=iatsc_s,iatsc_e
9613        if (itype(i).eq.ntyp1) cycle
9614        do iint=1,nint_gr(i)
9615          do j=istart(i,iint),iend(i,iint)
9616            if (itype(j).eq.ntyp1) cycle
9617 #ifdef ALLSAXS
9618            dijCACA=dist(i,j)
9619            dijCASC=dist(i,j+nres)
9620            dijSCCA=dist(i+nres,j)
9621            dijSCSC=dist(i+nres,j+nres)
9622            sigma2CACA=2.0d0/(pstok**2)
9623            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9624            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9625            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9626            do k=1,nsaxs
9627              dk = distsaxs(k)
9628              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9629              if (itype(j).ne.10) then
9630              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9631              else
9632              endif
9633              expCASC = 0.0d0
9634              if (itype(i).ne.10) then
9635              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9636              else
9637              expSCCA = 0.0d0
9638              endif
9639              if (itype(i).ne.10 .and. itype(j).ne.10) then
9640              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9641              else
9642              expSCSC = 0.0d0
9643              endif
9644              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9645 #ifdef DEBUG
9646              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9647 #endif
9648              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9649              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9650              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9651              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9652              do l=1,3
9653 c CA CA
9654                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9655                PgradC(k,l,i) = PgradC(k,l,i)-aux
9656                PgradC(k,l,j) = PgradC(k,l,j)+aux
9657 c CA SC
9658                if (itype(j).ne.10) then
9659                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9660                PgradC(k,l,i) = PgradC(k,l,i)-aux
9661                PgradC(k,l,j) = PgradC(k,l,j)+aux
9662                PgradX(k,l,j) = PgradX(k,l,j)+aux
9663                endif
9664 c SC CA
9665                if (itype(i).ne.10) then
9666                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9667                PgradX(k,l,i) = PgradX(k,l,i)-aux
9668                PgradC(k,l,i) = PgradC(k,l,i)-aux
9669                PgradC(k,l,j) = PgradC(k,l,j)+aux
9670                endif
9671 c SC SC
9672                if (itype(i).ne.10 .and. itype(j).ne.10) then
9673                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9674                PgradC(k,l,i) = PgradC(k,l,i)-aux
9675                PgradC(k,l,j) = PgradC(k,l,j)+aux
9676                PgradX(k,l,i) = PgradX(k,l,i)-aux
9677                PgradX(k,l,j) = PgradX(k,l,j)+aux
9678                endif
9679              enddo ! l
9680            enddo ! k
9681 #else
9682            dijCACA=dist(i,j)
9683            sigma2CACA=scal_rad**2*0.25d0/
9684      &        (restok(itype(j))**2+restok(itype(i))**2)
9685
9686            IF (saxs_cutoff.eq.0) THEN
9687            do k=1,nsaxs
9688              dk = distsaxs(k)
9689              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9690              Pcalc(k) = Pcalc(k)+expCACA
9691              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9692              do l=1,3
9693                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9694                PgradC(k,l,i) = PgradC(k,l,i)-aux
9695                PgradC(k,l,j) = PgradC(k,l,j)+aux
9696              enddo ! l
9697            enddo ! k
9698            ELSE
9699            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9700            do k=1,nsaxs
9701              dk = distsaxs(k)
9702 c             write (2,*) "ijk",i,j,k
9703              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9704              if (sss2.eq.0.0d0) cycle
9705              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9706              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9707              Pcalc(k) = Pcalc(k)+expCACA
9708 #ifdef DEBUG
9709              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9710 #endif
9711              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9712      &             ssgrad2*expCACA/sss2
9713              do l=1,3
9714 c CA CA
9715                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9716                PgradC(k,l,i) = PgradC(k,l,i)+aux
9717                PgradC(k,l,j) = PgradC(k,l,j)-aux
9718              enddo ! l
9719            enddo ! k
9720            ENDIF
9721 #endif
9722          enddo ! j
9723        enddo ! iint
9724       enddo ! i
9725 #ifdef MPI
9726       if (nfgtasks.gt.1) then
9727         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9728      &    MPI_SUM,king,FG_COMM,IERR)
9729         if (fg_rank.eq.king) then
9730           do k=1,nsaxs
9731             Pcalc(k) = Pcalc_(k)
9732           enddo
9733         endif
9734         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9736         if (fg_rank.eq.king) then
9737           do i=1,nres
9738             do l=1,3
9739               do k=1,nsaxs
9740                 PgradC(k,l,i) = PgradC_(k,l,i)
9741               enddo
9742             enddo
9743           enddo
9744         endif
9745 #ifdef ALLSAXS
9746         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9748         if (fg_rank.eq.king) then
9749           do i=1,nres
9750             do l=1,3
9751               do k=1,nsaxs
9752                 PgradX(k,l,i) = PgradX_(k,l,i)
9753               enddo
9754             enddo
9755           enddo
9756         endif
9757 #endif
9758       endif
9759 #endif
9760 #ifdef MPI
9761       if (fg_rank.eq.king) then
9762 #endif
9763       Cnorm = 0.0d0
9764       do k=1,nsaxs
9765         Cnorm = Cnorm + Pcalc(k)
9766       enddo
9767       Esaxs_constr = dlog(Cnorm)-wsaxs0
9768       do k=1,nsaxs
9769         if (Pcalc(k).gt.0.0d0)
9770      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9771 #ifdef DEBUG
9772         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9773 #endif
9774       enddo
9775 #ifdef DEBUG
9776       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9777 #endif
9778       do i=nnt,nct
9779         do l=1,3
9780           auxC=0.0d0
9781           auxC1=0.0d0
9782           auxX=0.0d0
9783           auxX1=0.d0
9784           do k=1,nsaxs
9785             if (Pcalc(k).gt.0)
9786      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9787             auxC1 = auxC1+PgradC(k,l,i)
9788 #ifdef ALLSAXS
9789             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9790             auxX1 = auxX1+PgradX(k,l,i)
9791 #endif
9792           enddo
9793           gsaxsC(l,i) = auxC - auxC1/Cnorm
9794 #ifdef ALLSAXS
9795           gsaxsX(l,i) = auxX - auxX1/Cnorm
9796 #endif
9797 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9798 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9799         enddo
9800       enddo
9801 #ifdef MPI
9802       endif
9803 #endif
9804       return
9805       end
9806 c----------------------------------------------------------------------------
9807       subroutine e_saxsC(Esaxs_constr)
9808       implicit none
9809       include 'DIMENSIONS'
9810 #ifdef MPI
9811       include "mpif.h"
9812       include "COMMON.SETUP"
9813       integer IERR
9814 #endif
9815       include 'COMMON.SBRIDGE'
9816       include 'COMMON.CHAIN'
9817       include 'COMMON.GEO'
9818       include 'COMMON.LOCAL'
9819       include 'COMMON.INTERACT'
9820       include 'COMMON.VAR'
9821       include 'COMMON.IOUNITS'
9822       include 'COMMON.DERIV'
9823       include 'COMMON.CONTROL'
9824       include 'COMMON.NAMES'
9825       include 'COMMON.FFIELD'
9826       include 'COMMON.LANGEVIN'
9827       include 'COMMON.SAXS'
9828 c
9829       double precision Esaxs_constr
9830       integer i,iint,j,k,l
9831       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9832 #ifdef MPI
9833       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9834 #endif
9835       double precision dk,dijCASPH,dijSCSPH,
9836      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9837      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9838      & auxX,auxX1,Cnorm
9839 c  SAXS restraint penalty function
9840 #ifdef DEBUG
9841       write(iout,*) "------- SAXS penalty function start -------"
9842       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9843      & " isaxs_end",isaxs_end
9844       write (iout,*) "nnt",nnt," ntc",nct
9845       do i=nnt,nct
9846         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9847      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9848       enddo
9849       do i=nnt,nct
9850         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9851       enddo
9852 #endif
9853       Esaxs_constr = 0.0d0
9854       logPtot=0.0d0
9855       do j=isaxs_start,isaxs_end
9856         Pcalc_=0.0d0
9857         do i=1,nres
9858           do l=1,3
9859             PgradC(l,i)=0.0d0
9860             PgradX(l,i)=0.0d0
9861           enddo
9862         enddo
9863         do i=nnt,nct
9864           dijCASPH=0.0d0
9865           dijSCSPH=0.0d0
9866           do l=1,3
9867             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9868           enddo
9869           if (itype(i).ne.10) then
9870           do l=1,3
9871             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9872           enddo
9873           endif
9874           sigma2CA=2.0d0/pstok**2
9875           sigma2SC=4.0d0/restok(itype(i))**2
9876           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9877           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9878           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9879 #ifdef DEBUG
9880           write(*,*) "processor i j Pcalc",
9881      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9882 #endif
9883           CASPHgrad = sigma2CA*expCASPH
9884           SCSPHgrad = sigma2SC*expSCSPH
9885           do l=1,3
9886             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9887             PgradX(l,i) = PgradX(l,i) + aux
9888             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9889           enddo ! l
9890         enddo ! i
9891         do i=nnt,nct
9892           do l=1,3
9893             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9894             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9895           enddo
9896         enddo
9897         logPtot = logPtot - dlog(Pcalc_)
9898 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9899 c     &    " logPtot",logPtot
9900       enddo ! j
9901 #ifdef MPI
9902       if (nfgtasks.gt.1) then
9903 c        write (iout,*) "logPtot before reduction",logPtot
9904         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9905      &    MPI_SUM,king,FG_COMM,IERR)
9906         logPtot = logPtot_
9907 c        write (iout,*) "logPtot after reduction",logPtot
9908         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9909      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9910         if (fg_rank.eq.king) then
9911           do i=1,nres
9912             do l=1,3
9913               gsaxsC(l,i) = gsaxsC_(l,i)
9914             enddo
9915           enddo
9916         endif
9917         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9918      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9919         if (fg_rank.eq.king) then
9920           do i=1,nres
9921             do l=1,3
9922               gsaxsX(l,i) = gsaxsX_(l,i)
9923             enddo
9924           enddo
9925         endif
9926       endif
9927 #endif
9928       Esaxs_constr = logPtot
9929       return
9930       end
9931 C--------------------------------------------------------------------------
9932 c MODELLER restraint function
9933       subroutine e_modeller(ehomology_constr)
9934       implicit real*8 (a-h,o-z)
9935       include 'DIMENSIONS'
9936       integer nnn, i, j, k, ki, irec, l
9937       integer katy, odleglosci, test7
9938       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
9939       real*8 distance(max_template),distancek(max_template),
9940      &    min_odl,godl(max_template),dih_diff(max_template)
9941
9942 c
9943 c     FP - 30/10/2014 Temporary specifications for homology restraints
9944 c
9945       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
9946      &                 sgtheta
9947       double precision, dimension (maxres) :: guscdiff,usc_diff
9948       double precision, dimension (max_template) ::
9949      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
9950      &           theta_diff
9951
9952       include 'COMMON.SBRIDGE'
9953       include 'COMMON.CHAIN'
9954       include 'COMMON.GEO'
9955       include 'COMMON.DERIV'
9956       include 'COMMON.LOCAL'
9957       include 'COMMON.INTERACT'
9958       include 'COMMON.VAR'
9959       include 'COMMON.IOUNITS'
9960       include 'COMMON.CONTROL'
9961       include 'COMMON.HOMRESTR'
9962       include 'COMMON.HOMOLOGY'
9963       include 'COMMON.SETUP'
9964       include 'COMMON.NAMES'
9965
9966       do i=1,max_template
9967         distancek(i)=9999999.9
9968       enddo
9969
9970       odleg=0.0d0
9971
9972 c Pseudo-energy and gradient from homology restraints (MODELLER-like
9973 c function)
9974 C AL 5/2/14 - Introduce list of restraints
9975 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
9976 #ifdef DEBUG
9977       write(iout,*) "------- dist restrs start -------"
9978 #endif
9979       do ii = link_start_homo,link_end_homo
9980          i = ires_homo(ii)
9981          j = jres_homo(ii)
9982          dij=dist(i,j)
9983 c        write (iout,*) "dij(",i,j,") =",dij
9984          nexl=0
9985          do k=1,constr_homology
9986            if(.not.l_homo(k,ii)) then
9987               nexl=nexl+1
9988               cycle
9989            endif
9990            distance(k)=odl(k,ii)-dij
9991 c          write (iout,*) "distance(",k,") =",distance(k)
9992 c
9993 c          For Gaussian-type Urestr
9994 c
9995            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
9996 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
9997 c          write (iout,*) "distancek(",k,") =",distancek(k)
9998 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
9999 c
10000 c          For Lorentzian-type Urestr
10001 c
10002            if (waga_dist.lt.0.0d0) then
10003               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10004               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10005      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10006            endif
10007          enddo
10008
10009 c         min_odl=minval(distancek)
10010          if (nexl.gt.0) then
10011            min_odl=0.0d0
10012          else
10013            do kk=1,constr_homology
10014             if(l_homo(kk,ii)) then
10015               min_odl=distancek(kk)
10016               exit
10017             endif
10018            enddo
10019            do kk=1,constr_homology
10020             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10021      &              min_odl=distancek(kk)
10022            enddo
10023          endif
10024 c        write (iout,* )"min_odl",min_odl
10025 #ifdef DEBUG
10026          write (iout,*) "ij dij",i,j,dij
10027          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10028          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10029          write (iout,* )"min_odl",min_odl
10030 #endif
10031 #ifdef OLDRESTR
10032          odleg2=0.0d0
10033 #else
10034          if (waga_dist.ge.0.0d0) then
10035            odleg2=nexl
10036          else
10037            odleg2=0.0d0
10038          endif
10039 #endif
10040          do k=1,constr_homology
10041 c Nie wiem po co to liczycie jeszcze raz!
10042 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10043 c     &              (2*(sigma_odl(i,j,k))**2))
10044            if(.not.l_homo(k,ii)) cycle
10045            if (waga_dist.ge.0.0d0) then
10046 c
10047 c          For Gaussian-type Urestr
10048 c
10049             godl(k)=dexp(-distancek(k)+min_odl)
10050             odleg2=odleg2+godl(k)
10051 c
10052 c          For Lorentzian-type Urestr
10053 c
10054            else
10055             odleg2=odleg2+distancek(k)
10056            endif
10057
10058 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10059 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10060 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10061 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10062
10063          enddo
10064 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10065 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10066 #ifdef DEBUG
10067          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10068          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10069 #endif
10070            if (waga_dist.ge.0.0d0) then
10071 c
10072 c          For Gaussian-type Urestr
10073 c
10074               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10075 c
10076 c          For Lorentzian-type Urestr
10077 c
10078            else
10079               odleg=odleg+odleg2/constr_homology
10080            endif
10081 c
10082 #ifdef GRAD
10083 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10084 c Gradient
10085 c
10086 c          For Gaussian-type Urestr
10087 c
10088          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10089          sum_sgodl=0.0d0
10090          do k=1,constr_homology
10091 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10092 c     &           *waga_dist)+min_odl
10093 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10094 c
10095          if(.not.l_homo(k,ii)) cycle
10096          if (waga_dist.ge.0.0d0) then
10097 c          For Gaussian-type Urestr
10098 c
10099            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10100 c
10101 c          For Lorentzian-type Urestr
10102 c
10103          else
10104            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10105      &           sigma_odlir(k,ii)**2)**2)
10106          endif
10107            sum_sgodl=sum_sgodl+sgodl
10108
10109 c            sgodl2=sgodl2+sgodl
10110 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10111 c      write(iout,*) "constr_homology=",constr_homology
10112 c      write(iout,*) i, j, k, "TEST K"
10113          enddo
10114          if (waga_dist.ge.0.0d0) then
10115 c
10116 c          For Gaussian-type Urestr
10117 c
10118             grad_odl3=waga_homology(iset)*waga_dist
10119      &                *sum_sgodl/(sum_godl*dij)
10120 c
10121 c          For Lorentzian-type Urestr
10122 c
10123          else
10124 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10125 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10126             grad_odl3=-waga_homology(iset)*waga_dist*
10127      &                sum_sgodl/(constr_homology*dij)
10128          endif
10129 c
10130 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10131
10132
10133 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10134 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10135 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10136
10137 ccc      write(iout,*) godl, sgodl, grad_odl3
10138
10139 c          grad_odl=grad_odl+grad_odl3
10140
10141          do jik=1,3
10142             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10143 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10144 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10145 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10146             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10147             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10148 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10149 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10150 c         if (i.eq.25.and.j.eq.27) then
10151 c         write(iout,*) "jik",jik,"i",i,"j",j
10152 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10153 c         write(iout,*) "grad_odl3",grad_odl3
10154 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10155 c         write(iout,*) "ggodl",ggodl
10156 c         write(iout,*) "ghpbc(",jik,i,")",
10157 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10158 c     &                 ghpbc(jik,j)
10159 c         endif
10160          enddo
10161 #endif
10162 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10163 ccc     & dLOG(odleg2),"-odleg=", -odleg
10164
10165       enddo ! ii-loop for dist
10166 #ifdef DEBUG
10167       write(iout,*) "------- dist restrs end -------"
10168 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10169 c    &     waga_d.eq.1.0d0) call sum_gradient
10170 #endif
10171 c Pseudo-energy and gradient from dihedral-angle restraints from
10172 c homology templates
10173 c      write (iout,*) "End of distance loop"
10174 c      call flush(iout)
10175       kat=0.0d0
10176 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10177 #ifdef DEBUG
10178       write(iout,*) "------- dih restrs start -------"
10179       do i=idihconstr_start_homo,idihconstr_end_homo
10180         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10181       enddo
10182 #endif
10183       do i=idihconstr_start_homo,idihconstr_end_homo
10184         kat2=0.0d0
10185 c        betai=beta(i,i+1,i+2,i+3)
10186         betai = phi(i)
10187 c       write (iout,*) "betai =",betai
10188         do k=1,constr_homology
10189           dih_diff(k)=pinorm(dih(k,i)-betai)
10190 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10191 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10192 c     &                                   -(6.28318-dih_diff(i,k))
10193 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10194 c     &                                   6.28318+dih_diff(i,k)
10195 #ifdef OLD_DIHED
10196           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10197 #else
10198           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10199 #endif
10200 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10201           gdih(k)=dexp(kat3)
10202           kat2=kat2+gdih(k)
10203 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10204 c          write(*,*)""
10205         enddo
10206 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10207 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10208 #ifdef DEBUG
10209         write (iout,*) "i",i," betai",betai," kat2",kat2
10210         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10211 #endif
10212         if (kat2.le.1.0d-14) cycle
10213         kat=kat-dLOG(kat2/constr_homology)
10214 c       write (iout,*) "kat",kat ! sum of -ln-s
10215
10216 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10217 ccc     & dLOG(kat2), "-kat=", -kat
10218
10219 #ifdef GRAD
10220 c ----------------------------------------------------------------------
10221 c Gradient
10222 c ----------------------------------------------------------------------
10223
10224         sum_gdih=kat2
10225         sum_sgdih=0.0d0
10226         do k=1,constr_homology
10227 #ifdef OLD_DIHED
10228           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10229 #else
10230           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10231 #endif
10232 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10233           sum_sgdih=sum_sgdih+sgdih
10234         enddo
10235 c       grad_dih3=sum_sgdih/sum_gdih
10236         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10237
10238 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10239 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10240 ccc     & gloc(nphi+i-3,icg)
10241         gloc(i,icg)=gloc(i,icg)+grad_dih3
10242 c        if (i.eq.25) then
10243 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10244 c        endif
10245 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10246 ccc     & gloc(nphi+i-3,icg)
10247 #endif
10248       enddo ! i-loop for dih
10249 #ifdef DEBUG
10250       write(iout,*) "------- dih restrs end -------"
10251 #endif
10252
10253 c Pseudo-energy and gradient for theta angle restraints from
10254 c homology templates
10255 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10256 c adapted
10257
10258 c
10259 c     For constr_homology reference structures (FP)
10260 c
10261 c     Uconst_back_tot=0.0d0
10262       Eval=0.0d0
10263       Erot=0.0d0
10264 c     Econstr_back legacy
10265 #ifdef GRAD
10266       do i=1,nres
10267 c     do i=ithet_start,ithet_end
10268        dutheta(i)=0.0d0
10269 c     enddo
10270 c     do i=loc_start,loc_end
10271         do j=1,3
10272           duscdiff(j,i)=0.0d0
10273           duscdiffx(j,i)=0.0d0
10274         enddo
10275       enddo
10276 #endif
10277 c
10278 c     do iref=1,nref
10279 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10280 c     write (iout,*) "waga_theta",waga_theta
10281       if (waga_theta.gt.0.0d0) then
10282 #ifdef DEBUG
10283       write (iout,*) "usampl",usampl
10284       write(iout,*) "------- theta restrs start -------"
10285 c     do i=ithet_start,ithet_end
10286 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10287 c     enddo
10288 #endif
10289 c     write (iout,*) "maxres",maxres,"nres",nres
10290
10291       do i=ithet_start,ithet_end
10292 c
10293 c     do i=1,nfrag_back
10294 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10295 c
10296 c Deviation of theta angles wrt constr_homology ref structures
10297 c
10298         utheta_i=0.0d0 ! argument of Gaussian for single k
10299         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10300 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10301 c       over residues in a fragment
10302 c       write (iout,*) "theta(",i,")=",theta(i)
10303         do k=1,constr_homology
10304 c
10305 c         dtheta_i=theta(j)-thetaref(j,iref)
10306 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10307           theta_diff(k)=thetatpl(k,i)-theta(i)
10308 c
10309           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10310 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10311           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10312           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10313 c         Gradient for single Gaussian restraint in subr Econstr_back
10314 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10315 c
10316         enddo
10317 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10318 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10319
10320 c
10321 #ifdef GRAD
10322 c         Gradient for multiple Gaussian restraint
10323         sum_gtheta=gutheta_i
10324         sum_sgtheta=0.0d0
10325         do k=1,constr_homology
10326 c        New generalized expr for multiple Gaussian from Econstr_back
10327          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10328 c
10329 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10330           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10331         enddo
10332 c
10333 c       Final value of gradient using same var as in Econstr_back
10334         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10335      &               *waga_homology(iset)
10336 c       dutheta(i)=sum_sgtheta/sum_gtheta
10337 c
10338 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10339 #endif
10340         Eval=Eval-dLOG(gutheta_i/constr_homology)
10341 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10342 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10343 c       Uconst_back=Uconst_back+utheta(i)
10344       enddo ! (i-loop for theta)
10345 #ifdef DEBUG
10346       write(iout,*) "------- theta restrs end -------"
10347 #endif
10348       endif
10349 c
10350 c Deviation of local SC geometry
10351 c
10352 c Separation of two i-loops (instructed by AL - 11/3/2014)
10353 c
10354 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10355 c     write (iout,*) "waga_d",waga_d
10356
10357 #ifdef DEBUG
10358       write(iout,*) "------- SC restrs start -------"
10359       write (iout,*) "Initial duscdiff,duscdiffx"
10360       do i=loc_start,loc_end
10361         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10362      &                 (duscdiffx(jik,i),jik=1,3)
10363       enddo
10364 #endif
10365       do i=loc_start,loc_end
10366         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10367         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10368 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10369 c       write(iout,*) "xxtab, yytab, zztab"
10370 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10371         do k=1,constr_homology
10372 c
10373           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10374 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10375           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10376           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10377 c         write(iout,*) "dxx, dyy, dzz"
10378 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10379 c
10380           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10381 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10382 c         uscdiffk(k)=usc_diff(i)
10383           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10384           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10385 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10386 c     &      xxref(j),yyref(j),zzref(j)
10387         enddo
10388 c
10389 c       Gradient
10390 c
10391 c       Generalized expression for multiple Gaussian acc to that for a single
10392 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10393 c
10394 c       Original implementation
10395 c       sum_guscdiff=guscdiff(i)
10396 c
10397 c       sum_sguscdiff=0.0d0
10398 c       do k=1,constr_homology
10399 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10400 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10401 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10402 c       enddo
10403 c
10404 c       Implementation of new expressions for gradient (Jan. 2015)
10405 c
10406 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10407 #ifdef GRAD
10408         do k=1,constr_homology
10409 c
10410 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10411 c       before. Now the drivatives should be correct
10412 c
10413           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10414 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10415           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10416           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10417 c
10418 c         New implementation
10419 c
10420           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10421      &                 sigma_d(k,i) ! for the grad wrt r'
10422 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10423 c
10424 c
10425 c        New implementation
10426          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10427          do jik=1,3
10428             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10429      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10430      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10431             duscdiff(jik,i)=duscdiff(jik,i)+
10432      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10433      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10434             duscdiffx(jik,i)=duscdiffx(jik,i)+
10435      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10436      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10437 c
10438 #ifdef DEBUG
10439              write(iout,*) "jik",jik,"i",i
10440              write(iout,*) "dxx, dyy, dzz"
10441              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10442              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10443 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10444 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10445 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10446 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10447 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10448 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10449 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10450 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10451 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10452 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10453 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10454 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10455 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10456 c            endif
10457 #endif
10458          enddo
10459         enddo
10460 #endif
10461 c
10462 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10463 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10464 c
10465 c        write (iout,*) i," uscdiff",uscdiff(i)
10466 c
10467 c Put together deviations from local geometry
10468
10469 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10470 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10471         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10472 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10473 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10474 c       Uconst_back=Uconst_back+usc_diff(i)
10475 c
10476 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10477 c
10478 c     New implment: multiplied by sum_sguscdiff
10479 c
10480
10481       enddo ! (i-loop for dscdiff)
10482
10483 c      endif
10484
10485 #ifdef DEBUG
10486       write(iout,*) "------- SC restrs end -------"
10487         write (iout,*) "------ After SC loop in e_modeller ------"
10488         do i=loc_start,loc_end
10489          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10490          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10491         enddo
10492       if (waga_theta.eq.1.0d0) then
10493       write (iout,*) "in e_modeller after SC restr end: dutheta"
10494       do i=ithet_start,ithet_end
10495         write (iout,*) i,dutheta(i)
10496       enddo
10497       endif
10498       if (waga_d.eq.1.0d0) then
10499       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10500       do i=1,nres
10501         write (iout,*) i,(duscdiff(j,i),j=1,3)
10502         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10503       enddo
10504       endif
10505 #endif
10506
10507 c Total energy from homology restraints
10508 #ifdef DEBUG
10509       write (iout,*) "odleg",odleg," kat",kat
10510       write (iout,*) "odleg",odleg," kat",kat
10511       write (iout,*) "Eval",Eval," Erot",Erot
10512       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10513       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10514       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10515 #endif
10516 c
10517 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10518 c
10519 c     ehomology_constr=odleg+kat
10520 c
10521 c     For Lorentzian-type Urestr
10522 c
10523
10524       if (waga_dist.ge.0.0d0) then
10525 c
10526 c          For Gaussian-type Urestr
10527 c
10528 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10529 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10530         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10531      &              waga_theta*Eval+waga_d*Erot
10532 c     write (iout,*) "ehomology_constr=",ehomology_constr
10533       else
10534 c
10535 c          For Lorentzian-type Urestr
10536 c
10537 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10538 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10539         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10540      &              waga_theta*Eval+waga_d*Erot
10541 c     write (iout,*) "ehomology_constr=",ehomology_constr
10542       endif
10543 #ifdef DEBUG
10544       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10545      & "Eval",waga_theta,eval,
10546      &   "Erot",waga_d,Erot
10547       write (iout,*) "ehomology_constr",ehomology_constr
10548 #endif
10549       return
10550
10551   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10552   747 format(a12,i4,i4,i4,f8.3,f8.3)
10553   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10554   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10555   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10556      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10557       end