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       j=i+3
3548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3549 C
3550 C               Fourth-order contributions
3551 C
3552 C                 (i+3)o----(i+4)
3553 C                     /  |
3554 C               (i+2)o   |
3555 C                     \  |
3556 C                 (i+1)o----i
3557 C
3558 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3559 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3560 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3561 c        write(iout,*)"WCHODZE W PROGRAM"
3562         a_temp(1,1)=a22
3563         a_temp(1,2)=a23
3564         a_temp(2,1)=a32
3565         a_temp(2,2)=a33
3566         iti1=itype2loc(itype(i+1))
3567         iti2=itype2loc(itype(i+2))
3568         iti3=itype2loc(itype(i+3))
3569 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3570         call transpose2(EUg(1,1,i+1),e1t(1,1))
3571         call transpose2(Eug(1,1,i+2),e2t(1,1))
3572         call transpose2(Eug(1,1,i+3),e3t(1,1))
3573 C Ematrix derivative in theta
3574         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3575         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3576         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3577         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3578 c       eta1 in derivative theta
3579         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3580         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3581 c       auxgvec is derivative of Ub2 so i+3 theta
3582         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3583 c       auxalary matrix of E i+1
3584         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3585 c        s1=0.0
3586 c        gs1=0.0
3587         s1=scalar2(b1(1,i+2),auxvec(1))
3588 c derivative of theta i+2 with constant i+3
3589         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3590 c derivative of theta i+2 with constant i+2
3591         gs32=scalar2(b1(1,i+2),auxgvec(1))
3592 c derivative of E matix in theta of i+1
3593         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3594
3595         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3596 c       ea31 in derivative theta
3597         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3598         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3599 c auxilary matrix auxgvec of Ub2 with constant E matirx
3600         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3601 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3602         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3603
3604 c        s2=0.0
3605 c        gs2=0.0
3606         s2=scalar2(b1(1,i+1),auxvec(1))
3607 c derivative of theta i+1 with constant i+3
3608         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3609 c derivative of theta i+2 with constant i+1
3610         gs21=scalar2(b1(1,i+1),auxgvec(1))
3611 c derivative of theta i+3 with constant i+1
3612         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3613 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3614 c     &  gtb1(1,i+1)
3615         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3616 c two derivatives over diffetent matrices
3617 c gtae3e2 is derivative over i+3
3618         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3619 c ae3gte2 is derivative over i+2
3620         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3621         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3622 c three possible derivative over theta E matices
3623 c i+1
3624         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3625 c i+2
3626         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3627 c i+3
3628         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3629         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3630
3631         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3632         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3633         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3634         if (shield_mode.eq.0) then
3635         fac_shield(i)=1.0
3636         fac_shield(j)=1.0
3637 C        else
3638 C        fac_shield(i)=0.6
3639 C        fac_shield(j)=0.4
3640         endif
3641         eello_turn4=eello_turn4-(s1+s2+s3)
3642      &  *fac_shield(i)*fac_shield(j)*faclipij
3643         eello_t4=-(s1+s2+s3)
3644      &  *fac_shield(i)*fac_shield(j)
3645 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3646         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3647      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3648 C Now derivative over shield:
3649           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3650      &  (shield_mode.gt.0)) then
3651 C          print *,i,j
3652
3653           do ilist=1,ishield_list(i)
3654            iresshield=shield_list(ilist,i)
3655            do k=1,3
3656            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3657 C     &      *2.0
3658            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3659      &              rlocshield
3660      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3661             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3662      &      +rlocshield
3663            enddo
3664           enddo
3665           do ilist=1,ishield_list(j)
3666            iresshield=shield_list(ilist,j)
3667            do k=1,3
3668            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3669 C     &     *2.0
3670            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3671      &              rlocshield
3672      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3673            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3674      &             +rlocshield
3675
3676            enddo
3677           enddo
3678
3679           do k=1,3
3680             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3681      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3682             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3683      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3684             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3685      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3686             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3687      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3688            enddo
3689            endif
3690 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3691 cd     &    ' eello_turn4_num',8*eello_turn4_num
3692 #ifdef NEWCORR
3693         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3694      &                  -(gs13+gsE13+gsEE1)*wturn4
3695      &  *fac_shield(i)*fac_shield(j)
3696         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3697      &                    -(gs23+gs21+gsEE2)*wturn4
3698      &  *fac_shield(i)*fac_shield(j)
3699
3700         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3701      &                    -(gs32+gsE31+gsEE3)*wturn4
3702      &  *fac_shield(i)*fac_shield(j)
3703
3704 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3705 c     &   gs2
3706 #endif
3707         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3708      &      'eturn4',i,j,-(s1+s2+s3)
3709 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3710 c     &    ' eello_turn4_num',8*eello_turn4_num
3711 C Derivatives in gamma(i)
3712         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3713         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3714         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3715         s1=scalar2(b1(1,i+2),auxvec(1))
3716         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3717         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3718         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3719      &  *fac_shield(i)*fac_shield(j)*faclipij
3720 C Derivatives in gamma(i+1)
3721         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3722         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3723         s2=scalar2(b1(1,i+1),auxvec(1))
3724         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3725         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3726         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3727         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3728      &  *fac_shield(i)*fac_shield(j)*faclipij
3729 C Derivatives in gamma(i+2)
3730         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3731         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3732         s1=scalar2(b1(1,i+2),auxvec(1))
3733         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3734         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3735         s2=scalar2(b1(1,i+1),auxvec(1))
3736         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3737         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3738         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3739         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3740      &  *fac_shield(i)*fac_shield(j)*faclipij
3741         if (calc_grad) then
3742 C Cartesian derivatives
3743 C Derivatives of this turn contributions in DC(i+2)
3744         if (j.lt.nres-1) then
3745           do l=1,3
3746             a_temp(1,1)=agg(l,1)
3747             a_temp(1,2)=agg(l,2)
3748             a_temp(2,1)=agg(l,3)
3749             a_temp(2,2)=agg(l,4)
3750             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3751             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3752             s1=scalar2(b1(1,i+2),auxvec(1))
3753             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3754             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3755             s2=scalar2(b1(1,i+1),auxvec(1))
3756             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3757             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3758             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3759             ggg(l)=-(s1+s2+s3)
3760             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3761      &  *fac_shield(i)*fac_shield(j)*faclipij
3762           enddo
3763         endif
3764 C Remaining derivatives of this turn contribution
3765         do l=1,3
3766           a_temp(1,1)=aggi(l,1)
3767           a_temp(1,2)=aggi(l,2)
3768           a_temp(2,1)=aggi(l,3)
3769           a_temp(2,2)=aggi(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,i+2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,i+1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3780      &  *fac_shield(i)*fac_shield(j)*faclipij
3781           a_temp(1,1)=aggi1(l,1)
3782           a_temp(1,2)=aggi1(l,2)
3783           a_temp(2,1)=aggi1(l,3)
3784           a_temp(2,2)=aggi1(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,i+2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,i+1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3795      &  *fac_shield(i)*fac_shield(j)*faclipij
3796           a_temp(1,1)=aggj(l,1)
3797           a_temp(1,2)=aggj(l,2)
3798           a_temp(2,1)=aggj(l,3)
3799           a_temp(2,2)=aggj(l,4)
3800           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3801           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3802           s1=scalar2(b1(1,i+2),auxvec(1))
3803           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3804           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3805           s2=scalar2(b1(1,i+1),auxvec(1))
3806           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3807           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3808           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3809           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3810      &  *fac_shield(i)*fac_shield(j)*faclipij
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3816           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3817           s1=scalar2(b1(1,i+2),auxvec(1))
3818           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3819           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3820           s2=scalar2(b1(1,i+1),auxvec(1))
3821           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3822           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3823           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3824 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3825           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3826      &  *fac_shield(i)*fac_shield(j)*faclipij
3827         enddo
3828
3829         endif ! calc_grad
3830
3831       return
3832       end
3833 C-----------------------------------------------------------------------------
3834       subroutine vecpr(u,v,w)
3835       implicit real*8(a-h,o-z)
3836       dimension u(3),v(3),w(3)
3837       w(1)=u(2)*v(3)-u(3)*v(2)
3838       w(2)=-u(1)*v(3)+u(3)*v(1)
3839       w(3)=u(1)*v(2)-u(2)*v(1)
3840       return
3841       end
3842 C-----------------------------------------------------------------------------
3843       subroutine unormderiv(u,ugrad,unorm,ungrad)
3844 C This subroutine computes the derivatives of a normalized vector u, given
3845 C the derivatives computed without normalization conditions, ugrad. Returns
3846 C ungrad.
3847       implicit none
3848       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3849       double precision vec(3)
3850       double precision scalar
3851       integer i,j
3852 c      write (2,*) 'ugrad',ugrad
3853 c      write (2,*) 'u',u
3854       do i=1,3
3855         vec(i)=scalar(ugrad(1,i),u(1))
3856       enddo
3857 c      write (2,*) 'vec',vec
3858       do i=1,3
3859         do j=1,3
3860           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3861         enddo
3862       enddo
3863 c      write (2,*) 'ungrad',ungrad
3864       return
3865       end
3866 C-----------------------------------------------------------------------------
3867       subroutine escp(evdw2,evdw2_14)
3868 C
3869 C This subroutine calculates the excluded-volume interaction energy between
3870 C peptide-group centers and side chains and its gradient in virtual-bond and
3871 C side-chain vectors.
3872 C
3873       implicit real*8 (a-h,o-z)
3874       include 'DIMENSIONS'
3875       include 'COMMON.GEO'
3876       include 'COMMON.VAR'
3877       include 'COMMON.LOCAL'
3878       include 'COMMON.CHAIN'
3879       include 'COMMON.DERIV'
3880       include 'COMMON.INTERACT'
3881       include 'COMMON.FFIELD'
3882       include 'COMMON.IOUNITS'
3883       dimension ggg(3)
3884       evdw2=0.0D0
3885       evdw2_14=0.0d0
3886 cd    print '(a)','Enter ESCP'
3887 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3888 c     &  ' scal14',scal14
3889       do i=iatscp_s,iatscp_e
3890         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3891         iteli=itel(i)
3892 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3893 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3894         if (iteli.eq.0) goto 1225
3895         xi=0.5D0*(c(1,i)+c(1,i+1))
3896         yi=0.5D0*(c(2,i)+c(2,i+1))
3897         zi=0.5D0*(c(3,i)+c(3,i+1))
3898 C Returning the ith atom to box
3899         call to_box(xi,yi,zi)
3900         do iint=1,nscp_gr(i)
3901
3902         do j=iscpstart(i,iint),iscpend(i,iint)
3903           itypj=iabs(itype(j))
3904           if (itypj.eq.ntyp1) cycle
3905 C Uncomment following three lines for SC-p interactions
3906 c         xj=c(1,nres+j)-xi
3907 c         yj=c(2,nres+j)-yi
3908 c         zj=c(3,nres+j)-zi
3909 C Uncomment following three lines for Ca-p interactions
3910           xj=c(1,j)
3911           yj=c(2,j)
3912           zj=c(3,j)
3913 C returning the jth atom to box
3914           call to_box(xj,yj,zj)
3915           xj=boxshift(xj-xi,boxxsize)
3916           yj=boxshift(yj-yi,boxysize)
3917           zj=boxshift(zj-zi,boxzsize)
3918           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3919 C sss is scaling function for smoothing the cutoff gradient otherwise
3920 C the gradient would not be continuouse
3921           sss=sscale(1.0d0/(dsqrt(rrij)))
3922           if (sss.le.0.0d0) cycle
3923           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3924           fac=rrij**expon2
3925           e1=fac*fac*aad(itypj,iteli)
3926           e2=fac*bad(itypj,iteli)
3927           if (iabs(j-i) .le. 2) then
3928             e1=scal14*e1
3929             e2=scal14*e2
3930             evdw2_14=evdw2_14+(e1+e2)*sss
3931           endif
3932           evdwij=e1+e2
3933 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3934 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3935 c     &       bad(itypj,iteli)
3936           evdw2=evdw2+evdwij*sss
3937           if (calc_grad) then
3938 C
3939 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3940 C
3941           fac=-(evdwij+e1)*rrij*sss
3942           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3943           ggg(1)=xj*fac
3944           ggg(2)=yj*fac
3945           ggg(3)=zj*fac
3946           if (j.lt.i) then
3947 cd          write (iout,*) 'j<i'
3948 C Uncomment following three lines for SC-p interactions
3949 c           do k=1,3
3950 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3951 c           enddo
3952           else
3953 cd          write (iout,*) 'j>i'
3954             do k=1,3
3955               ggg(k)=-ggg(k)
3956 C Uncomment following line for SC-p interactions
3957 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3958             enddo
3959           endif
3960           do k=1,3
3961             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3962           enddo
3963           kstart=min0(i+1,j)
3964           kend=max0(i-1,j-1)
3965 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3966 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3967           do k=kstart,kend
3968             do l=1,3
3969               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3970             enddo
3971           enddo
3972           endif ! calc_grad
3973         enddo
3974         enddo ! iint
3975  1225   continue
3976       enddo ! i
3977       do i=1,nct
3978         do j=1,3
3979           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3980           gradx_scp(j,i)=expon*gradx_scp(j,i)
3981         enddo
3982       enddo
3983 C******************************************************************************
3984 C
3985 C                              N O T E !!!
3986 C
3987 C To save time the factor EXPON has been extracted from ALL components
3988 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3989 C use!
3990 C
3991 C******************************************************************************
3992       return
3993       end
3994 C--------------------------------------------------------------------------
3995       subroutine edis(ehpb)
3996 C
3997 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3998 C
3999       implicit real*8 (a-h,o-z)
4000       include 'DIMENSIONS'
4001       include 'COMMON.SBRIDGE'
4002       include 'COMMON.CHAIN'
4003       include 'COMMON.DERIV'
4004       include 'COMMON.VAR'
4005       include 'COMMON.INTERACT'
4006       include 'COMMON.CONTROL'
4007       include 'COMMON.IOUNITS'
4008       dimension ggg(3),ggg_peak(3,1000)
4009       ehpb=0.0D0
4010       ggg=0.0d0
4011 c 8/21/18 AL: added explicit restraints on reference coords
4012 c      write (iout,*) "restr_on_coord",restr_on_coord
4013       if (restr_on_coord) then
4014
4015       do i=nnt,nct
4016         ecoor=0.0d0
4017         if (itype(i).eq.ntyp1) cycle
4018         do j=1,3
4019           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4020           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4021         enddo
4022         if (itype(i).ne.10) then
4023           do j=1,3
4024             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4025             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4026           enddo
4027         endif
4028         if (energy_dec) write (iout,*)
4029      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4030         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4031       enddo
4032
4033       endif
4034 C      write (iout,*) ,"link_end",link_end,constr_dist
4035 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4036 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4037 c     &  " constr_dist",constr_dist
4038       if (link_end.eq.0.and.link_end_peak.eq.0) return
4039       do i=link_start_peak,link_end_peak
4040         ehpb_peak=0.0d0
4041 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4042 c     &   ipeak(1,i),ipeak(2,i)
4043         do ip=ipeak(1,i),ipeak(2,i)
4044           ii=ihpb_peak(ip)
4045           jj=jhpb_peak(ip)
4046           dd=dist(ii,jj)
4047           iip=ip-ipeak(1,i)+1
4048 C iii and jjj point to the residues for which the distance is assigned.
4049 c          if (ii.gt.nres) then
4050 c            iii=ii-nres
4051 c            jjj=jj-nres
4052 c          else
4053 c            iii=ii
4054 c            jjj=jj
4055 c          endif
4056           if (ii.gt.nres) then
4057             iii=ii-nres
4058           else
4059             iii=ii
4060           endif
4061           if (jj.gt.nres) then
4062             jjj=jj-nres
4063           else
4064             jjj=jj
4065           endif
4066           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4067           aux=dexp(-scal_peak*aux)
4068           ehpb_peak=ehpb_peak+aux
4069           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4070      &      forcon_peak(ip))*aux/dd
4071           do j=1,3
4072             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4073           enddo
4074           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4075      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4076      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4077         enddo
4078 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4079         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4080         do ip=ipeak(1,i),ipeak(2,i)
4081           iip=ip-ipeak(1,i)+1
4082           do j=1,3
4083             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4084           enddo
4085           ii=ihpb_peak(ip)
4086           jj=jhpb_peak(ip)
4087 C iii and jjj point to the residues for which the distance is assigned.
4088 c          if (ii.gt.nres) then
4089 c            iii=ii-nres
4090 c            jjj=jj-nres
4091 c          else
4092 c            iii=ii
4093 c            jjj=jj
4094 c          endif
4095           if (ii.gt.nres) then
4096             iii=ii-nres
4097           else
4098             iii=ii
4099           endif
4100           if (jj.gt.nres) then
4101             jjj=jj-nres
4102           else
4103             jjj=jj
4104           endif
4105           if (iii.lt.ii) then
4106             do j=1,3
4107               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4108             enddo
4109           endif
4110           if (jjj.lt.jj) then
4111             do j=1,3
4112               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4113             enddo
4114           endif
4115           do k=1,3
4116             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4117             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4118           enddo
4119         enddo
4120       enddo
4121       do i=link_start,link_end
4122 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4123 C CA-CA distance used in regularization of structure.
4124         ii=ihpb(i)
4125         jj=jhpb(i)
4126 C iii and jjj point to the residues for which the distance is assigned.
4127 c        if (ii.gt.nres) then
4128 c          iii=ii-nres
4129 c          jjj=jj-nres
4130 c        else
4131 c          iii=ii
4132 c          jjj=jj
4133 c        endif
4134         if (ii.gt.nres) then
4135           iii=ii-nres
4136         else
4137           iii=ii
4138         endif
4139         if (jj.gt.nres) then
4140           jjj=jj-nres
4141         else
4142           jjj=jj
4143         endif
4144 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4145 c     &    dhpb(i),dhpb1(i),forcon(i)
4146 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4147 C    distance and angle dependent SS bond potential.
4148 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4149 C     & iabs(itype(jjj)).eq.1) then
4150 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4151 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4152         if (.not.dyn_ss .and. i.le.nss) then
4153 C 15/02/13 CC dynamic SSbond - additional check
4154           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4155      &        iabs(itype(jjj)).eq.1) then
4156            call ssbond_ene(iii,jjj,eij)
4157            ehpb=ehpb+2*eij
4158          endif
4159 cd          write (iout,*) "eij",eij
4160 cd   &   ' waga=',waga,' fac=',fac
4161 !        else if (ii.gt.nres .and. jj.gt.nres) then
4162         else
4163 C Calculate the distance between the two points and its difference from the
4164 C target distance.
4165           dd=dist(ii,jj)
4166           if (irestr_type(i).eq.11) then
4167             ehpb=ehpb+fordepth(i)!**4.0d0
4168      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4169             fac=fordepth(i)!**4.0d0
4170      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4171             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4172      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4173      &        ehpb,irestr_type(i)
4174           else if (irestr_type(i).eq.10) then
4175 c AL 6//19/2018 cross-link restraints
4176             xdis = 0.5d0*(dd/forcon(i))**2
4177             expdis = dexp(-xdis)
4178 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4179             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4180 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4181 c     &          " wboltzd",wboltzd
4182             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4183 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4184             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4185      &           *expdis/(aux*forcon(i)**2)
4186             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4187      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4188      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4189           else if (irestr_type(i).eq.2) then
4190 c Quartic restraints
4191             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4192             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4193      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4194      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4195             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4196           else
4197 c Quadratic restraints
4198             rdis=dd-dhpb(i)
4199 C Get the force constant corresponding to this distance.
4200             waga=forcon(i)
4201 C Calculate the contribution to energy.
4202             ehpb=ehpb+0.5d0*waga*rdis*rdis
4203             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4204      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4205      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4206 C
4207 C Evaluate gradient.
4208 C
4209             fac=waga*rdis/dd
4210           endif
4211 c Calculate Cartesian gradient
4212           do j=1,3
4213             ggg(j)=fac*(c(j,jj)-c(j,ii))
4214           enddo
4215 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4216 C If this is a SC-SC distance, we need to calculate the contributions to the
4217 C Cartesian gradient in the SC vectors (ghpbx).
4218           if (iii.lt.ii) then
4219             do j=1,3
4220               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4221             enddo
4222           endif
4223           if (jjj.lt.jj) then
4224             do j=1,3
4225               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4226             enddo
4227           endif
4228           do k=1,3
4229             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4230             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4231           enddo
4232         endif
4233       enddo
4234       return
4235       end
4236 C--------------------------------------------------------------------------
4237       subroutine ssbond_ene(i,j,eij)
4238 C
4239 C Calculate the distance and angle dependent SS-bond potential energy
4240 C using a free-energy function derived based on RHF/6-31G** ab initio
4241 C calculations of diethyl disulfide.
4242 C
4243 C A. Liwo and U. Kozlowska, 11/24/03
4244 C
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'COMMON.SBRIDGE'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.DERIV'
4250       include 'COMMON.LOCAL'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.VAR'
4253       include 'COMMON.IOUNITS'
4254       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4255       itypi=iabs(itype(i))
4256       xi=c(1,nres+i)
4257       yi=c(2,nres+i)
4258       zi=c(3,nres+i)
4259       dxi=dc_norm(1,nres+i)
4260       dyi=dc_norm(2,nres+i)
4261       dzi=dc_norm(3,nres+i)
4262       dsci_inv=dsc_inv(itypi)
4263       itypj=iabs(itype(j))
4264       dscj_inv=dsc_inv(itypj)
4265       xj=c(1,nres+j)-xi
4266       yj=c(2,nres+j)-yi
4267       zj=c(3,nres+j)-zi
4268       dxj=dc_norm(1,nres+j)
4269       dyj=dc_norm(2,nres+j)
4270       dzj=dc_norm(3,nres+j)
4271       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4272       rij=dsqrt(rrij)
4273       erij(1)=xj*rij
4274       erij(2)=yj*rij
4275       erij(3)=zj*rij
4276       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4277       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4278       om12=dxi*dxj+dyi*dyj+dzi*dzj
4279       do k=1,3
4280         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4281         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4282       enddo
4283       rij=1.0d0/rij
4284       deltad=rij-d0cm
4285       deltat1=1.0d0-om1
4286       deltat2=1.0d0+om2
4287       deltat12=om2-om1+2.0d0
4288       cosphi=om12-om1*om2
4289       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4290      &  +akct*deltad*deltat12
4291      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4292 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4293 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4294 c     &  " deltat12",deltat12," eij",eij
4295       ed=2*akcm*deltad+akct*deltat12
4296       pom1=akct*deltad
4297       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4298       eom1=-2*akth*deltat1-pom1-om2*pom2
4299       eom2= 2*akth*deltat2+pom1-om1*pom2
4300       eom12=pom2
4301       do k=1,3
4302         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4303       enddo
4304       do k=1,3
4305         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4306      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4307         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4308      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4309       enddo
4310 C
4311 C Calculate the components of the gradient in DC and X
4312 C
4313       do k=i,j-1
4314         do l=1,3
4315           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4316         enddo
4317       enddo
4318       return
4319       end
4320 C--------------------------------------------------------------------------
4321       subroutine ebond(estr)
4322 c
4323 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4324 c
4325       implicit real*8 (a-h,o-z)
4326       include 'DIMENSIONS'
4327       include 'COMMON.LOCAL'
4328       include 'COMMON.GEO'
4329       include 'COMMON.INTERACT'
4330       include 'COMMON.DERIV'
4331       include 'COMMON.VAR'
4332       include 'COMMON.CHAIN'
4333       include 'COMMON.IOUNITS'
4334       include 'COMMON.NAMES'
4335       include 'COMMON.FFIELD'
4336       include 'COMMON.CONTROL'
4337       double precision u(3),ud(3)
4338       estr=0.0d0
4339       estr1=0.0d0
4340 c      write (iout,*) "distchainmax",distchainmax
4341       do i=nnt+1,nct
4342 #ifdef FIVEDIAG
4343         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4344         diff = vbld(i)-vbldp0
4345 #else
4346         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4347 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4348 C          do j=1,3
4349 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4350 C     &      *dc(j,i-1)/vbld(i)
4351 C          enddo
4352 C          if (energy_dec) write(iout,*)
4353 C     &       "estr1",i,vbld(i),distchainmax,
4354 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4355 C        else
4356          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4357         diff = vbld(i)-vbldpDUM
4358 C         write(iout,*) i,diff
4359          else
4360           diff = vbld(i)-vbldp0
4361 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4362          endif
4363 #endif
4364         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4365      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4366           estr=estr+diff*diff
4367           do j=1,3
4368             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4369           enddo
4370 C        endif
4371 C        write (iout,'(a7,i5,4f7.3)')
4372 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4373       enddo
4374       estr=0.5d0*AKP*estr+estr1
4375 c
4376 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4377 c
4378       do i=nnt,nct
4379         iti=iabs(itype(i))
4380         if (iti.ne.10 .and. iti.ne.ntyp1) then
4381           nbi=nbondterm(iti)
4382           if (nbi.eq.1) then
4383             diff=vbld(i+nres)-vbldsc0(1,iti)
4384             if (energy_dec) write (iout,*)
4385      &      i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4386      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4387             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4388             do j=1,3
4389               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4390             enddo
4391           else
4392             do j=1,nbi
4393               diff=vbld(i+nres)-vbldsc0(j,iti)
4394               ud(j)=aksc(j,iti)*diff
4395               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4396             enddo
4397             uprod=u(1)
4398             do j=2,nbi
4399               uprod=uprod*u(j)
4400             enddo
4401             usum=0.0d0
4402             usumsqder=0.0d0
4403             do j=1,nbi
4404               uprod1=1.0d0
4405               uprod2=1.0d0
4406               do k=1,nbi
4407                 if (k.ne.j) then
4408                   uprod1=uprod1*u(k)
4409                   uprod2=uprod2*u(k)*u(k)
4410                 endif
4411               enddo
4412               usum=usum+uprod1
4413               usumsqder=usumsqder+ud(j)*uprod2
4414             enddo
4415 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4416 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4417             estr=estr+uprod/usum
4418             do j=1,3
4419              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4420             enddo
4421           endif
4422         endif
4423       enddo
4424       return
4425       end
4426 #ifdef CRYST_THETA
4427 C--------------------------------------------------------------------------
4428       subroutine ebend(etheta,ethetacnstr)
4429 C
4430 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4431 C angles gamma and its derivatives in consecutive thetas and gammas.
4432 C
4433       implicit real*8 (a-h,o-z)
4434       include 'DIMENSIONS'
4435       include 'COMMON.LOCAL'
4436       include 'COMMON.GEO'
4437       include 'COMMON.INTERACT'
4438       include 'COMMON.DERIV'
4439       include 'COMMON.VAR'
4440       include 'COMMON.CHAIN'
4441       include 'COMMON.IOUNITS'
4442       include 'COMMON.NAMES'
4443       include 'COMMON.FFIELD'
4444       include 'COMMON.TORCNSTR'
4445       common /calcthet/ term1,term2,termm,diffak,ratak,
4446      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4447      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4448       double precision y(2),z(2)
4449       delta=0.02d0*pi
4450 c      time11=dexp(-2*time)
4451 c      time12=1.0d0
4452       etheta=0.0D0
4453 c      write (iout,*) "nres",nres
4454 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4455 c      write (iout,*) ithet_start,ithet_end
4456       do i=ithet_start,ithet_end
4457 C        if (itype(i-1).eq.ntyp1) cycle
4458         if (i.le.2) cycle
4459         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4460      &  .or.itype(i).eq.ntyp1) cycle
4461 C Zero the energy function and its derivative at 0 or pi.
4462         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4463         it=itype(i-1)
4464         ichir1=isign(1,itype(i-2))
4465         ichir2=isign(1,itype(i))
4466          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4467          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4468          if (itype(i-1).eq.10) then
4469           itype1=isign(10,itype(i-2))
4470           ichir11=isign(1,itype(i-2))
4471           ichir12=isign(1,itype(i-2))
4472           itype2=isign(10,itype(i))
4473           ichir21=isign(1,itype(i))
4474           ichir22=isign(1,itype(i))
4475          endif
4476          if (i.eq.3) then
4477           y(1)=0.0D0
4478           y(2)=0.0D0
4479           else
4480
4481         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4482 #ifdef OSF
4483           phii=phi(i)
4484 c          icrc=0
4485 c          call proc_proc(phii,icrc)
4486           if (icrc.eq.1) phii=150.0
4487 #else
4488           phii=phi(i)
4489 #endif
4490           y(1)=dcos(phii)
4491           y(2)=dsin(phii)
4492         else
4493           y(1)=0.0D0
4494           y(2)=0.0D0
4495         endif
4496         endif
4497         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4498 #ifdef OSF
4499           phii1=phi(i+1)
4500 c          icrc=0
4501 c          call proc_proc(phii1,icrc)
4502           if (icrc.eq.1) phii1=150.0
4503           phii1=pinorm(phii1)
4504           z(1)=cos(phii1)
4505 #else
4506           phii1=phi(i+1)
4507           z(1)=dcos(phii1)
4508 #endif
4509           z(2)=dsin(phii1)
4510         else
4511           z(1)=0.0D0
4512           z(2)=0.0D0
4513         endif
4514 C Calculate the "mean" value of theta from the part of the distribution
4515 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4516 C In following comments this theta will be referred to as t_c.
4517         thet_pred_mean=0.0d0
4518         do k=1,2
4519             athetk=athet(k,it,ichir1,ichir2)
4520             bthetk=bthet(k,it,ichir1,ichir2)
4521           if (it.eq.10) then
4522              athetk=athet(k,itype1,ichir11,ichir12)
4523              bthetk=bthet(k,itype2,ichir21,ichir22)
4524           endif
4525           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4526         enddo
4527 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4528         dthett=thet_pred_mean*ssd
4529         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4530 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4531 C Derivatives of the "mean" values in gamma1 and gamma2.
4532         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4533      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4534          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4535      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4536          if (it.eq.10) then
4537       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4538      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4539         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4540      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4541          endif
4542         if (theta(i).gt.pi-delta) then
4543           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4544      &         E_tc0)
4545           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4546           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4547           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4548      &        E_theta)
4549           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4550      &        E_tc)
4551         else if (theta(i).lt.delta) then
4552           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4553           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4554           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4555      &        E_theta)
4556           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4557           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4558      &        E_tc)
4559         else
4560           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4561      &        E_theta,E_tc)
4562         endif
4563         etheta=etheta+ethetai
4564 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4565 c     &      'ebend',i,ethetai,theta(i),itype(i)
4566 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4567 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4568         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4569         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4570         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4571 c 1215   continue
4572       enddo
4573       ethetacnstr=0.0d0
4574 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4575       do i=1,ntheta_constr
4576         itheta=itheta_constr(i)
4577         thetiii=theta(itheta)
4578         difi=pinorm(thetiii-theta_constr0(i))
4579         if (difi.gt.theta_drange(i)) then
4580           difi=difi-theta_drange(i)
4581           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4582           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4583      &    +for_thet_constr(i)*difi**3
4584         else if (difi.lt.-drange(i)) then
4585           difi=difi+drange(i)
4586           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4587           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4588      &    +for_thet_constr(i)*difi**3
4589         else
4590           difi=0.0
4591         endif
4592 C       if (energy_dec) then
4593 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4594 C     &    i,itheta,rad2deg*thetiii,
4595 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4596 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4597 C     &    gloc(itheta+nphi-2,icg)
4598 C        endif
4599       enddo
4600 C Ufff.... We've done all this!!!
4601       return
4602       end
4603 C---------------------------------------------------------------------------
4604       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4605      &     E_tc)
4606       implicit real*8 (a-h,o-z)
4607       include 'DIMENSIONS'
4608       include 'COMMON.LOCAL'
4609       include 'COMMON.IOUNITS'
4610       common /calcthet/ term1,term2,termm,diffak,ratak,
4611      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4612      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4613 C Calculate the contributions to both Gaussian lobes.
4614 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4615 C The "polynomial part" of the "standard deviation" of this part of
4616 C the distribution.
4617         sig=polthet(3,it)
4618         do j=2,0,-1
4619           sig=sig*thet_pred_mean+polthet(j,it)
4620         enddo
4621 C Derivative of the "interior part" of the "standard deviation of the"
4622 C gamma-dependent Gaussian lobe in t_c.
4623         sigtc=3*polthet(3,it)
4624         do j=2,1,-1
4625           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4626         enddo
4627         sigtc=sig*sigtc
4628 C Set the parameters of both Gaussian lobes of the distribution.
4629 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4630         fac=sig*sig+sigc0(it)
4631         sigcsq=fac+fac
4632         sigc=1.0D0/sigcsq
4633 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4634         sigsqtc=-4.0D0*sigcsq*sigtc
4635 c       print *,i,sig,sigtc,sigsqtc
4636 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4637         sigtc=-sigtc/(fac*fac)
4638 C Following variable is sigma(t_c)**(-2)
4639         sigcsq=sigcsq*sigcsq
4640         sig0i=sig0(it)
4641         sig0inv=1.0D0/sig0i**2
4642         delthec=thetai-thet_pred_mean
4643         delthe0=thetai-theta0i
4644         term1=-0.5D0*sigcsq*delthec*delthec
4645         term2=-0.5D0*sig0inv*delthe0*delthe0
4646 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4647 C NaNs in taking the logarithm. We extract the largest exponent which is added
4648 C to the energy (this being the log of the distribution) at the end of energy
4649 C term evaluation for this virtual-bond angle.
4650         if (term1.gt.term2) then
4651           termm=term1
4652           term2=dexp(term2-termm)
4653           term1=1.0d0
4654         else
4655           termm=term2
4656           term1=dexp(term1-termm)
4657           term2=1.0d0
4658         endif
4659 C The ratio between the gamma-independent and gamma-dependent lobes of
4660 C the distribution is a Gaussian function of thet_pred_mean too.
4661         diffak=gthet(2,it)-thet_pred_mean
4662         ratak=diffak/gthet(3,it)**2
4663         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4664 C Let's differentiate it in thet_pred_mean NOW.
4665         aktc=ak*ratak
4666 C Now put together the distribution terms to make complete distribution.
4667         termexp=term1+ak*term2
4668         termpre=sigc+ak*sig0i
4669 C Contribution of the bending energy from this theta is just the -log of
4670 C the sum of the contributions from the two lobes and the pre-exponential
4671 C factor. Simple enough, isn't it?
4672         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4673 C NOW the derivatives!!!
4674 C 6/6/97 Take into account the deformation.
4675         E_theta=(delthec*sigcsq*term1
4676      &       +ak*delthe0*sig0inv*term2)/termexp
4677         E_tc=((sigtc+aktc*sig0i)/termpre
4678      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4679      &       aktc*term2)/termexp)
4680       return
4681       end
4682 c-----------------------------------------------------------------------------
4683       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4684       implicit real*8 (a-h,o-z)
4685       include 'DIMENSIONS'
4686       include 'COMMON.LOCAL'
4687       include 'COMMON.IOUNITS'
4688       common /calcthet/ term1,term2,termm,diffak,ratak,
4689      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4690      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4691       delthec=thetai-thet_pred_mean
4692       delthe0=thetai-theta0i
4693 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4694       t3 = thetai-thet_pred_mean
4695       t6 = t3**2
4696       t9 = term1
4697       t12 = t3*sigcsq
4698       t14 = t12+t6*sigsqtc
4699       t16 = 1.0d0
4700       t21 = thetai-theta0i
4701       t23 = t21**2
4702       t26 = term2
4703       t27 = t21*t26
4704       t32 = termexp
4705       t40 = t32**2
4706       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4707      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4708      & *(-t12*t9-ak*sig0inv*t27)
4709       return
4710       end
4711 #else
4712 C--------------------------------------------------------------------------
4713       subroutine ebend(etheta)
4714 C
4715 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4716 C angles gamma and its derivatives in consecutive thetas and gammas.
4717 C ab initio-derived potentials from
4718 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4719 C
4720       implicit real*8 (a-h,o-z)
4721       include 'DIMENSIONS'
4722       include 'COMMON.LOCAL'
4723       include 'COMMON.GEO'
4724       include 'COMMON.INTERACT'
4725       include 'COMMON.DERIV'
4726       include 'COMMON.VAR'
4727       include 'COMMON.CHAIN'
4728       include 'COMMON.IOUNITS'
4729       include 'COMMON.NAMES'
4730       include 'COMMON.FFIELD'
4731       include 'COMMON.CONTROL'
4732       include 'COMMON.TORCNSTR'
4733       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4734      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4735      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4736      & sinph1ph2(maxdouble,maxdouble)
4737       logical lprn /.false./, lprn1 /.false./
4738       etheta=0.0D0
4739 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4740       do i=ithet_start,ithet_end
4741 C         if (i.eq.2) cycle
4742 C        if (itype(i-1).eq.ntyp1) cycle
4743         if (i.le.2) cycle
4744         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4745      &  .or.itype(i).eq.ntyp1) cycle
4746         if (iabs(itype(i+1)).eq.20) iblock=2
4747         if (iabs(itype(i+1)).ne.20) iblock=1
4748         dethetai=0.0d0
4749         dephii=0.0d0
4750         dephii1=0.0d0
4751         theti2=0.5d0*theta(i)
4752         ityp2=ithetyp((itype(i-1)))
4753         do k=1,nntheterm
4754           coskt(k)=dcos(k*theti2)
4755           sinkt(k)=dsin(k*theti2)
4756         enddo
4757 cu        if (i.eq.3) then
4758 cu          phii=0.0d0
4759 cu          ityp1=nthetyp+1
4760 cu          do k=1,nsingle
4761 cu            cosph1(k)=0.0d0
4762 cu            sinph1(k)=0.0d0
4763 cu          enddo
4764 cu        else
4765         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4766 #ifdef OSF
4767           phii=phi(i)
4768           if (phii.ne.phii) phii=150.0
4769 #else
4770           phii=phi(i)
4771 #endif
4772           ityp1=ithetyp((itype(i-2)))
4773           do k=1,nsingle
4774             cosph1(k)=dcos(k*phii)
4775             sinph1(k)=dsin(k*phii)
4776           enddo
4777         else
4778           phii=0.0d0
4779 c          ityp1=nthetyp+1
4780           do k=1,nsingle
4781             ityp1=ithetyp((itype(i-2)))
4782             cosph1(k)=0.0d0
4783             sinph1(k)=0.0d0
4784           enddo
4785         endif
4786         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4787 #ifdef OSF
4788           phii1=phi(i+1)
4789           if (phii1.ne.phii1) phii1=150.0
4790           phii1=pinorm(phii1)
4791 #else
4792           phii1=phi(i+1)
4793 #endif
4794           ityp3=ithetyp((itype(i)))
4795           do k=1,nsingle
4796             cosph2(k)=dcos(k*phii1)
4797             sinph2(k)=dsin(k*phii1)
4798           enddo
4799         else
4800           phii1=0.0d0
4801 c          ityp3=nthetyp+1
4802           ityp3=ithetyp((itype(i)))
4803           do k=1,nsingle
4804             cosph2(k)=0.0d0
4805             sinph2(k)=0.0d0
4806           enddo
4807         endif
4808 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4809 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4810 c        call flush(iout)
4811         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4812         do k=1,ndouble
4813           do l=1,k-1
4814             ccl=cosph1(l)*cosph2(k-l)
4815             ssl=sinph1(l)*sinph2(k-l)
4816             scl=sinph1(l)*cosph2(k-l)
4817             csl=cosph1(l)*sinph2(k-l)
4818             cosph1ph2(l,k)=ccl-ssl
4819             cosph1ph2(k,l)=ccl+ssl
4820             sinph1ph2(l,k)=scl+csl
4821             sinph1ph2(k,l)=scl-csl
4822           enddo
4823         enddo
4824         if (lprn) then
4825         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4826      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4827         write (iout,*) "coskt and sinkt"
4828         do k=1,nntheterm
4829           write (iout,*) k,coskt(k),sinkt(k)
4830         enddo
4831         endif
4832         do k=1,ntheterm
4833           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4834           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4835      &      *coskt(k)
4836           if (lprn)
4837      &    write (iout,*) "k",k,"
4838      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4839      &     " ethetai",ethetai
4840         enddo
4841         if (lprn) then
4842         write (iout,*) "cosph and sinph"
4843         do k=1,nsingle
4844           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4845         enddo
4846         write (iout,*) "cosph1ph2 and sinph2ph2"
4847         do k=2,ndouble
4848           do l=1,k-1
4849             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4850      &         sinph1ph2(l,k),sinph1ph2(k,l)
4851           enddo
4852         enddo
4853         write(iout,*) "ethetai",ethetai
4854         endif
4855         do m=1,ntheterm2
4856           do k=1,nsingle
4857             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4858      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4859      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4860      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4861             ethetai=ethetai+sinkt(m)*aux
4862             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4863             dephii=dephii+k*sinkt(m)*(
4864      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4865      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4866             dephii1=dephii1+k*sinkt(m)*(
4867      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4868      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4869             if (lprn)
4870      &      write (iout,*) "m",m," k",k," bbthet",
4871      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4872      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4873      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4874      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4875           enddo
4876         enddo
4877         if (lprn)
4878      &  write(iout,*) "ethetai",ethetai
4879         do m=1,ntheterm3
4880           do k=2,ndouble
4881             do l=1,k-1
4882               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4883      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4884      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4885      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4886               ethetai=ethetai+sinkt(m)*aux
4887               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4888               dephii=dephii+l*sinkt(m)*(
4889      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4890      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4891      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4892      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4893               dephii1=dephii1+(k-l)*sinkt(m)*(
4894      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4895      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4896      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4897      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4898               if (lprn) then
4899               write (iout,*) "m",m," k",k," l",l," ffthet",
4900      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4901      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4902      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4903      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4904      &            " ethetai",ethetai
4905               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4906      &            cosph1ph2(k,l)*sinkt(m),
4907      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4908               endif
4909             enddo
4910           enddo
4911         enddo
4912 10      continue
4913         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4914      &   i,theta(i)*rad2deg,phii*rad2deg,
4915      &   phii1*rad2deg,ethetai
4916         etheta=etheta+ethetai
4917         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4918         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4919 c        gloc(nphi+i-2,icg)=wang*dethetai
4920         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4921       enddo
4922       return
4923       end
4924 #endif
4925 #ifdef CRYST_SC
4926 c-----------------------------------------------------------------------------
4927       subroutine esc(escloc)
4928 C Calculate the local energy of a side chain and its derivatives in the
4929 C corresponding virtual-bond valence angles THETA and the spherical angles
4930 C ALPHA and OMEGA.
4931       implicit real*8 (a-h,o-z)
4932       include 'DIMENSIONS'
4933       include 'COMMON.GEO'
4934       include 'COMMON.LOCAL'
4935       include 'COMMON.VAR'
4936       include 'COMMON.INTERACT'
4937       include 'COMMON.DERIV'
4938       include 'COMMON.CHAIN'
4939       include 'COMMON.IOUNITS'
4940       include 'COMMON.NAMES'
4941       include 'COMMON.FFIELD'
4942       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4943      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4944       common /sccalc/ time11,time12,time112,theti,it,nlobit
4945       delta=0.02d0*pi
4946       escloc=0.0D0
4947 C      write (iout,*) 'ESC'
4948       do i=loc_start,loc_end
4949         it=itype(i)
4950         if (it.eq.ntyp1) cycle
4951         if (it.eq.10) goto 1
4952         nlobit=nlob(iabs(it))
4953 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4954 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4955         theti=theta(i+1)-pipol
4956         x(1)=dtan(theti)
4957         x(2)=alph(i)
4958         x(3)=omeg(i)
4959 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4960
4961         if (x(2).gt.pi-delta) then
4962           xtemp(1)=x(1)
4963           xtemp(2)=pi-delta
4964           xtemp(3)=x(3)
4965           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4966           xtemp(2)=pi
4967           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4968           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4969      &        escloci,dersc(2))
4970           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4971      &        ddersc0(1),dersc(1))
4972           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4973      &        ddersc0(3),dersc(3))
4974           xtemp(2)=pi-delta
4975           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4976           xtemp(2)=pi
4977           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4978           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4979      &            dersc0(2),esclocbi,dersc02)
4980           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4981      &            dersc12,dersc01)
4982           call splinthet(x(2),0.5d0*delta,ss,ssd)
4983           dersc0(1)=dersc01
4984           dersc0(2)=dersc02
4985           dersc0(3)=0.0d0
4986           do k=1,3
4987             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4988           enddo
4989           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4990           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4991      &             esclocbi,ss,ssd
4992           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4993 c         escloci=esclocbi
4994 c         write (iout,*) escloci
4995         else if (x(2).lt.delta) then
4996           xtemp(1)=x(1)
4997           xtemp(2)=delta
4998           xtemp(3)=x(3)
4999           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5000           xtemp(2)=0.0d0
5001           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5002           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5003      &        escloci,dersc(2))
5004           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5005      &        ddersc0(1),dersc(1))
5006           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5007      &        ddersc0(3),dersc(3))
5008           xtemp(2)=delta
5009           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5010           xtemp(2)=0.0d0
5011           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5012           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5013      &            dersc0(2),esclocbi,dersc02)
5014           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5015      &            dersc12,dersc01)
5016           dersc0(1)=dersc01
5017           dersc0(2)=dersc02
5018           dersc0(3)=0.0d0
5019           call splinthet(x(2),0.5d0*delta,ss,ssd)
5020           do k=1,3
5021             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5022           enddo
5023           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5024 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5025 c     &             esclocbi,ss,ssd
5026           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5027 C         write (iout,*) 'i=',i, escloci
5028         else
5029           call enesc(x,escloci,dersc,ddummy,.false.)
5030         endif
5031
5032         escloc=escloc+escloci
5033 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5034             write (iout,'(a6,i5,0pf7.3)')
5035      &     'escloc',i,escloci
5036
5037         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5038      &   wscloc*dersc(1)
5039         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5040         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5041     1   continue
5042       enddo
5043       return
5044       end
5045 C---------------------------------------------------------------------------
5046       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5047       implicit real*8 (a-h,o-z)
5048       include 'DIMENSIONS'
5049       include 'COMMON.GEO'
5050       include 'COMMON.LOCAL'
5051       include 'COMMON.IOUNITS'
5052       common /sccalc/ time11,time12,time112,theti,it,nlobit
5053       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5054       double precision contr(maxlob,-1:1)
5055       logical mixed
5056 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5057         escloc_i=0.0D0
5058         do j=1,3
5059           dersc(j)=0.0D0
5060           if (mixed) ddersc(j)=0.0d0
5061         enddo
5062         x3=x(3)
5063
5064 C Because of periodicity of the dependence of the SC energy in omega we have
5065 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5066 C To avoid underflows, first compute & store the exponents.
5067
5068         do iii=-1,1
5069
5070           x(3)=x3+iii*dwapi
5071
5072           do j=1,nlobit
5073             do k=1,3
5074               z(k)=x(k)-censc(k,j,it)
5075             enddo
5076             do k=1,3
5077               Axk=0.0D0
5078               do l=1,3
5079                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5080               enddo
5081               Ax(k,j,iii)=Axk
5082             enddo
5083             expfac=0.0D0
5084             do k=1,3
5085               expfac=expfac+Ax(k,j,iii)*z(k)
5086             enddo
5087             contr(j,iii)=expfac
5088           enddo ! j
5089
5090         enddo ! iii
5091
5092         x(3)=x3
5093 C As in the case of ebend, we want to avoid underflows in exponentiation and
5094 C subsequent NaNs and INFs in energy calculation.
5095 C Find the largest exponent
5096         emin=contr(1,-1)
5097         do iii=-1,1
5098           do j=1,nlobit
5099             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5100           enddo
5101         enddo
5102         emin=0.5D0*emin
5103 cd      print *,'it=',it,' emin=',emin
5104
5105 C Compute the contribution to SC energy and derivatives
5106         do iii=-1,1
5107
5108           do j=1,nlobit
5109             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5110 cd          print *,'j=',j,' expfac=',expfac
5111             escloc_i=escloc_i+expfac
5112             do k=1,3
5113               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5114             enddo
5115             if (mixed) then
5116               do k=1,3,2
5117                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5118      &            +gaussc(k,2,j,it))*expfac
5119               enddo
5120             endif
5121           enddo
5122
5123         enddo ! iii
5124
5125         dersc(1)=dersc(1)/cos(theti)**2
5126         ddersc(1)=ddersc(1)/cos(theti)**2
5127         ddersc(3)=ddersc(3)
5128
5129         escloci=-(dlog(escloc_i)-emin)
5130         do j=1,3
5131           dersc(j)=dersc(j)/escloc_i
5132         enddo
5133         if (mixed) then
5134           do j=1,3,2
5135             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5136           enddo
5137         endif
5138       return
5139       end
5140 C------------------------------------------------------------------------------
5141       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5142       implicit real*8 (a-h,o-z)
5143       include 'DIMENSIONS'
5144       include 'COMMON.GEO'
5145       include 'COMMON.LOCAL'
5146       include 'COMMON.IOUNITS'
5147       common /sccalc/ time11,time12,time112,theti,it,nlobit
5148       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5149       double precision contr(maxlob)
5150       logical mixed
5151
5152       escloc_i=0.0D0
5153
5154       do j=1,3
5155         dersc(j)=0.0D0
5156       enddo
5157
5158       do j=1,nlobit
5159         do k=1,2
5160           z(k)=x(k)-censc(k,j,it)
5161         enddo
5162         z(3)=dwapi
5163         do k=1,3
5164           Axk=0.0D0
5165           do l=1,3
5166             Axk=Axk+gaussc(l,k,j,it)*z(l)
5167           enddo
5168           Ax(k,j)=Axk
5169         enddo
5170         expfac=0.0D0
5171         do k=1,3
5172           expfac=expfac+Ax(k,j)*z(k)
5173         enddo
5174         contr(j)=expfac
5175       enddo ! j
5176
5177 C As in the case of ebend, we want to avoid underflows in exponentiation and
5178 C subsequent NaNs and INFs in energy calculation.
5179 C Find the largest exponent
5180       emin=contr(1)
5181       do j=1,nlobit
5182         if (emin.gt.contr(j)) emin=contr(j)
5183       enddo
5184       emin=0.5D0*emin
5185
5186 C Compute the contribution to SC energy and derivatives
5187
5188       dersc12=0.0d0
5189       do j=1,nlobit
5190         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5191         escloc_i=escloc_i+expfac
5192         do k=1,2
5193           dersc(k)=dersc(k)+Ax(k,j)*expfac
5194         enddo
5195         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5196      &            +gaussc(1,2,j,it))*expfac
5197         dersc(3)=0.0d0
5198       enddo
5199
5200       dersc(1)=dersc(1)/cos(theti)**2
5201       dersc12=dersc12/cos(theti)**2
5202       escloci=-(dlog(escloc_i)-emin)
5203       do j=1,2
5204         dersc(j)=dersc(j)/escloc_i
5205       enddo
5206       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5207       return
5208       end
5209 #else
5210 c----------------------------------------------------------------------------------
5211       subroutine esc(escloc)
5212 C Calculate the local energy of a side chain and its derivatives in the
5213 C corresponding virtual-bond valence angles THETA and the spherical angles
5214 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5215 C added by Urszula Kozlowska. 07/11/2007
5216 C
5217       implicit real*8 (a-h,o-z)
5218       include 'DIMENSIONS'
5219       include 'COMMON.GEO'
5220       include 'COMMON.LOCAL'
5221       include 'COMMON.VAR'
5222       include 'COMMON.SCROT'
5223       include 'COMMON.INTERACT'
5224       include 'COMMON.DERIV'
5225       include 'COMMON.CHAIN'
5226       include 'COMMON.IOUNITS'
5227       include 'COMMON.NAMES'
5228       include 'COMMON.FFIELD'
5229       include 'COMMON.CONTROL'
5230       include 'COMMON.VECTORS'
5231       double precision x_prime(3),y_prime(3),z_prime(3)
5232      &    , sumene,dsc_i,dp2_i,x(65),
5233      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5234      &    de_dxx,de_dyy,de_dzz,de_dt
5235       double precision s1_t,s1_6_t,s2_t,s2_6_t
5236       double precision
5237      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5238      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5239      & dt_dCi(3),dt_dCi1(3)
5240       common /sccalc/ time11,time12,time112,theti,it,nlobit
5241       delta=0.02d0*pi
5242       escloc=0.0D0
5243       do i=loc_start,loc_end
5244         if (itype(i).eq.ntyp1) cycle
5245         costtab(i+1) =dcos(theta(i+1))
5246         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5247         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5248         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5249         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5250         cosfac=dsqrt(cosfac2)
5251         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5252         sinfac=dsqrt(sinfac2)
5253         it=iabs(itype(i))
5254         if (it.eq.10) goto 1
5255 c
5256 C  Compute the axes of tghe local cartesian coordinates system; store in
5257 c   x_prime, y_prime and z_prime
5258 c
5259         do j=1,3
5260           x_prime(j) = 0.00
5261           y_prime(j) = 0.00
5262           z_prime(j) = 0.00
5263         enddo
5264 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5265 C     &   dc_norm(3,i+nres)
5266         do j = 1,3
5267           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5268           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5269         enddo
5270         do j = 1,3
5271           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5272         enddo
5273 c       write (2,*) "i",i
5274 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5275 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5276 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5277 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5278 c      & " xy",scalar(x_prime(1),y_prime(1)),
5279 c      & " xz",scalar(x_prime(1),z_prime(1)),
5280 c      & " yy",scalar(y_prime(1),y_prime(1)),
5281 c      & " yz",scalar(y_prime(1),z_prime(1)),
5282 c      & " zz",scalar(z_prime(1),z_prime(1))
5283 c
5284 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5285 C to local coordinate system. Store in xx, yy, zz.
5286 c
5287         xx=0.0d0
5288         yy=0.0d0
5289         zz=0.0d0
5290         do j = 1,3
5291           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5292           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5293           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5294         enddo
5295
5296         xxtab(i)=xx
5297         yytab(i)=yy
5298         zztab(i)=zz
5299 C
5300 C Compute the energy of the ith side cbain
5301 C
5302 c        write (2,*) "xx",xx," yy",yy," zz",zz
5303         it=iabs(itype(i))
5304         do j = 1,65
5305           x(j) = sc_parmin(j,it)
5306         enddo
5307 #ifdef CHECK_COORD
5308 Cc diagnostics - remove later
5309         xx1 = dcos(alph(2))
5310         yy1 = dsin(alph(2))*dcos(omeg(2))
5311         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5312         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5313      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5314      &    xx1,yy1,zz1
5315 C,"  --- ", xx_w,yy_w,zz_w
5316 c end diagnostics
5317 #endif
5318         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5319      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5320      &   + x(10)*yy*zz
5321         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5322      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5323      & + x(20)*yy*zz
5324         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5325      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5326      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5327      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5328      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5329      &  +x(40)*xx*yy*zz
5330         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5331      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5332      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5333      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5334      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5335      &  +x(60)*xx*yy*zz
5336         dsc_i   = 0.743d0+x(61)
5337         dp2_i   = 1.9d0+x(62)
5338         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5339      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5340         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5341      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5342         s1=(1+x(63))/(0.1d0 + dscp1)
5343         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5344         s2=(1+x(65))/(0.1d0 + dscp2)
5345         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5346         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5347      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5348 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5349 c     &   sumene4,
5350 c     &   dscp1,dscp2,sumene
5351 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5352         escloc = escloc + sumene
5353 c        write (2,*) "escloc",escloc
5354 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5355 c     &  zz,xx,yy
5356         if (.not. calc_grad) goto 1
5357 #ifdef DEBUG
5358 C
5359 C This section to check the numerical derivatives of the energy of ith side
5360 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5361 C #define DEBUG in the code to turn it on.
5362 C
5363         write (2,*) "sumene               =",sumene
5364         aincr=1.0d-7
5365         xxsave=xx
5366         xx=xx+aincr
5367         write (2,*) xx,yy,zz
5368         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5369         de_dxx_num=(sumenep-sumene)/aincr
5370         xx=xxsave
5371         write (2,*) "xx+ sumene from enesc=",sumenep
5372         yysave=yy
5373         yy=yy+aincr
5374         write (2,*) xx,yy,zz
5375         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5376         de_dyy_num=(sumenep-sumene)/aincr
5377         yy=yysave
5378         write (2,*) "yy+ sumene from enesc=",sumenep
5379         zzsave=zz
5380         zz=zz+aincr
5381         write (2,*) xx,yy,zz
5382         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5383         de_dzz_num=(sumenep-sumene)/aincr
5384         zz=zzsave
5385         write (2,*) "zz+ sumene from enesc=",sumenep
5386         costsave=cost2tab(i+1)
5387         sintsave=sint2tab(i+1)
5388         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5389         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5390         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5391         de_dt_num=(sumenep-sumene)/aincr
5392         write (2,*) " t+ sumene from enesc=",sumenep
5393         cost2tab(i+1)=costsave
5394         sint2tab(i+1)=sintsave
5395 C End of diagnostics section.
5396 #endif
5397 C
5398 C Compute the gradient of esc
5399 C
5400         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5401         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5402         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5403         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5404         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5405         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5406         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5407         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5408         pom1=(sumene3*sint2tab(i+1)+sumene1)
5409      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5410         pom2=(sumene4*cost2tab(i+1)+sumene2)
5411      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5412         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5413         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5414      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5415      &  +x(40)*yy*zz
5416         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5417         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5418      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5419      &  +x(60)*yy*zz
5420         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5421      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5422      &        +(pom1+pom2)*pom_dx
5423 #ifdef DEBUG
5424         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5425 #endif
5426 C
5427         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5428         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5429      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5430      &  +x(40)*xx*zz
5431         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5432         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5433      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5434      &  +x(59)*zz**2 +x(60)*xx*zz
5435         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5436      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5437      &        +(pom1-pom2)*pom_dy
5438 #ifdef DEBUG
5439         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5440 #endif
5441 C
5442         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5443      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5444      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5445      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5446      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5447      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5448      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5449      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5450 #ifdef DEBUG
5451         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5452 #endif
5453 C
5454         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5455      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5456      &  +pom1*pom_dt1+pom2*pom_dt2
5457 #ifdef DEBUG
5458         write(2,*), "de_dt = ", de_dt,de_dt_num
5459 #endif
5460 c
5461 C
5462        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5463        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5464        cosfac2xx=cosfac2*xx
5465        sinfac2yy=sinfac2*yy
5466        do k = 1,3
5467          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5468      &      vbld_inv(i+1)
5469          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5470      &      vbld_inv(i)
5471          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5472          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5473 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5474 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5475 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5476 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5477          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5478          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5479          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5480          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5481          dZZ_Ci1(k)=0.0d0
5482          dZZ_Ci(k)=0.0d0
5483          do j=1,3
5484            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5485      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5486            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5487      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5488          enddo
5489
5490          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5491          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5492          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5493 c
5494          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5495          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5496        enddo
5497
5498        do k=1,3
5499          dXX_Ctab(k,i)=dXX_Ci(k)
5500          dXX_C1tab(k,i)=dXX_Ci1(k)
5501          dYY_Ctab(k,i)=dYY_Ci(k)
5502          dYY_C1tab(k,i)=dYY_Ci1(k)
5503          dZZ_Ctab(k,i)=dZZ_Ci(k)
5504          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5505          dXX_XYZtab(k,i)=dXX_XYZ(k)
5506          dYY_XYZtab(k,i)=dYY_XYZ(k)
5507          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5508        enddo
5509
5510        do k = 1,3
5511 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5512 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5513 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5514 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5515 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5516 c     &    dt_dci(k)
5517 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5518 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5519          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5520      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5521          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5522      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5523          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5524      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5525        enddo
5526 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5527 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5528
5529 C to check gradient call subroutine check_grad
5530
5531     1 continue
5532       enddo
5533       return
5534       end
5535 #endif
5536 c------------------------------------------------------------------------------
5537       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5538 C
5539 C This procedure calculates two-body contact function g(rij) and its derivative:
5540 C
5541 C           eps0ij                                     !       x < -1
5542 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5543 C            0                                         !       x > 1
5544 C
5545 C where x=(rij-r0ij)/delta
5546 C
5547 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5548 C
5549       implicit none
5550       double precision rij,r0ij,eps0ij,fcont,fprimcont
5551       double precision x,x2,x4,delta
5552 c     delta=0.02D0*r0ij
5553 c      delta=0.2D0*r0ij
5554       x=(rij-r0ij)/delta
5555       if (x.lt.-1.0D0) then
5556         fcont=eps0ij
5557         fprimcont=0.0D0
5558       else if (x.le.1.0D0) then
5559         x2=x*x
5560         x4=x2*x2
5561         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5562         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5563       else
5564         fcont=0.0D0
5565         fprimcont=0.0D0
5566       endif
5567       return
5568       end
5569 c------------------------------------------------------------------------------
5570       subroutine splinthet(theti,delta,ss,ssder)
5571       implicit real*8 (a-h,o-z)
5572       include 'DIMENSIONS'
5573       include 'COMMON.VAR'
5574       include 'COMMON.GEO'
5575       thetup=pi-delta
5576       thetlow=delta
5577       if (theti.gt.pipol) then
5578         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5579       else
5580         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5581         ssder=-ssder
5582       endif
5583       return
5584       end
5585 c------------------------------------------------------------------------------
5586       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5587       implicit none
5588       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5589       double precision ksi,ksi2,ksi3,a1,a2,a3
5590       a1=fprim0*delta/(f1-f0)
5591       a2=3.0d0-2.0d0*a1
5592       a3=a1-2.0d0
5593       ksi=(x-x0)/delta
5594       ksi2=ksi*ksi
5595       ksi3=ksi2*ksi
5596       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5597       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5598       return
5599       end
5600 c------------------------------------------------------------------------------
5601       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5602       implicit none
5603       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5604       double precision ksi,ksi2,ksi3,a1,a2,a3
5605       ksi=(x-x0)/delta
5606       ksi2=ksi*ksi
5607       ksi3=ksi2*ksi
5608       a1=fprim0x*delta
5609       a2=3*(f1x-f0x)-2*fprim0x*delta
5610       a3=fprim0x*delta-2*(f1x-f0x)
5611       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5612       return
5613       end
5614 C-----------------------------------------------------------------------------
5615 #ifdef CRYST_TOR
5616 C-----------------------------------------------------------------------------
5617       subroutine etor(etors,fact)
5618       implicit real*8 (a-h,o-z)
5619       include 'DIMENSIONS'
5620       include 'COMMON.VAR'
5621       include 'COMMON.GEO'
5622       include 'COMMON.LOCAL'
5623       include 'COMMON.TORSION'
5624       include 'COMMON.INTERACT'
5625       include 'COMMON.DERIV'
5626       include 'COMMON.CHAIN'
5627       include 'COMMON.NAMES'
5628       include 'COMMON.IOUNITS'
5629       include 'COMMON.FFIELD'
5630       include 'COMMON.TORCNSTR'
5631       logical lprn
5632 C Set lprn=.true. for debugging
5633       lprn=.false.
5634 c      lprn=.true.
5635       etors=0.0D0
5636       do i=iphi_start,iphi_end
5637         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5638      &      .or. itype(i).eq.ntyp1) cycle
5639         itori=itortyp(itype(i-2))
5640         itori1=itortyp(itype(i-1))
5641         phii=phi(i)
5642         gloci=0.0D0
5643 C Proline-Proline pair is a special case...
5644         if (itori.eq.3 .and. itori1.eq.3) then
5645           if (phii.gt.-dwapi3) then
5646             cosphi=dcos(3*phii)
5647             fac=1.0D0/(1.0D0-cosphi)
5648             etorsi=v1(1,3,3)*fac
5649             etorsi=etorsi+etorsi
5650             etors=etors+etorsi-v1(1,3,3)
5651             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5652           endif
5653           do j=1,3
5654             v1ij=v1(j+1,itori,itori1)
5655             v2ij=v2(j+1,itori,itori1)
5656             cosphi=dcos(j*phii)
5657             sinphi=dsin(j*phii)
5658             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5659             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5660           enddo
5661         else
5662           do j=1,nterm_old
5663             v1ij=v1(j,itori,itori1)
5664             v2ij=v2(j,itori,itori1)
5665             cosphi=dcos(j*phii)
5666             sinphi=dsin(j*phii)
5667             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5668             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5669           enddo
5670         endif
5671         if (lprn)
5672      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5673      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5674      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5675         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5676 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5677       enddo
5678       return
5679       end
5680 c------------------------------------------------------------------------------
5681 #else
5682       subroutine etor(etors,fact)
5683       implicit real*8 (a-h,o-z)
5684       include 'DIMENSIONS'
5685       include 'COMMON.VAR'
5686       include 'COMMON.GEO'
5687       include 'COMMON.LOCAL'
5688       include 'COMMON.TORSION'
5689       include 'COMMON.INTERACT'
5690       include 'COMMON.DERIV'
5691       include 'COMMON.CHAIN'
5692       include 'COMMON.NAMES'
5693       include 'COMMON.IOUNITS'
5694       include 'COMMON.FFIELD'
5695       include 'COMMON.TORCNSTR'
5696       logical lprn
5697 C Set lprn=.true. for debugging
5698       lprn=.false.
5699 c      lprn=.true.
5700       etors=0.0D0
5701       do i=iphi_start,iphi_end
5702         if (i.le.2) cycle
5703         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5704      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5705 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5706 C     &       .or. itype(i).eq.ntyp1) cycle
5707         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5708          if (iabs(itype(i)).eq.20) then
5709          iblock=2
5710          else
5711          iblock=1
5712          endif
5713         itori=itortyp(itype(i-2))
5714         itori1=itortyp(itype(i-1))
5715         phii=phi(i)
5716         gloci=0.0D0
5717 C Regular cosine and sine terms
5718         do j=1,nterm(itori,itori1,iblock)
5719           v1ij=v1(j,itori,itori1,iblock)
5720           v2ij=v2(j,itori,itori1,iblock)
5721           cosphi=dcos(j*phii)
5722           sinphi=dsin(j*phii)
5723           etors=etors+v1ij*cosphi+v2ij*sinphi
5724           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5725         enddo
5726 C Lorentz terms
5727 C                         v1
5728 C  E = SUM ----------------------------------- - v1
5729 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5730 C
5731         cosphi=dcos(0.5d0*phii)
5732         sinphi=dsin(0.5d0*phii)
5733         do j=1,nlor(itori,itori1,iblock)
5734           vl1ij=vlor1(j,itori,itori1)
5735           vl2ij=vlor2(j,itori,itori1)
5736           vl3ij=vlor3(j,itori,itori1)
5737           pom=vl2ij*cosphi+vl3ij*sinphi
5738           pom1=1.0d0/(pom*pom+1.0d0)
5739           etors=etors+vl1ij*pom1
5740 c          if (energy_dec) etors_ii=etors_ii+
5741 c     &                vl1ij*pom1
5742           pom=-pom*pom1*pom1
5743           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5744         enddo
5745 C Subtract the constant term
5746         etors=etors-v0(itori,itori1,iblock)
5747         if (lprn)
5748      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5749      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5750      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5751         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5752 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5753  1215   continue
5754       enddo
5755       return
5756       end
5757 c----------------------------------------------------------------------------
5758       subroutine etor_d(etors_d,fact2)
5759 C 6/23/01 Compute double torsional energy
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.VAR'
5763       include 'COMMON.GEO'
5764       include 'COMMON.LOCAL'
5765       include 'COMMON.TORSION'
5766       include 'COMMON.INTERACT'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.CHAIN'
5769       include 'COMMON.NAMES'
5770       include 'COMMON.IOUNITS'
5771       include 'COMMON.FFIELD'
5772       include 'COMMON.TORCNSTR'
5773       logical lprn
5774 C Set lprn=.true. for debugging
5775       lprn=.false.
5776 c     lprn=.true.
5777       etors_d=0.0D0
5778       do i=iphi_start,iphi_end-1
5779         if (i.le.3) cycle
5780 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5781 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5782          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5783      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5784      &  (itype(i+1).eq.ntyp1)) cycle
5785         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5786      &     goto 1215
5787         itori=itortyp(itype(i-2))
5788         itori1=itortyp(itype(i-1))
5789         itori2=itortyp(itype(i))
5790         phii=phi(i)
5791         phii1=phi(i+1)
5792         gloci1=0.0D0
5793         gloci2=0.0D0
5794         iblock=1
5795         if (iabs(itype(i+1)).eq.20) iblock=2
5796 C Regular cosine and sine terms
5797         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5798           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5799           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5800           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5801           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5802           cosphi1=dcos(j*phii)
5803           sinphi1=dsin(j*phii)
5804           cosphi2=dcos(j*phii1)
5805           sinphi2=dsin(j*phii1)
5806           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5807      &     v2cij*cosphi2+v2sij*sinphi2
5808           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5809           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5810         enddo
5811         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5812           do l=1,k-1
5813             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5814             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5815             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5816             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5817             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5818             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5819             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5820             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5821             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5822      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5823             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5824      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5825             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5826      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5827           enddo
5828         enddo
5829         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5830         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5831  1215   continue
5832       enddo
5833       return
5834       end
5835 #endif
5836 c---------------------------------------------------------------------------
5837 C The rigorous attempt to derive energy function
5838       subroutine etor_kcc(etors,fact)
5839       implicit real*8 (a-h,o-z)
5840       include 'DIMENSIONS'
5841       include 'COMMON.VAR'
5842       include 'COMMON.GEO'
5843       include 'COMMON.LOCAL'
5844       include 'COMMON.TORSION'
5845       include 'COMMON.INTERACT'
5846       include 'COMMON.DERIV'
5847       include 'COMMON.CHAIN'
5848       include 'COMMON.NAMES'
5849       include 'COMMON.IOUNITS'
5850       include 'COMMON.FFIELD'
5851       include 'COMMON.TORCNSTR'
5852       include 'COMMON.CONTROL'
5853       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5854       logical lprn
5855 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5856 C Set lprn=.true. for debugging
5857       lprn=energy_dec
5858 c     lprn=.true.
5859 C      print *,"wchodze kcc"
5860       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5861       etors=0.0D0
5862       do i=iphi_start,iphi_end
5863 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5864 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5865 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5866 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5867         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5868      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5869         itori=itortyp(itype(i-2))
5870         itori1=itortyp(itype(i-1))
5871         phii=phi(i)
5872         glocig=0.0D0
5873         glocit1=0.0d0
5874         glocit2=0.0d0
5875 C to avoid multiple devision by 2
5876 c        theti22=0.5d0*theta(i)
5877 C theta 12 is the theta_1 /2
5878 C theta 22 is theta_2 /2
5879 c        theti12=0.5d0*theta(i-1)
5880 C and appropriate sinus function
5881         sinthet1=dsin(theta(i-1))
5882         sinthet2=dsin(theta(i))
5883         costhet1=dcos(theta(i-1))
5884         costhet2=dcos(theta(i))
5885 C to speed up lets store its mutliplication
5886         sint1t2=sinthet2*sinthet1
5887         sint1t2n=1.0d0
5888 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5889 C +d_n*sin(n*gamma)) *
5890 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5891 C we have two sum 1) Non-Chebyshev which is with n and gamma
5892         nval=nterm_kcc_Tb(itori,itori1)
5893         c1(0)=0.0d0
5894         c2(0)=0.0d0
5895         c1(1)=1.0d0
5896         c2(1)=1.0d0
5897         do j=2,nval
5898           c1(j)=c1(j-1)*costhet1
5899           c2(j)=c2(j-1)*costhet2
5900         enddo
5901         etori=0.0d0
5902         do j=1,nterm_kcc(itori,itori1)
5903           cosphi=dcos(j*phii)
5904           sinphi=dsin(j*phii)
5905           sint1t2n1=sint1t2n
5906           sint1t2n=sint1t2n*sint1t2
5907           sumvalc=0.0d0
5908           gradvalct1=0.0d0
5909           gradvalct2=0.0d0
5910           do k=1,nval
5911             do l=1,nval
5912               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5913               gradvalct1=gradvalct1+
5914      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5915               gradvalct2=gradvalct2+
5916      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5917             enddo
5918           enddo
5919           gradvalct1=-gradvalct1*sinthet1
5920           gradvalct2=-gradvalct2*sinthet2
5921           sumvals=0.0d0
5922           gradvalst1=0.0d0
5923           gradvalst2=0.0d0
5924           do k=1,nval
5925             do l=1,nval
5926               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5927               gradvalst1=gradvalst1+
5928      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5929               gradvalst2=gradvalst2+
5930      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5931             enddo
5932           enddo
5933           gradvalst1=-gradvalst1*sinthet1
5934           gradvalst2=-gradvalst2*sinthet2
5935           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5936 C glocig is the gradient local i site in gamma
5937           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5938 C now gradient over theta_1
5939           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5940      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5941           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5942      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5943         enddo ! j
5944         etors=etors+etori
5945 C derivative over gamma
5946         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5947 C derivative over theta1
5948         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5949 C now derivative over theta2
5950         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5951         if (lprn)
5952      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5953      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5954       enddo
5955       return
5956       end
5957 c---------------------------------------------------------------------------------------------
5958       subroutine etor_constr(edihcnstr)
5959       implicit real*8 (a-h,o-z)
5960       include 'DIMENSIONS'
5961       include 'COMMON.VAR'
5962       include 'COMMON.GEO'
5963       include 'COMMON.LOCAL'
5964       include 'COMMON.TORSION'
5965       include 'COMMON.INTERACT'
5966       include 'COMMON.DERIV'
5967       include 'COMMON.CHAIN'
5968       include 'COMMON.NAMES'
5969       include 'COMMON.IOUNITS'
5970       include 'COMMON.FFIELD'
5971       include 'COMMON.TORCNSTR'
5972       include 'COMMON.CONTROL'
5973 ! 6/20/98 - dihedral angle constraints
5974       edihcnstr=0.0d0
5975 c      do i=1,ndih_constr
5976 c      write (iout,*) "idihconstr_start",idihconstr_start,
5977 c     &  " idihconstr_end",idihconstr_end
5978       if (raw_psipred) then
5979         do i=idihconstr_start,idihconstr_end
5980           itori=idih_constr(i)
5981           phii=phi(itori)
5982           gaudih_i=vpsipred(1,i)
5983           gauder_i=0.0d0
5984           do j=1,2
5985             s = sdihed(j,i)
5986             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
5987             dexpcos_i=dexp(-cos_i*cos_i)
5988             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
5989             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
5990      &            *cos_i*dexpcos_i/s**2
5991           enddo
5992           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
5993           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
5994           if (energy_dec)
5995      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
5996      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
5997      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
5998      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
5999      &     -wdihc*dlog(gaudih_i)
6000         enddo
6001       else
6002         do i=idihconstr_start,idihconstr_end
6003           itori=idih_constr(i)
6004           phii=phi(itori)
6005           difi=pinorm(phii-phi0(i))
6006           if (difi.gt.drange(i)) then
6007             difi=difi-drange(i)
6008             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6009             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6010           else if (difi.lt.-drange(i)) then
6011             difi=difi+drange(i)
6012             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6013             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6014           else
6015             difi=0.0
6016           endif
6017         enddo
6018       endif
6019       return
6020       end
6021 c----------------------------------------------------------------------------
6022 C The rigorous attempt to derive energy function
6023       subroutine ebend_kcc(etheta)
6024
6025       implicit real*8 (a-h,o-z)
6026       include 'DIMENSIONS'
6027       include 'COMMON.VAR'
6028       include 'COMMON.GEO'
6029       include 'COMMON.LOCAL'
6030       include 'COMMON.TORSION'
6031       include 'COMMON.INTERACT'
6032       include 'COMMON.DERIV'
6033       include 'COMMON.CHAIN'
6034       include 'COMMON.NAMES'
6035       include 'COMMON.IOUNITS'
6036       include 'COMMON.FFIELD'
6037       include 'COMMON.TORCNSTR'
6038       include 'COMMON.CONTROL'
6039       logical lprn
6040       double precision thybt1(maxang_kcc)
6041 C Set lprn=.true. for debugging
6042       lprn=energy_dec
6043 c     lprn=.true.
6044 C      print *,"wchodze kcc"
6045       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6046       etheta=0.0D0
6047       do i=ithet_start,ithet_end
6048 c        print *,i,itype(i-1),itype(i),itype(i-2)
6049         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6050      &  .or.itype(i).eq.ntyp1) cycle
6051         iti=iabs(itortyp(itype(i-1)))
6052         sinthet=dsin(theta(i))
6053         costhet=dcos(theta(i))
6054         do j=1,nbend_kcc_Tb(iti)
6055           thybt1(j)=v1bend_chyb(j,iti)
6056         enddo
6057         sumth1thyb=v1bend_chyb(0,iti)+
6058      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6059         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6060      &    sumth1thyb
6061         ihelp=nbend_kcc_Tb(iti)-1
6062         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6063         etheta=etheta+sumth1thyb
6064 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6065         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6066       enddo
6067       return
6068       end
6069 c-------------------------------------------------------------------------------------
6070       subroutine etheta_constr(ethetacnstr)
6071
6072       implicit real*8 (a-h,o-z)
6073       include 'DIMENSIONS'
6074       include 'COMMON.VAR'
6075       include 'COMMON.GEO'
6076       include 'COMMON.LOCAL'
6077       include 'COMMON.TORSION'
6078       include 'COMMON.INTERACT'
6079       include 'COMMON.DERIV'
6080       include 'COMMON.CHAIN'
6081       include 'COMMON.NAMES'
6082       include 'COMMON.IOUNITS'
6083       include 'COMMON.FFIELD'
6084       include 'COMMON.TORCNSTR'
6085       include 'COMMON.CONTROL'
6086       ethetacnstr=0.0d0
6087 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6088       do i=ithetaconstr_start,ithetaconstr_end
6089         itheta=itheta_constr(i)
6090         thetiii=theta(itheta)
6091         difi=pinorm(thetiii-theta_constr0(i))
6092         if (difi.gt.theta_drange(i)) then
6093           difi=difi-theta_drange(i)
6094           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6095           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6096      &    +for_thet_constr(i)*difi**3
6097         else if (difi.lt.-drange(i)) then
6098           difi=difi+drange(i)
6099           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6100           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6101      &    +for_thet_constr(i)*difi**3
6102         else
6103           difi=0.0
6104         endif
6105        if (energy_dec) then
6106         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6107      &    i,itheta,rad2deg*thetiii,
6108      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6109      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6110      &    gloc(itheta+nphi-2,icg)
6111         endif
6112       enddo
6113       return
6114       end
6115 c------------------------------------------------------------------------------
6116 c------------------------------------------------------------------------------
6117       subroutine eback_sc_corr(esccor)
6118 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6119 c        conformational states; temporarily implemented as differences
6120 c        between UNRES torsional potentials (dependent on three types of
6121 c        residues) and the torsional potentials dependent on all 20 types
6122 c        of residues computed from AM1 energy surfaces of terminally-blocked
6123 c        amino-acid residues.
6124       implicit real*8 (a-h,o-z)
6125       include 'DIMENSIONS'
6126       include 'COMMON.VAR'
6127       include 'COMMON.GEO'
6128       include 'COMMON.LOCAL'
6129       include 'COMMON.TORSION'
6130       include 'COMMON.SCCOR'
6131       include 'COMMON.INTERACT'
6132       include 'COMMON.DERIV'
6133       include 'COMMON.CHAIN'
6134       include 'COMMON.NAMES'
6135       include 'COMMON.IOUNITS'
6136       include 'COMMON.FFIELD'
6137       include 'COMMON.CONTROL'
6138       logical lprn
6139 C Set lprn=.true. for debugging
6140       lprn=.false.
6141 c      lprn=.true.
6142 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6143       esccor=0.0D0
6144       do i=itau_start,itau_end
6145         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6146         esccor_ii=0.0D0
6147         isccori=isccortyp(itype(i-2))
6148         isccori1=isccortyp(itype(i-1))
6149         phii=phi(i)
6150         do intertyp=1,3 !intertyp
6151 cc Added 09 May 2012 (Adasko)
6152 cc  Intertyp means interaction type of backbone mainchain correlation:
6153 c   1 = SC...Ca...Ca...Ca
6154 c   2 = Ca...Ca...Ca...SC
6155 c   3 = SC...Ca...Ca...SCi
6156         gloci=0.0D0
6157         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6158      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6159      &      (itype(i-1).eq.ntyp1)))
6160      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6161      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6162      &     .or.(itype(i).eq.ntyp1)))
6163      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6164      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6165      &      (itype(i-3).eq.ntyp1)))) cycle
6166         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6167         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6168      & cycle
6169        do j=1,nterm_sccor(isccori,isccori1)
6170           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6171           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6172           cosphi=dcos(j*tauangle(intertyp,i))
6173           sinphi=dsin(j*tauangle(intertyp,i))
6174            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6175            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6176          enddo
6177 C      write (iout,*)"EBACK_SC_COR",esccor,i
6178 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6179 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6180 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6181         if (lprn)
6182      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6183      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6184      &  (v1sccor(j,1,itori,itori1),j=1,6)
6185      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6186 c        gsccor_loc(i-3)=gloci
6187        enddo !intertyp
6188       enddo
6189       return
6190       end
6191 #ifdef FOURBODY
6192 c------------------------------------------------------------------------------
6193       subroutine multibody(ecorr)
6194 C This subroutine calculates multi-body contributions to energy following
6195 C the idea of Skolnick et al. If side chains I and J make a contact and
6196 C at the same time side chains I+1 and J+1 make a contact, an extra
6197 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6198       implicit real*8 (a-h,o-z)
6199       include 'DIMENSIONS'
6200       include 'COMMON.IOUNITS'
6201       include 'COMMON.DERIV'
6202       include 'COMMON.INTERACT'
6203       include 'COMMON.CONTACTS'
6204       include 'COMMON.CONTMAT'
6205       include 'COMMON.CORRMAT'
6206       double precision gx(3),gx1(3)
6207       logical lprn
6208
6209 C Set lprn=.true. for debugging
6210       lprn=.false.
6211
6212       if (lprn) then
6213         write (iout,'(a)') 'Contact function values:'
6214         do i=nnt,nct-2
6215           write (iout,'(i2,20(1x,i2,f10.5))')
6216      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6217         enddo
6218       endif
6219       ecorr=0.0D0
6220       do i=nnt,nct
6221         do j=1,3
6222           gradcorr(j,i)=0.0D0
6223           gradxorr(j,i)=0.0D0
6224         enddo
6225       enddo
6226       do i=nnt,nct-2
6227
6228         DO ISHIFT = 3,4
6229
6230         i1=i+ishift
6231         num_conti=num_cont(i)
6232         num_conti1=num_cont(i1)
6233         do jj=1,num_conti
6234           j=jcont(jj,i)
6235           do kk=1,num_conti1
6236             j1=jcont(kk,i1)
6237             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6238 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6239 cd   &                   ' ishift=',ishift
6240 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6241 C The system gains extra energy.
6242               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6243             endif   ! j1==j+-ishift
6244           enddo     ! kk
6245         enddo       ! jj
6246
6247         ENDDO ! ISHIFT
6248
6249       enddo         ! i
6250       return
6251       end
6252 c------------------------------------------------------------------------------
6253       double precision function esccorr(i,j,k,l,jj,kk)
6254       implicit real*8 (a-h,o-z)
6255       include 'DIMENSIONS'
6256       include 'COMMON.IOUNITS'
6257       include 'COMMON.DERIV'
6258       include 'COMMON.INTERACT'
6259       include 'COMMON.CONTACTS'
6260       include 'COMMON.CONTMAT'
6261       include 'COMMON.CORRMAT'
6262       double precision gx(3),gx1(3)
6263       logical lprn
6264       lprn=.false.
6265       eij=facont(jj,i)
6266       ekl=facont(kk,k)
6267 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6268 C Calculate the multi-body contribution to energy.
6269 C Calculate multi-body contributions to the gradient.
6270 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6271 cd   & k,l,(gacont(m,kk,k),m=1,3)
6272       do m=1,3
6273         gx(m) =ekl*gacont(m,jj,i)
6274         gx1(m)=eij*gacont(m,kk,k)
6275         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6276         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6277         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6278         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6279       enddo
6280       do m=i,j-1
6281         do ll=1,3
6282           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6283         enddo
6284       enddo
6285       do m=k,l-1
6286         do ll=1,3
6287           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6288         enddo
6289       enddo
6290       esccorr=-eij*ekl
6291       return
6292       end
6293 c------------------------------------------------------------------------------
6294       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6295 C This subroutine calculates multi-body contributions to hydrogen-bonding
6296       implicit real*8 (a-h,o-z)
6297       include 'DIMENSIONS'
6298       include 'COMMON.IOUNITS'
6299       include 'COMMON.FFIELD'
6300       include 'COMMON.DERIV'
6301       include 'COMMON.INTERACT'
6302       include 'COMMON.CONTACTS'
6303       include 'COMMON.CONTMAT'
6304       include 'COMMON.CORRMAT'
6305       double precision gx(3),gx1(3)
6306       logical lprn,ldone
6307
6308 C Set lprn=.true. for debugging
6309       lprn=.false.
6310       if (lprn) then
6311         write (iout,'(a)') 'Contact function values:'
6312         do i=nnt,nct-2
6313           write (iout,'(2i3,50(1x,i2,f5.2))')
6314      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6315      &    j=1,num_cont_hb(i))
6316         enddo
6317       endif
6318       ecorr=0.0D0
6319 C Remove the loop below after debugging !!!
6320       do i=nnt,nct
6321         do j=1,3
6322           gradcorr(j,i)=0.0D0
6323           gradxorr(j,i)=0.0D0
6324         enddo
6325       enddo
6326 C Calculate the local-electrostatic correlation terms
6327       do i=iatel_s,iatel_e+1
6328         i1=i+1
6329         num_conti=num_cont_hb(i)
6330         num_conti1=num_cont_hb(i+1)
6331         do jj=1,num_conti
6332           j=jcont_hb(jj,i)
6333           do kk=1,num_conti1
6334             j1=jcont_hb(kk,i1)
6335 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6336 c     &         ' jj=',jj,' kk=',kk
6337             if (j1.eq.j+1 .or. j1.eq.j-1) then
6338 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6339 C The system gains extra energy.
6340               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6341               n_corr=n_corr+1
6342             else if (j1.eq.j) then
6343 C Contacts I-J and I-(J+1) occur simultaneously.
6344 C The system loses extra energy.
6345 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6346             endif
6347           enddo ! kk
6348           do kk=1,num_conti
6349             j1=jcont_hb(kk,i)
6350 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6351 c    &         ' jj=',jj,' kk=',kk
6352             if (j1.eq.j+1) then
6353 C Contacts I-J and (I+1)-J occur simultaneously.
6354 C The system loses extra energy.
6355 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6356             endif ! j1==j+1
6357           enddo ! kk
6358         enddo ! jj
6359       enddo ! i
6360       return
6361       end
6362 c------------------------------------------------------------------------------
6363       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6364      &  n_corr1)
6365 C This subroutine calculates multi-body contributions to hydrogen-bonding
6366       implicit real*8 (a-h,o-z)
6367       include 'DIMENSIONS'
6368       include 'COMMON.IOUNITS'
6369 #ifdef MPI
6370       include "mpif.h"
6371 #endif
6372       include 'COMMON.FFIELD'
6373       include 'COMMON.DERIV'
6374       include 'COMMON.LOCAL'
6375       include 'COMMON.INTERACT'
6376       include 'COMMON.CONTACTS'
6377       include 'COMMON.CONTMAT'
6378       include 'COMMON.CORRMAT'
6379       include 'COMMON.CHAIN'
6380       include 'COMMON.CONTROL'
6381       include 'COMMON.SHIELD'
6382       double precision gx(3),gx1(3)
6383       integer num_cont_hb_old(maxres)
6384       logical lprn,ldone
6385       double precision eello4,eello5,eelo6,eello_turn6
6386       external eello4,eello5,eello6,eello_turn6
6387 C Set lprn=.true. for debugging
6388       lprn=.false.
6389       eturn6=0.0d0
6390       if (lprn) then
6391         write (iout,'(a)') 'Contact function values:'
6392         do i=nnt,nct-2
6393           write (iout,'(2i3,50(1x,i2,5f6.3))')
6394      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6395      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6396         enddo
6397       endif
6398       ecorr=0.0D0
6399       ecorr5=0.0d0
6400       ecorr6=0.0d0
6401 C Remove the loop below after debugging !!!
6402       do i=nnt,nct
6403         do j=1,3
6404           gradcorr(j,i)=0.0D0
6405           gradxorr(j,i)=0.0D0
6406         enddo
6407       enddo
6408 C Calculate the dipole-dipole interaction energies
6409       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6410       do i=iatel_s,iatel_e+1
6411         num_conti=num_cont_hb(i)
6412         do jj=1,num_conti
6413           j=jcont_hb(jj,i)
6414 #ifdef MOMENT
6415           call dipole(i,j,jj)
6416 #endif
6417         enddo
6418       enddo
6419       endif
6420 C Calculate the local-electrostatic correlation terms
6421 c                write (iout,*) "gradcorr5 in eello5 before loop"
6422 c                do iii=1,nres
6423 c                  write (iout,'(i5,3f10.5)')
6424 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6425 c                enddo
6426       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6427 c        write (iout,*) "corr loop i",i
6428         i1=i+1
6429         num_conti=num_cont_hb(i)
6430         num_conti1=num_cont_hb(i+1)
6431         do jj=1,num_conti
6432           j=jcont_hb(jj,i)
6433           jp=iabs(j)
6434           do kk=1,num_conti1
6435             j1=jcont_hb(kk,i1)
6436             jp1=iabs(j1)
6437 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6438 c     &         ' jj=',jj,' kk=',kk
6439 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6440             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6441      &          .or. j.lt.0 .and. j1.gt.0) .and.
6442      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6443 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6444 C The system gains extra energy.
6445               n_corr=n_corr+1
6446               sqd1=dsqrt(d_cont(jj,i))
6447               sqd2=dsqrt(d_cont(kk,i1))
6448               sred_geom = sqd1*sqd2
6449               IF (sred_geom.lt.cutoff_corr) THEN
6450                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6451      &            ekont,fprimcont)
6452 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6453 cd     &         ' jj=',jj,' kk=',kk
6454                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6455                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6456                 do l=1,3
6457                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6458                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6459                 enddo
6460                 n_corr1=n_corr1+1
6461 cd               write (iout,*) 'sred_geom=',sred_geom,
6462 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6463 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6464 cd               write (iout,*) "g_contij",g_contij
6465 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6466 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6467                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6468                 if (wcorr4.gt.0.0d0)
6469      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6470 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6471                   if (energy_dec.and.wcorr4.gt.0.0d0)
6472      1                 write (iout,'(a6,4i5,0pf7.3)')
6473      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6474 c                write (iout,*) "gradcorr5 before eello5"
6475 c                do iii=1,nres
6476 c                  write (iout,'(i5,3f10.5)')
6477 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6478 c                enddo
6479                 if (wcorr5.gt.0.0d0)
6480      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6481 c                write (iout,*) "gradcorr5 after eello5"
6482 c                do iii=1,nres
6483 c                  write (iout,'(i5,3f10.5)')
6484 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6485 c                enddo
6486                   if (energy_dec.and.wcorr5.gt.0.0d0)
6487      1                 write (iout,'(a6,4i5,0pf7.3)')
6488      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6489 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6490 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6491                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6492      &               .or. wturn6.eq.0.0d0))then
6493 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6494                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6495                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6496      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6497 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6498 cd     &            'ecorr6=',ecorr6
6499 cd                write (iout,'(4e15.5)') sred_geom,
6500 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6501 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6502 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6503                 else if (wturn6.gt.0.0d0
6504      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6505 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6506                   eturn6=eturn6+eello_turn6(i,jj,kk)
6507                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6508      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6509 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6510                 endif
6511               ENDIF
6512 1111          continue
6513             endif
6514           enddo ! kk
6515         enddo ! jj
6516       enddo ! i
6517       do i=1,nres
6518         num_cont_hb(i)=num_cont_hb_old(i)
6519       enddo
6520 c                write (iout,*) "gradcorr5 in eello5"
6521 c                do iii=1,nres
6522 c                  write (iout,'(i5,3f10.5)')
6523 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6524 c                enddo
6525       return
6526       end
6527 c------------------------------------------------------------------------------
6528       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6529       implicit real*8 (a-h,o-z)
6530       include 'DIMENSIONS'
6531       include 'COMMON.IOUNITS'
6532       include 'COMMON.DERIV'
6533       include 'COMMON.INTERACT'
6534       include 'COMMON.CONTACTS'
6535       include 'COMMON.CONTMAT'
6536       include 'COMMON.CORRMAT'
6537       include 'COMMON.SHIELD'
6538       include 'COMMON.CONTROL'
6539       double precision gx(3),gx1(3)
6540       logical lprn
6541       lprn=.false.
6542 C      print *,"wchodze",fac_shield(i),shield_mode
6543       eij=facont_hb(jj,i)
6544       ekl=facont_hb(kk,k)
6545       ees0pij=ees0p(jj,i)
6546       ees0pkl=ees0p(kk,k)
6547       ees0mij=ees0m(jj,i)
6548       ees0mkl=ees0m(kk,k)
6549       ekont=eij*ekl
6550       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6551 C*
6552 C     & fac_shield(i)**2*fac_shield(j)**2
6553 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6554 C Following 4 lines for diagnostics.
6555 cd    ees0pkl=0.0D0
6556 cd    ees0pij=1.0D0
6557 cd    ees0mkl=0.0D0
6558 cd    ees0mij=1.0D0
6559 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6560 c     & 'Contacts ',i,j,
6561 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6562 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6563 c     & 'gradcorr_long'
6564 C Calculate the multi-body contribution to energy.
6565 C      ecorr=ecorr+ekont*ees
6566 C Calculate multi-body contributions to the gradient.
6567       coeffpees0pij=coeffp*ees0pij
6568       coeffmees0mij=coeffm*ees0mij
6569       coeffpees0pkl=coeffp*ees0pkl
6570       coeffmees0mkl=coeffm*ees0mkl
6571       do ll=1,3
6572 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6573         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6574      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6575      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6576         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6577      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6578      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6579 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6580         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6581      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6582      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6583         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6584      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6585      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6586         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6587      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6588      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6589         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6590         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6591         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6592      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6593      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6594         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6595         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6596 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6597       enddo
6598 c      write (iout,*)
6599 cgrad      do m=i+1,j-1
6600 cgrad        do ll=1,3
6601 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6602 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6603 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6604 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6605 cgrad        enddo
6606 cgrad      enddo
6607 cgrad      do m=k+1,l-1
6608 cgrad        do ll=1,3
6609 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6610 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6611 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6612 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6613 cgrad        enddo
6614 cgrad      enddo
6615 c      write (iout,*) "ehbcorr",ekont*ees
6616 C      print *,ekont,ees,i,k
6617       ehbcorr=ekont*ees
6618 C now gradient over shielding
6619 C      return
6620       if (shield_mode.gt.0) then
6621        j=ees0plist(jj,i)
6622        l=ees0plist(kk,k)
6623 C        print *,i,j,fac_shield(i),fac_shield(j),
6624 C     &fac_shield(k),fac_shield(l)
6625         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6626      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6627           do ilist=1,ishield_list(i)
6628            iresshield=shield_list(ilist,i)
6629            do m=1,3
6630            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6631 C     &      *2.0
6632            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6633      &              rlocshield
6634      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6635             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6636      &+rlocshield
6637            enddo
6638           enddo
6639           do ilist=1,ishield_list(j)
6640            iresshield=shield_list(ilist,j)
6641            do m=1,3
6642            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6643 C     &     *2.0
6644            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6645      &              rlocshield
6646      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6647            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6648      &     +rlocshield
6649            enddo
6650           enddo
6651
6652           do ilist=1,ishield_list(k)
6653            iresshield=shield_list(ilist,k)
6654            do m=1,3
6655            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6656 C     &     *2.0
6657            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6658      &              rlocshield
6659      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6660            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6661      &     +rlocshield
6662            enddo
6663           enddo
6664           do ilist=1,ishield_list(l)
6665            iresshield=shield_list(ilist,l)
6666            do m=1,3
6667            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6668 C     &     *2.0
6669            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6670      &              rlocshield
6671      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6672            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6673      &     +rlocshield
6674            enddo
6675           enddo
6676 C          print *,gshieldx(m,iresshield)
6677           do m=1,3
6678             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6679      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6680             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6681      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6682             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6683      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6684             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6685      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6686
6687             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6688      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6689             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6690      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6691             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6692      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6693             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6694      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6695
6696            enddo
6697       endif
6698       endif
6699       return
6700       end
6701 #ifdef MOMENT
6702 C---------------------------------------------------------------------------
6703       subroutine dipole(i,j,jj)
6704       implicit real*8 (a-h,o-z)
6705       include 'DIMENSIONS'
6706       include 'COMMON.IOUNITS'
6707       include 'COMMON.CHAIN'
6708       include 'COMMON.FFIELD'
6709       include 'COMMON.DERIV'
6710       include 'COMMON.INTERACT'
6711       include 'COMMON.CONTACTS'
6712       include 'COMMON.CONTMAT'
6713       include 'COMMON.CORRMAT'
6714       include 'COMMON.TORSION'
6715       include 'COMMON.VAR'
6716       include 'COMMON.GEO'
6717       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6718      &  auxmat(2,2)
6719       iti1 = itortyp(itype(i+1))
6720       if (j.lt.nres-1) then
6721         itj1 = itype2loc(itype(j+1))
6722       else
6723         itj1=nloctyp
6724       endif
6725       do iii=1,2
6726         dipi(iii,1)=Ub2(iii,i)
6727         dipderi(iii)=Ub2der(iii,i)
6728         dipi(iii,2)=b1(iii,i+1)
6729         dipj(iii,1)=Ub2(iii,j)
6730         dipderj(iii)=Ub2der(iii,j)
6731         dipj(iii,2)=b1(iii,j+1)
6732       enddo
6733       kkk=0
6734       do iii=1,2
6735         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6736         do jjj=1,2
6737           kkk=kkk+1
6738           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6739         enddo
6740       enddo
6741       do kkk=1,5
6742         do lll=1,3
6743           mmm=0
6744           do iii=1,2
6745             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6746      &        auxvec(1))
6747             do jjj=1,2
6748               mmm=mmm+1
6749               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6750             enddo
6751           enddo
6752         enddo
6753       enddo
6754       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6755       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6756       do iii=1,2
6757         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6758       enddo
6759       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6760       do iii=1,2
6761         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6762       enddo
6763       return
6764       end
6765 #endif
6766 C---------------------------------------------------------------------------
6767       subroutine calc_eello(i,j,k,l,jj,kk)
6768 C
6769 C This subroutine computes matrices and vectors needed to calculate
6770 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6771 C
6772       implicit real*8 (a-h,o-z)
6773       include 'DIMENSIONS'
6774       include 'COMMON.IOUNITS'
6775       include 'COMMON.CHAIN'
6776       include 'COMMON.DERIV'
6777       include 'COMMON.INTERACT'
6778       include 'COMMON.CONTACTS'
6779       include 'COMMON.CONTMAT'
6780       include 'COMMON.CORRMAT'
6781       include 'COMMON.TORSION'
6782       include 'COMMON.VAR'
6783       include 'COMMON.GEO'
6784       include 'COMMON.FFIELD'
6785       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6786      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6787       logical lprn
6788       common /kutas/ lprn
6789 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6790 cd     & ' jj=',jj,' kk=',kk
6791 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6792 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6793 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6794       do iii=1,2
6795         do jjj=1,2
6796           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6797           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6798         enddo
6799       enddo
6800       call transpose2(aa1(1,1),aa1t(1,1))
6801       call transpose2(aa2(1,1),aa2t(1,1))
6802       do kkk=1,5
6803         do lll=1,3
6804           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6805      &      aa1tder(1,1,lll,kkk))
6806           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6807      &      aa2tder(1,1,lll,kkk))
6808         enddo
6809       enddo
6810       if (l.eq.j+1) then
6811 C parallel orientation of the two CA-CA-CA frames.
6812         if (i.gt.1) then
6813           iti=itype2loc(itype(i))
6814         else
6815           iti=nloctyp
6816         endif
6817         itk1=itype2loc(itype(k+1))
6818         itj=itype2loc(itype(j))
6819         if (l.lt.nres-1) then
6820           itl1=itype2loc(itype(l+1))
6821         else
6822           itl1=nloctyp
6823         endif
6824 C A1 kernel(j+1) A2T
6825 cd        do iii=1,2
6826 cd          write (iout,'(3f10.5,5x,3f10.5)')
6827 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6828 cd        enddo
6829         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6830      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6831      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6832 C Following matrices are needed only for 6-th order cumulants
6833         IF (wcorr6.gt.0.0d0) THEN
6834         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6835      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6836      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6837         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6838      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6839      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6840      &   ADtEAderx(1,1,1,1,1,1))
6841         lprn=.false.
6842         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6843      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6844      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6845      &   ADtEA1derx(1,1,1,1,1,1))
6846         ENDIF
6847 C End 6-th order cumulants
6848 cd        lprn=.false.
6849 cd        if (lprn) then
6850 cd        write (2,*) 'In calc_eello6'
6851 cd        do iii=1,2
6852 cd          write (2,*) 'iii=',iii
6853 cd          do kkk=1,5
6854 cd            write (2,*) 'kkk=',kkk
6855 cd            do jjj=1,2
6856 cd              write (2,'(3(2f10.5),5x)')
6857 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6858 cd            enddo
6859 cd          enddo
6860 cd        enddo
6861 cd        endif
6862         call transpose2(EUgder(1,1,k),auxmat(1,1))
6863         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6864         call transpose2(EUg(1,1,k),auxmat(1,1))
6865         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6866         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6867         do iii=1,2
6868           do kkk=1,5
6869             do lll=1,3
6870               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6871      &          EAEAderx(1,1,lll,kkk,iii,1))
6872             enddo
6873           enddo
6874         enddo
6875 C A1T kernel(i+1) A2
6876         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6877      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6878      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6879 C Following matrices are needed only for 6-th order cumulants
6880         IF (wcorr6.gt.0.0d0) THEN
6881         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6882      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6883      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6884         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6885      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6886      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6887      &   ADtEAderx(1,1,1,1,1,2))
6888         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6889      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6890      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6891      &   ADtEA1derx(1,1,1,1,1,2))
6892         ENDIF
6893 C End 6-th order cumulants
6894         call transpose2(EUgder(1,1,l),auxmat(1,1))
6895         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6896         call transpose2(EUg(1,1,l),auxmat(1,1))
6897         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6898         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6899         do iii=1,2
6900           do kkk=1,5
6901             do lll=1,3
6902               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6903      &          EAEAderx(1,1,lll,kkk,iii,2))
6904             enddo
6905           enddo
6906         enddo
6907 C AEAb1 and AEAb2
6908 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6909 C They are needed only when the fifth- or the sixth-order cumulants are
6910 C indluded.
6911         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6912         call transpose2(AEA(1,1,1),auxmat(1,1))
6913         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6914         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6915         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6916         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6917         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6918         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6919         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6920         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6921         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6922         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6923         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6924         call transpose2(AEA(1,1,2),auxmat(1,1))
6925         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6926         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6927         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6928         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6929         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6930         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6931         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6932         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6933         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6934         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6935         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6936 C Calculate the Cartesian derivatives of the vectors.
6937         do iii=1,2
6938           do kkk=1,5
6939             do lll=1,3
6940               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6941               call matvec2(auxmat(1,1),b1(1,i),
6942      &          AEAb1derx(1,lll,kkk,iii,1,1))
6943               call matvec2(auxmat(1,1),Ub2(1,i),
6944      &          AEAb2derx(1,lll,kkk,iii,1,1))
6945               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6946      &          AEAb1derx(1,lll,kkk,iii,2,1))
6947               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6948      &          AEAb2derx(1,lll,kkk,iii,2,1))
6949               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6950               call matvec2(auxmat(1,1),b1(1,j),
6951      &          AEAb1derx(1,lll,kkk,iii,1,2))
6952               call matvec2(auxmat(1,1),Ub2(1,j),
6953      &          AEAb2derx(1,lll,kkk,iii,1,2))
6954               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6955      &          AEAb1derx(1,lll,kkk,iii,2,2))
6956               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6957      &          AEAb2derx(1,lll,kkk,iii,2,2))
6958             enddo
6959           enddo
6960         enddo
6961         ENDIF
6962 C End vectors
6963       else
6964 C Antiparallel orientation of the two CA-CA-CA frames.
6965         if (i.gt.1) then
6966           iti=itype2loc(itype(i))
6967         else
6968           iti=nloctyp
6969         endif
6970         itk1=itype2loc(itype(k+1))
6971         itl=itype2loc(itype(l))
6972         itj=itype2loc(itype(j))
6973         if (j.lt.nres-1) then
6974           itj1=itype2loc(itype(j+1))
6975         else
6976           itj1=nloctyp
6977         endif
6978 C A2 kernel(j-1)T A1T
6979         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6980      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6981      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6982 C Following matrices are needed only for 6-th order cumulants
6983         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6984      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6985         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6986      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6987      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6988         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6989      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6990      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6991      &   ADtEAderx(1,1,1,1,1,1))
6992         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6993      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6994      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6995      &   ADtEA1derx(1,1,1,1,1,1))
6996         ENDIF
6997 C End 6-th order cumulants
6998         call transpose2(EUgder(1,1,k),auxmat(1,1))
6999         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7000         call transpose2(EUg(1,1,k),auxmat(1,1))
7001         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7002         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7003         do iii=1,2
7004           do kkk=1,5
7005             do lll=1,3
7006               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7007      &          EAEAderx(1,1,lll,kkk,iii,1))
7008             enddo
7009           enddo
7010         enddo
7011 C A2T kernel(i+1)T A1
7012         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7013      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7014      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7015 C Following matrices are needed only for 6-th order cumulants
7016         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7017      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7018         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7019      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7020      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7021         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7022      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7023      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7024      &   ADtEAderx(1,1,1,1,1,2))
7025         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7026      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7027      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7028      &   ADtEA1derx(1,1,1,1,1,2))
7029         ENDIF
7030 C End 6-th order cumulants
7031         call transpose2(EUgder(1,1,j),auxmat(1,1))
7032         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7033         call transpose2(EUg(1,1,j),auxmat(1,1))
7034         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7035         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7036         do iii=1,2
7037           do kkk=1,5
7038             do lll=1,3
7039               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7040      &          EAEAderx(1,1,lll,kkk,iii,2))
7041             enddo
7042           enddo
7043         enddo
7044 C AEAb1 and AEAb2
7045 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7046 C They are needed only when the fifth- or the sixth-order cumulants are
7047 C indluded.
7048         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7049      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7050         call transpose2(AEA(1,1,1),auxmat(1,1))
7051         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7052         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7053         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7054         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7055         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7056         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7057         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7058         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7059         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7060         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7061         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7062         call transpose2(AEA(1,1,2),auxmat(1,1))
7063         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7064         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7065         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7066         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7067         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7068         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7069         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7070         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7071         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7072         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7073         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7074 C Calculate the Cartesian derivatives of the vectors.
7075         do iii=1,2
7076           do kkk=1,5
7077             do lll=1,3
7078               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7079               call matvec2(auxmat(1,1),b1(1,i),
7080      &          AEAb1derx(1,lll,kkk,iii,1,1))
7081               call matvec2(auxmat(1,1),Ub2(1,i),
7082      &          AEAb2derx(1,lll,kkk,iii,1,1))
7083               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7084      &          AEAb1derx(1,lll,kkk,iii,2,1))
7085               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7086      &          AEAb2derx(1,lll,kkk,iii,2,1))
7087               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7088               call matvec2(auxmat(1,1),b1(1,l),
7089      &          AEAb1derx(1,lll,kkk,iii,1,2))
7090               call matvec2(auxmat(1,1),Ub2(1,l),
7091      &          AEAb2derx(1,lll,kkk,iii,1,2))
7092               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7093      &          AEAb1derx(1,lll,kkk,iii,2,2))
7094               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7095      &          AEAb2derx(1,lll,kkk,iii,2,2))
7096             enddo
7097           enddo
7098         enddo
7099         ENDIF
7100 C End vectors
7101       endif
7102       return
7103       end
7104 C---------------------------------------------------------------------------
7105       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7106      &  KK,KKderg,AKA,AKAderg,AKAderx)
7107       implicit none
7108       integer nderg
7109       logical transp
7110       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7111      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7112      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7113       integer iii,kkk,lll
7114       integer jjj,mmm
7115       logical lprn
7116       common /kutas/ lprn
7117       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7118       do iii=1,nderg
7119         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7120      &    AKAderg(1,1,iii))
7121       enddo
7122 cd      if (lprn) write (2,*) 'In kernel'
7123       do kkk=1,5
7124 cd        if (lprn) write (2,*) 'kkk=',kkk
7125         do lll=1,3
7126           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7127      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7128 cd          if (lprn) then
7129 cd            write (2,*) 'lll=',lll
7130 cd            write (2,*) 'iii=1'
7131 cd            do jjj=1,2
7132 cd              write (2,'(3(2f10.5),5x)')
7133 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7134 cd            enddo
7135 cd          endif
7136           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7137      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7138 cd          if (lprn) then
7139 cd            write (2,*) 'lll=',lll
7140 cd            write (2,*) 'iii=2'
7141 cd            do jjj=1,2
7142 cd              write (2,'(3(2f10.5),5x)')
7143 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7144 cd            enddo
7145 cd          endif
7146         enddo
7147       enddo
7148       return
7149       end
7150 C---------------------------------------------------------------------------
7151       double precision function eello4(i,j,k,l,jj,kk)
7152       implicit real*8 (a-h,o-z)
7153       include 'DIMENSIONS'
7154       include 'COMMON.IOUNITS'
7155       include 'COMMON.CHAIN'
7156       include 'COMMON.DERIV'
7157       include 'COMMON.INTERACT'
7158       include 'COMMON.CONTACTS'
7159       include 'COMMON.CONTMAT'
7160       include 'COMMON.CORRMAT'
7161       include 'COMMON.TORSION'
7162       include 'COMMON.VAR'
7163       include 'COMMON.GEO'
7164       double precision pizda(2,2),ggg1(3),ggg2(3)
7165 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7166 cd        eello4=0.0d0
7167 cd        return
7168 cd      endif
7169 cd      print *,'eello4:',i,j,k,l,jj,kk
7170 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7171 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7172 cold      eij=facont_hb(jj,i)
7173 cold      ekl=facont_hb(kk,k)
7174 cold      ekont=eij*ekl
7175       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7176       if (calc_grad) then
7177 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7178       gcorr_loc(k-1)=gcorr_loc(k-1)
7179      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7180       if (l.eq.j+1) then
7181         gcorr_loc(l-1)=gcorr_loc(l-1)
7182      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7183       else
7184         gcorr_loc(j-1)=gcorr_loc(j-1)
7185      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7186       endif
7187       do iii=1,2
7188         do kkk=1,5
7189           do lll=1,3
7190             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7191      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7192 cd            derx(lll,kkk,iii)=0.0d0
7193           enddo
7194         enddo
7195       enddo
7196 cd      gcorr_loc(l-1)=0.0d0
7197 cd      gcorr_loc(j-1)=0.0d0
7198 cd      gcorr_loc(k-1)=0.0d0
7199 cd      eel4=1.0d0
7200 cd      write (iout,*)'Contacts have occurred for peptide groups',
7201 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7202 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7203       if (j.lt.nres-1) then
7204         j1=j+1
7205         j2=j-1
7206       else
7207         j1=j-1
7208         j2=j-2
7209       endif
7210       if (l.lt.nres-1) then
7211         l1=l+1
7212         l2=l-1
7213       else
7214         l1=l-1
7215         l2=l-2
7216       endif
7217       do ll=1,3
7218 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7219 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7220         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7221         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7222 cgrad        ghalf=0.5d0*ggg1(ll)
7223         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7224         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7225         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7226         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7227         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7228         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7229 cgrad        ghalf=0.5d0*ggg2(ll)
7230         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7231         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7232         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7233         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7234         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7235         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7236       enddo
7237 cgrad      do m=i+1,j-1
7238 cgrad        do ll=1,3
7239 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7240 cgrad        enddo
7241 cgrad      enddo
7242 cgrad      do m=k+1,l-1
7243 cgrad        do ll=1,3
7244 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7245 cgrad        enddo
7246 cgrad      enddo
7247 cgrad      do m=i+2,j2
7248 cgrad        do ll=1,3
7249 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7250 cgrad        enddo
7251 cgrad      enddo
7252 cgrad      do m=k+2,l2
7253 cgrad        do ll=1,3
7254 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7255 cgrad        enddo
7256 cgrad      enddo
7257 cd      do iii=1,nres-3
7258 cd        write (2,*) iii,gcorr_loc(iii)
7259 cd      enddo
7260       endif ! calc_grad
7261       eello4=ekont*eel4
7262 cd      write (2,*) 'ekont',ekont
7263 cd      write (iout,*) 'eello4',ekont*eel4
7264       return
7265       end
7266 C---------------------------------------------------------------------------
7267       double precision function eello5(i,j,k,l,jj,kk)
7268       implicit real*8 (a-h,o-z)
7269       include 'DIMENSIONS'
7270       include 'COMMON.IOUNITS'
7271       include 'COMMON.CHAIN'
7272       include 'COMMON.DERIV'
7273       include 'COMMON.INTERACT'
7274       include 'COMMON.CONTACTS'
7275       include 'COMMON.CONTMAT'
7276       include 'COMMON.CORRMAT'
7277       include 'COMMON.TORSION'
7278       include 'COMMON.VAR'
7279       include 'COMMON.GEO'
7280       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7281       double precision ggg1(3),ggg2(3)
7282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7283 C                                                                              C
7284 C                            Parallel chains                                   C
7285 C                                                                              C
7286 C          o             o                   o             o                   C
7287 C         /l\           / \             \   / \           / \   /              C
7288 C        /   \         /   \             \ /   \         /   \ /               C
7289 C       j| o |l1       | o |              o| o |         | o |o                C
7290 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7291 C      \i/   \         /   \ /             /   \         /   \                 C
7292 C       o    k1             o                                                  C
7293 C         (I)          (II)                (III)          (IV)                 C
7294 C                                                                              C
7295 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7296 C                                                                              C
7297 C                            Antiparallel chains                               C
7298 C                                                                              C
7299 C          o             o                   o             o                   C
7300 C         /j\           / \             \   / \           / \   /              C
7301 C        /   \         /   \             \ /   \         /   \ /               C
7302 C      j1| o |l        | o |              o| o |         | o |o                C
7303 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7304 C      \i/   \         /   \ /             /   \         /   \                 C
7305 C       o     k1            o                                                  C
7306 C         (I)          (II)                (III)          (IV)                 C
7307 C                                                                              C
7308 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7309 C                                                                              C
7310 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7311 C                                                                              C
7312 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7313 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7314 cd        eello5=0.0d0
7315 cd        return
7316 cd      endif
7317 cd      write (iout,*)
7318 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7319 cd     &   ' and',k,l
7320       itk=itype2loc(itype(k))
7321       itl=itype2loc(itype(l))
7322       itj=itype2loc(itype(j))
7323       eello5_1=0.0d0
7324       eello5_2=0.0d0
7325       eello5_3=0.0d0
7326       eello5_4=0.0d0
7327 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7328 cd     &   eel5_3_num,eel5_4_num)
7329       do iii=1,2
7330         do kkk=1,5
7331           do lll=1,3
7332             derx(lll,kkk,iii)=0.0d0
7333           enddo
7334         enddo
7335       enddo
7336 cd      eij=facont_hb(jj,i)
7337 cd      ekl=facont_hb(kk,k)
7338 cd      ekont=eij*ekl
7339 cd      write (iout,*)'Contacts have occurred for peptide groups',
7340 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7341 cd      goto 1111
7342 C Contribution from the graph I.
7343 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7344 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7345       call transpose2(EUg(1,1,k),auxmat(1,1))
7346       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7347       vv(1)=pizda(1,1)-pizda(2,2)
7348       vv(2)=pizda(1,2)+pizda(2,1)
7349       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7350      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7351       if (calc_grad) then
7352 C Explicit gradient in virtual-dihedral angles.
7353       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7354      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7355      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7356       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7357       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7358       vv(1)=pizda(1,1)-pizda(2,2)
7359       vv(2)=pizda(1,2)+pizda(2,1)
7360       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7361      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7362      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7363       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7364       vv(1)=pizda(1,1)-pizda(2,2)
7365       vv(2)=pizda(1,2)+pizda(2,1)
7366       if (l.eq.j+1) then
7367         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7368      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7369      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7370       else
7371         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7372      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7373      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7374       endif
7375 C Cartesian gradient
7376       do iii=1,2
7377         do kkk=1,5
7378           do lll=1,3
7379             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7380      &        pizda(1,1))
7381             vv(1)=pizda(1,1)-pizda(2,2)
7382             vv(2)=pizda(1,2)+pizda(2,1)
7383             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7384      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7385      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7386           enddo
7387         enddo
7388       enddo
7389       endif ! calc_grad
7390 c      goto 1112
7391 c1111  continue
7392 C Contribution from graph II
7393       call transpose2(EE(1,1,k),auxmat(1,1))
7394       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7395       vv(1)=pizda(1,1)+pizda(2,2)
7396       vv(2)=pizda(2,1)-pizda(1,2)
7397       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7398      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7399       if (calc_grad) then
7400 C Explicit gradient in virtual-dihedral angles.
7401       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7402      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7403       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7404       vv(1)=pizda(1,1)+pizda(2,2)
7405       vv(2)=pizda(2,1)-pizda(1,2)
7406       if (l.eq.j+1) then
7407         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7408      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7409      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7410       else
7411         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7412      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7413      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7414       endif
7415 C Cartesian gradient
7416       do iii=1,2
7417         do kkk=1,5
7418           do lll=1,3
7419             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7420      &        pizda(1,1))
7421             vv(1)=pizda(1,1)+pizda(2,2)
7422             vv(2)=pizda(2,1)-pizda(1,2)
7423             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7424      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7425      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7426           enddo
7427         enddo
7428       enddo
7429       endif ! calc_grad
7430 cd      goto 1112
7431 cd1111  continue
7432       if (l.eq.j+1) then
7433 cd        goto 1110
7434 C Parallel orientation
7435 C Contribution from graph III
7436         call transpose2(EUg(1,1,l),auxmat(1,1))
7437         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7438         vv(1)=pizda(1,1)-pizda(2,2)
7439         vv(2)=pizda(1,2)+pizda(2,1)
7440         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7441      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7442         if (calc_grad) then
7443 C Explicit gradient in virtual-dihedral angles.
7444         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7445      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7446      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7447         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7448         vv(1)=pizda(1,1)-pizda(2,2)
7449         vv(2)=pizda(1,2)+pizda(2,1)
7450         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7451      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7452      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7453         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7454         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7455         vv(1)=pizda(1,1)-pizda(2,2)
7456         vv(2)=pizda(1,2)+pizda(2,1)
7457         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7458      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7459      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7460 C Cartesian gradient
7461         do iii=1,2
7462           do kkk=1,5
7463             do lll=1,3
7464               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7465      &          pizda(1,1))
7466               vv(1)=pizda(1,1)-pizda(2,2)
7467               vv(2)=pizda(1,2)+pizda(2,1)
7468               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7469      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7470      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7471             enddo
7472           enddo
7473         enddo
7474 cd        goto 1112
7475 C Contribution from graph IV
7476 cd1110    continue
7477         call transpose2(EE(1,1,l),auxmat(1,1))
7478         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7479         vv(1)=pizda(1,1)+pizda(2,2)
7480         vv(2)=pizda(2,1)-pizda(1,2)
7481         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7482      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7483 C Explicit gradient in virtual-dihedral angles.
7484         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7485      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7486         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7487         vv(1)=pizda(1,1)+pizda(2,2)
7488         vv(2)=pizda(2,1)-pizda(1,2)
7489         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7490      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7491      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7492 C Cartesian gradient
7493         do iii=1,2
7494           do kkk=1,5
7495             do lll=1,3
7496               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7497      &          pizda(1,1))
7498               vv(1)=pizda(1,1)+pizda(2,2)
7499               vv(2)=pizda(2,1)-pizda(1,2)
7500               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7501      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7502      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7503             enddo
7504           enddo
7505         enddo
7506         endif ! calc_grad
7507       else
7508 C Antiparallel orientation
7509 C Contribution from graph III
7510 c        goto 1110
7511         call transpose2(EUg(1,1,j),auxmat(1,1))
7512         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7513         vv(1)=pizda(1,1)-pizda(2,2)
7514         vv(2)=pizda(1,2)+pizda(2,1)
7515         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7517         if (calc_grad) then
7518 C Explicit gradient in virtual-dihedral angles.
7519         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7520      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7521      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7522         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7523         vv(1)=pizda(1,1)-pizda(2,2)
7524         vv(2)=pizda(1,2)+pizda(2,1)
7525         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7526      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7527      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7528         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7529         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7530         vv(1)=pizda(1,1)-pizda(2,2)
7531         vv(2)=pizda(1,2)+pizda(2,1)
7532         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7533      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7534      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7535 C Cartesian gradient
7536         do iii=1,2
7537           do kkk=1,5
7538             do lll=1,3
7539               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7540      &          pizda(1,1))
7541               vv(1)=pizda(1,1)-pizda(2,2)
7542               vv(2)=pizda(1,2)+pizda(2,1)
7543               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7544      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7545      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7546             enddo
7547           enddo
7548         enddo
7549         endif ! calc_grad
7550 cd        goto 1112
7551 C Contribution from graph IV
7552 1110    continue
7553         call transpose2(EE(1,1,j),auxmat(1,1))
7554         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7555         vv(1)=pizda(1,1)+pizda(2,2)
7556         vv(2)=pizda(2,1)-pizda(1,2)
7557         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7558      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7559         if (calc_grad) then
7560 C Explicit gradient in virtual-dihedral angles.
7561         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7562      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7563         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7564         vv(1)=pizda(1,1)+pizda(2,2)
7565         vv(2)=pizda(2,1)-pizda(1,2)
7566         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7567      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7568      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7569 C Cartesian gradient
7570         do iii=1,2
7571           do kkk=1,5
7572             do lll=1,3
7573               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7574      &          pizda(1,1))
7575               vv(1)=pizda(1,1)+pizda(2,2)
7576               vv(2)=pizda(2,1)-pizda(1,2)
7577               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7578      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7579      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7580             enddo
7581           enddo
7582         enddo
7583         endif ! calc_grad
7584       endif
7585 1112  continue
7586       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7587 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7588 cd        write (2,*) 'ijkl',i,j,k,l
7589 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7590 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7591 cd      endif
7592 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7593 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7594 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7595 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7596       if (calc_grad) then
7597       if (j.lt.nres-1) then
7598         j1=j+1
7599         j2=j-1
7600       else
7601         j1=j-1
7602         j2=j-2
7603       endif
7604       if (l.lt.nres-1) then
7605         l1=l+1
7606         l2=l-1
7607       else
7608         l1=l-1
7609         l2=l-2
7610       endif
7611 cd      eij=1.0d0
7612 cd      ekl=1.0d0
7613 cd      ekont=1.0d0
7614 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7615 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7616 C        summed up outside the subrouine as for the other subroutines
7617 C        handling long-range interactions. The old code is commented out
7618 C        with "cgrad" to keep track of changes.
7619       do ll=1,3
7620 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7621 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7622         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7623         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7624 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7625 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7626 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7627 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7628 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7629 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7630 c     &   gradcorr5ij,
7631 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7632 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7633 cgrad        ghalf=0.5d0*ggg1(ll)
7634 cd        ghalf=0.0d0
7635         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7636         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7637         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7638         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7639         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7640         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7641 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7642 cgrad        ghalf=0.5d0*ggg2(ll)
7643 cd        ghalf=0.0d0
7644         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7645         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7646         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7647         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7648         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7649         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7650       enddo
7651       endif ! calc_grad
7652 cd      goto 1112
7653 cgrad      do m=i+1,j-1
7654 cgrad        do ll=1,3
7655 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7656 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7657 cgrad        enddo
7658 cgrad      enddo
7659 cgrad      do m=k+1,l-1
7660 cgrad        do ll=1,3
7661 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7662 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7663 cgrad        enddo
7664 cgrad      enddo
7665 c1112  continue
7666 cgrad      do m=i+2,j2
7667 cgrad        do ll=1,3
7668 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7669 cgrad        enddo
7670 cgrad      enddo
7671 cgrad      do m=k+2,l2
7672 cgrad        do ll=1,3
7673 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7674 cgrad        enddo
7675 cgrad      enddo
7676 cd      do iii=1,nres-3
7677 cd        write (2,*) iii,g_corr5_loc(iii)
7678 cd      enddo
7679       eello5=ekont*eel5
7680 cd      write (2,*) 'ekont',ekont
7681 cd      write (iout,*) 'eello5',ekont*eel5
7682       return
7683       end
7684 c--------------------------------------------------------------------------
7685       double precision function eello6(i,j,k,l,jj,kk)
7686       implicit real*8 (a-h,o-z)
7687       include 'DIMENSIONS'
7688       include 'COMMON.IOUNITS'
7689       include 'COMMON.CHAIN'
7690       include 'COMMON.DERIV'
7691       include 'COMMON.INTERACT'
7692       include 'COMMON.CONTACTS'
7693       include 'COMMON.CONTMAT'
7694       include 'COMMON.CORRMAT'
7695       include 'COMMON.TORSION'
7696       include 'COMMON.VAR'
7697       include 'COMMON.GEO'
7698       include 'COMMON.FFIELD'
7699       double precision ggg1(3),ggg2(3)
7700 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7701 cd        eello6=0.0d0
7702 cd        return
7703 cd      endif
7704 cd      write (iout,*)
7705 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7706 cd     &   ' and',k,l
7707       eello6_1=0.0d0
7708       eello6_2=0.0d0
7709       eello6_3=0.0d0
7710       eello6_4=0.0d0
7711       eello6_5=0.0d0
7712       eello6_6=0.0d0
7713 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7714 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7715       do iii=1,2
7716         do kkk=1,5
7717           do lll=1,3
7718             derx(lll,kkk,iii)=0.0d0
7719           enddo
7720         enddo
7721       enddo
7722 cd      eij=facont_hb(jj,i)
7723 cd      ekl=facont_hb(kk,k)
7724 cd      ekont=eij*ekl
7725 cd      eij=1.0d0
7726 cd      ekl=1.0d0
7727 cd      ekont=1.0d0
7728       if (l.eq.j+1) then
7729         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7730         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7731         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7732         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7733         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7734         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7735       else
7736         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7737         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7738         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7739         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7740         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7741           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7742         else
7743           eello6_5=0.0d0
7744         endif
7745         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7746       endif
7747 C If turn contributions are considered, they will be handled separately.
7748       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7749 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7750 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7751 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7752 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7753 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7754 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7755 cd      goto 1112
7756       if (calc_grad) then
7757       if (j.lt.nres-1) then
7758         j1=j+1
7759         j2=j-1
7760       else
7761         j1=j-1
7762         j2=j-2
7763       endif
7764       if (l.lt.nres-1) then
7765         l1=l+1
7766         l2=l-1
7767       else
7768         l1=l-1
7769         l2=l-2
7770       endif
7771       do ll=1,3
7772 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7773 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7774 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7775 cgrad        ghalf=0.5d0*ggg1(ll)
7776 cd        ghalf=0.0d0
7777         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7778         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7779         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7780         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7781         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7782         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7783         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7784         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7785 cgrad        ghalf=0.5d0*ggg2(ll)
7786 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7787 cd        ghalf=0.0d0
7788         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7789         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7790         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7791         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7792         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7793         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7794       enddo
7795       endif ! calc_grad
7796 cd      goto 1112
7797 cgrad      do m=i+1,j-1
7798 cgrad        do ll=1,3
7799 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7800 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7801 cgrad        enddo
7802 cgrad      enddo
7803 cgrad      do m=k+1,l-1
7804 cgrad        do ll=1,3
7805 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7806 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7807 cgrad        enddo
7808 cgrad      enddo
7809 cgrad1112  continue
7810 cgrad      do m=i+2,j2
7811 cgrad        do ll=1,3
7812 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7813 cgrad        enddo
7814 cgrad      enddo
7815 cgrad      do m=k+2,l2
7816 cgrad        do ll=1,3
7817 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7818 cgrad        enddo
7819 cgrad      enddo
7820 cd      do iii=1,nres-3
7821 cd        write (2,*) iii,g_corr6_loc(iii)
7822 cd      enddo
7823       eello6=ekont*eel6
7824 cd      write (2,*) 'ekont',ekont
7825 cd      write (iout,*) 'eello6',ekont*eel6
7826       return
7827       end
7828 c--------------------------------------------------------------------------
7829       double precision function eello6_graph1(i,j,k,l,imat,swap)
7830       implicit real*8 (a-h,o-z)
7831       include 'DIMENSIONS'
7832       include 'COMMON.IOUNITS'
7833       include 'COMMON.CHAIN'
7834       include 'COMMON.DERIV'
7835       include 'COMMON.INTERACT'
7836       include 'COMMON.CONTACTS'
7837       include 'COMMON.CONTMAT'
7838       include 'COMMON.CORRMAT'
7839       include 'COMMON.TORSION'
7840       include 'COMMON.VAR'
7841       include 'COMMON.GEO'
7842       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7843       logical swap
7844       logical lprn
7845       common /kutas/ lprn
7846 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7847 C                                                                              C
7848 C      Parallel       Antiparallel                                             C
7849 C                                                                              C
7850 C          o             o                                                     C
7851 C         /l\           /j\                                                    C
7852 C        /   \         /   \                                                   C
7853 C       /| o |         | o |\                                                  C
7854 C     \ j|/k\|  /   \  |/k\|l /                                                C
7855 C      \ /   \ /     \ /   \ /                                                 C
7856 C       o     o       o     o                                                  C
7857 C       i             i                                                        C
7858 C                                                                              C
7859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7860       itk=itype2loc(itype(k))
7861       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7862       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7863       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7864       call transpose2(EUgC(1,1,k),auxmat(1,1))
7865       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7866       vv1(1)=pizda1(1,1)-pizda1(2,2)
7867       vv1(2)=pizda1(1,2)+pizda1(2,1)
7868       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7869       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7870       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7871       s5=scalar2(vv(1),Dtobr2(1,i))
7872 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7873       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7874       if (calc_grad) then
7875       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7876      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7877      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7878      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7879      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7880      & +scalar2(vv(1),Dtobr2der(1,i)))
7881       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7882       vv1(1)=pizda1(1,1)-pizda1(2,2)
7883       vv1(2)=pizda1(1,2)+pizda1(2,1)
7884       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7885       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7886       if (l.eq.j+1) then
7887         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7888      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7889      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7890      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7891      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7892       else
7893         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7894      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7895      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7896      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7897      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7898       endif
7899       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7900       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7901       vv1(1)=pizda1(1,1)-pizda1(2,2)
7902       vv1(2)=pizda1(1,2)+pizda1(2,1)
7903       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7904      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7905      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7906      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7907       do iii=1,2
7908         if (swap) then
7909           ind=3-iii
7910         else
7911           ind=iii
7912         endif
7913         do kkk=1,5
7914           do lll=1,3
7915             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7916             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7917             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7918             call transpose2(EUgC(1,1,k),auxmat(1,1))
7919             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7920      &        pizda1(1,1))
7921             vv1(1)=pizda1(1,1)-pizda1(2,2)
7922             vv1(2)=pizda1(1,2)+pizda1(2,1)
7923             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7924             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7925      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7926             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7927      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7928             s5=scalar2(vv(1),Dtobr2(1,i))
7929             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7930           enddo
7931         enddo
7932       enddo
7933       endif ! calc_grad
7934       return
7935       end
7936 c----------------------------------------------------------------------------
7937       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7938       implicit real*8 (a-h,o-z)
7939       include 'DIMENSIONS'
7940       include 'COMMON.IOUNITS'
7941       include 'COMMON.CHAIN'
7942       include 'COMMON.DERIV'
7943       include 'COMMON.INTERACT'
7944       include 'COMMON.CONTACTS'
7945       include 'COMMON.CONTMAT'
7946       include 'COMMON.CORRMAT'
7947       include 'COMMON.TORSION'
7948       include 'COMMON.VAR'
7949       include 'COMMON.GEO'
7950       logical swap
7951       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7952      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7953       logical lprn
7954       common /kutas/ lprn
7955 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7956 C                                                                              C
7957 C      Parallel       Antiparallel                                             C
7958 C                                                                              C
7959 C          o             o                                                     C
7960 C     \   /l\           /j\   /                                                C
7961 C      \ /   \         /   \ /                                                 C
7962 C       o| o |         | o |o                                                  C
7963 C     \ j|/k\|      \  |/k\|l                                                  C
7964 C      \ /   \       \ /   \                                                   C
7965 C       o             o                                                        C
7966 C       i             i                                                        C
7967 C                                                                              C
7968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7969 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7970 C AL 7/4/01 s1 would occur in the sixth-order moment,
7971 C           but not in a cluster cumulant
7972 #ifdef MOMENT
7973       s1=dip(1,jj,i)*dip(1,kk,k)
7974 #endif
7975       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7976       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7977       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7978       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7979       call transpose2(EUg(1,1,k),auxmat(1,1))
7980       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7981       vv(1)=pizda(1,1)-pizda(2,2)
7982       vv(2)=pizda(1,2)+pizda(2,1)
7983       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7984 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7985 #ifdef MOMENT
7986       eello6_graph2=-(s1+s2+s3+s4)
7987 #else
7988       eello6_graph2=-(s2+s3+s4)
7989 #endif
7990 c      eello6_graph2=-s3
7991 C Derivatives in gamma(i-1)
7992       if (calc_grad) then
7993       if (i.gt.1) then
7994 #ifdef MOMENT
7995         s1=dipderg(1,jj,i)*dip(1,kk,k)
7996 #endif
7997         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7998         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7999         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8000         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8001 #ifdef MOMENT
8002         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8003 #else
8004         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8005 #endif
8006 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8007       endif
8008 C Derivatives in gamma(k-1)
8009 #ifdef MOMENT
8010       s1=dip(1,jj,i)*dipderg(1,kk,k)
8011 #endif
8012       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8013       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8014       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8015       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8016       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8017       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8018       vv(1)=pizda(1,1)-pizda(2,2)
8019       vv(2)=pizda(1,2)+pizda(2,1)
8020       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8021 #ifdef MOMENT
8022       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8023 #else
8024       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8025 #endif
8026 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8027 C Derivatives in gamma(j-1) or gamma(l-1)
8028       if (j.gt.1) then
8029 #ifdef MOMENT
8030         s1=dipderg(3,jj,i)*dip(1,kk,k)
8031 #endif
8032         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8033         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8034         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8035         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8036         vv(1)=pizda(1,1)-pizda(2,2)
8037         vv(2)=pizda(1,2)+pizda(2,1)
8038         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8039 #ifdef MOMENT
8040         if (swap) then
8041           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8042         else
8043           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8044         endif
8045 #endif
8046         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8047 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8048       endif
8049 C Derivatives in gamma(l-1) or gamma(j-1)
8050       if (l.gt.1) then
8051 #ifdef MOMENT
8052         s1=dip(1,jj,i)*dipderg(3,kk,k)
8053 #endif
8054         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8055         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8056         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8057         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8058         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8059         vv(1)=pizda(1,1)-pizda(2,2)
8060         vv(2)=pizda(1,2)+pizda(2,1)
8061         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8062 #ifdef MOMENT
8063         if (swap) then
8064           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8065         else
8066           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8067         endif
8068 #endif
8069         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8070 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8071       endif
8072 C Cartesian derivatives.
8073       if (lprn) then
8074         write (2,*) 'In eello6_graph2'
8075         do iii=1,2
8076           write (2,*) 'iii=',iii
8077           do kkk=1,5
8078             write (2,*) 'kkk=',kkk
8079             do jjj=1,2
8080               write (2,'(3(2f10.5),5x)')
8081      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8082             enddo
8083           enddo
8084         enddo
8085       endif
8086       do iii=1,2
8087         do kkk=1,5
8088           do lll=1,3
8089 #ifdef MOMENT
8090             if (iii.eq.1) then
8091               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8092             else
8093               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8094             endif
8095 #endif
8096             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8097      &        auxvec(1))
8098             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8099             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8100      &        auxvec(1))
8101             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8102             call transpose2(EUg(1,1,k),auxmat(1,1))
8103             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8104      &        pizda(1,1))
8105             vv(1)=pizda(1,1)-pizda(2,2)
8106             vv(2)=pizda(1,2)+pizda(2,1)
8107             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8108 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8109 #ifdef MOMENT
8110             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8111 #else
8112             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8113 #endif
8114             if (swap) then
8115               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8116             else
8117               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8118             endif
8119           enddo
8120         enddo
8121       enddo
8122       endif ! calc_grad
8123       return
8124       end
8125 c----------------------------------------------------------------------------
8126       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8127       implicit real*8 (a-h,o-z)
8128       include 'DIMENSIONS'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.CONTMAT'
8135       include 'COMMON.CORRMAT'
8136       include 'COMMON.TORSION'
8137       include 'COMMON.VAR'
8138       include 'COMMON.GEO'
8139       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8140       logical swap
8141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8142 C                                                                              C
8143 C      Parallel       Antiparallel                                             C
8144 C                                                                              C
8145 C          o             o                                                     C
8146 C         /l\   /   \   /j\                                                    C
8147 C        /   \ /     \ /   \                                                   C
8148 C       /| o |o       o| o |\                                                  C
8149 C       j|/k\|  /      |/k\|l /                                                C
8150 C        /   \ /       /   \ /                                                 C
8151 C       /     o       /     o                                                  C
8152 C       i             i                                                        C
8153 C                                                                              C
8154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8155 C
8156 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8157 C           energy moment and not to the cluster cumulant.
8158       iti=itortyp(itype(i))
8159       if (j.lt.nres-1) then
8160         itj1=itype2loc(itype(j+1))
8161       else
8162         itj1=nloctyp
8163       endif
8164       itk=itype2loc(itype(k))
8165       itk1=itype2loc(itype(k+1))
8166       if (l.lt.nres-1) then
8167         itl1=itype2loc(itype(l+1))
8168       else
8169         itl1=nloctyp
8170       endif
8171 #ifdef MOMENT
8172       s1=dip(4,jj,i)*dip(4,kk,k)
8173 #endif
8174       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8175       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8176       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8177       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8178       call transpose2(EE(1,1,k),auxmat(1,1))
8179       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8180       vv(1)=pizda(1,1)+pizda(2,2)
8181       vv(2)=pizda(2,1)-pizda(1,2)
8182       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8183 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8184 cd     & "sum",-(s2+s3+s4)
8185 #ifdef MOMENT
8186       eello6_graph3=-(s1+s2+s3+s4)
8187 #else
8188       eello6_graph3=-(s2+s3+s4)
8189 #endif
8190 c      eello6_graph3=-s4
8191 C Derivatives in gamma(k-1)
8192       if (calc_grad) then
8193       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8194       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8195       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8196       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8197 C Derivatives in gamma(l-1)
8198       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8199       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8200       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8201       vv(1)=pizda(1,1)+pizda(2,2)
8202       vv(2)=pizda(2,1)-pizda(1,2)
8203       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8204       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8205 C Cartesian derivatives.
8206       do iii=1,2
8207         do kkk=1,5
8208           do lll=1,3
8209 #ifdef MOMENT
8210             if (iii.eq.1) then
8211               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8212             else
8213               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8214             endif
8215 #endif
8216             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8217      &        auxvec(1))
8218             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8219             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8220      &        auxvec(1))
8221             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8222             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8223      &        pizda(1,1))
8224             vv(1)=pizda(1,1)+pizda(2,2)
8225             vv(2)=pizda(2,1)-pizda(1,2)
8226             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8227 #ifdef MOMENT
8228             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8229 #else
8230             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8231 #endif
8232             if (swap) then
8233               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8234             else
8235               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8236             endif
8237 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8238           enddo
8239         enddo
8240       enddo
8241       endif ! calc_grad
8242       return
8243       end
8244 c----------------------------------------------------------------------------
8245       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8246       implicit real*8 (a-h,o-z)
8247       include 'DIMENSIONS'
8248       include 'COMMON.IOUNITS'
8249       include 'COMMON.CHAIN'
8250       include 'COMMON.DERIV'
8251       include 'COMMON.INTERACT'
8252       include 'COMMON.CONTACTS'
8253       include 'COMMON.CONTMAT'
8254       include 'COMMON.CORRMAT'
8255       include 'COMMON.TORSION'
8256       include 'COMMON.VAR'
8257       include 'COMMON.GEO'
8258       include 'COMMON.FFIELD'
8259       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8260      & auxvec1(2),auxmat1(2,2)
8261       logical swap
8262 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8263 C                                                                              C
8264 C      Parallel       Antiparallel                                             C
8265 C                                                                              C
8266 C          o             o                                                     C
8267 C         /l\   /   \   /j\                                                    C
8268 C        /   \ /     \ /   \                                                   C
8269 C       /| o |o       o| o |\                                                  C
8270 C     \ j|/k\|      \  |/k\|l                                                  C
8271 C      \ /   \       \ /   \                                                   C
8272 C       o     \       o     \                                                  C
8273 C       i             i                                                        C
8274 C                                                                              C
8275 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8276 C
8277 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8278 C           energy moment and not to the cluster cumulant.
8279 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8280       iti=itype2loc(itype(i))
8281       itj=itype2loc(itype(j))
8282       if (j.lt.nres-1) then
8283         itj1=itype2loc(itype(j+1))
8284       else
8285         itj1=nloctyp
8286       endif
8287       itk=itype2loc(itype(k))
8288       if (k.lt.nres-1) then
8289         itk1=itype2loc(itype(k+1))
8290       else
8291         itk1=nloctyp
8292       endif
8293       itl=itype2loc(itype(l))
8294       if (l.lt.nres-1) then
8295         itl1=itype2loc(itype(l+1))
8296       else
8297         itl1=nloctyp
8298       endif
8299 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8300 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8301 cd     & ' itl',itl,' itl1',itl1
8302 #ifdef MOMENT
8303       if (imat.eq.1) then
8304         s1=dip(3,jj,i)*dip(3,kk,k)
8305       else
8306         s1=dip(2,jj,j)*dip(2,kk,l)
8307       endif
8308 #endif
8309       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8310       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8311       if (j.eq.l+1) then
8312         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8313         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8314       else
8315         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8316         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8317       endif
8318       call transpose2(EUg(1,1,k),auxmat(1,1))
8319       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8320       vv(1)=pizda(1,1)-pizda(2,2)
8321       vv(2)=pizda(2,1)+pizda(1,2)
8322       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8323 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8324 #ifdef MOMENT
8325       eello6_graph4=-(s1+s2+s3+s4)
8326 #else
8327       eello6_graph4=-(s2+s3+s4)
8328 #endif
8329 C Derivatives in gamma(i-1)
8330       if (calc_grad) then
8331       if (i.gt.1) then
8332 #ifdef MOMENT
8333         if (imat.eq.1) then
8334           s1=dipderg(2,jj,i)*dip(3,kk,k)
8335         else
8336           s1=dipderg(4,jj,j)*dip(2,kk,l)
8337         endif
8338 #endif
8339         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8340         if (j.eq.l+1) then
8341           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8342           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8343         else
8344           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8345           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8346         endif
8347         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8348         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8349 cd          write (2,*) 'turn6 derivatives'
8350 #ifdef MOMENT
8351           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8352 #else
8353           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8354 #endif
8355         else
8356 #ifdef MOMENT
8357           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8358 #else
8359           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8360 #endif
8361         endif
8362       endif
8363 C Derivatives in gamma(k-1)
8364 #ifdef MOMENT
8365       if (imat.eq.1) then
8366         s1=dip(3,jj,i)*dipderg(2,kk,k)
8367       else
8368         s1=dip(2,jj,j)*dipderg(4,kk,l)
8369       endif
8370 #endif
8371       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8372       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8373       if (j.eq.l+1) then
8374         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8375         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8376       else
8377         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8378         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8379       endif
8380       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8381       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8382       vv(1)=pizda(1,1)-pizda(2,2)
8383       vv(2)=pizda(2,1)+pizda(1,2)
8384       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8385       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8386 #ifdef MOMENT
8387         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8388 #else
8389         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8390 #endif
8391       else
8392 #ifdef MOMENT
8393         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8394 #else
8395         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8396 #endif
8397       endif
8398 C Derivatives in gamma(j-1) or gamma(l-1)
8399       if (l.eq.j+1 .and. l.gt.1) then
8400         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8401         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8402         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8403         vv(1)=pizda(1,1)-pizda(2,2)
8404         vv(2)=pizda(2,1)+pizda(1,2)
8405         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8406         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8407       else if (j.gt.1) then
8408         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8409         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8410         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8411         vv(1)=pizda(1,1)-pizda(2,2)
8412         vv(2)=pizda(2,1)+pizda(1,2)
8413         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8414         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8415           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8416         else
8417           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8418         endif
8419       endif
8420 C Cartesian derivatives.
8421       do iii=1,2
8422         do kkk=1,5
8423           do lll=1,3
8424 #ifdef MOMENT
8425             if (iii.eq.1) then
8426               if (imat.eq.1) then
8427                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8428               else
8429                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8430               endif
8431             else
8432               if (imat.eq.1) then
8433                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8434               else
8435                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8436               endif
8437             endif
8438 #endif
8439             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8440      &        auxvec(1))
8441             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8442             if (j.eq.l+1) then
8443               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8444      &          b1(1,j+1),auxvec(1))
8445               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8446             else
8447               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8448      &          b1(1,l+1),auxvec(1))
8449               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8450             endif
8451             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8452      &        pizda(1,1))
8453             vv(1)=pizda(1,1)-pizda(2,2)
8454             vv(2)=pizda(2,1)+pizda(1,2)
8455             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8456             if (swap) then
8457               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8458 #ifdef MOMENT
8459                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8460      &             -(s1+s2+s4)
8461 #else
8462                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8463      &             -(s2+s4)
8464 #endif
8465                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8466               else
8467 #ifdef MOMENT
8468                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8469 #else
8470                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8471 #endif
8472                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8473               endif
8474             else
8475 #ifdef MOMENT
8476               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8477 #else
8478               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8479 #endif
8480               if (l.eq.j+1) then
8481                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8482               else
8483                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8484               endif
8485             endif
8486           enddo
8487         enddo
8488       enddo
8489       endif ! calc_grad
8490       return
8491       end
8492 c----------------------------------------------------------------------------
8493       double precision function eello_turn6(i,jj,kk)
8494       implicit real*8 (a-h,o-z)
8495       include 'DIMENSIONS'
8496       include 'COMMON.IOUNITS'
8497       include 'COMMON.CHAIN'
8498       include 'COMMON.DERIV'
8499       include 'COMMON.INTERACT'
8500       include 'COMMON.CONTACTS'
8501       include 'COMMON.CONTMAT'
8502       include 'COMMON.CORRMAT'
8503       include 'COMMON.TORSION'
8504       include 'COMMON.VAR'
8505       include 'COMMON.GEO'
8506       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8507      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8508      &  ggg1(3),ggg2(3)
8509       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8510      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8511 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8512 C           the respective energy moment and not to the cluster cumulant.
8513       s1=0.0d0
8514       s8=0.0d0
8515       s13=0.0d0
8516 c
8517       eello_turn6=0.0d0
8518       j=i+4
8519       k=i+1
8520       l=i+3
8521       iti=itype2loc(itype(i))
8522       itk=itype2loc(itype(k))
8523       itk1=itype2loc(itype(k+1))
8524       itl=itype2loc(itype(l))
8525       itj=itype2loc(itype(j))
8526 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8527 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8528 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8529 cd        eello6=0.0d0
8530 cd        return
8531 cd      endif
8532 cd      write (iout,*)
8533 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8534 cd     &   ' and',k,l
8535 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8536       do iii=1,2
8537         do kkk=1,5
8538           do lll=1,3
8539             derx_turn(lll,kkk,iii)=0.0d0
8540           enddo
8541         enddo
8542       enddo
8543 cd      eij=1.0d0
8544 cd      ekl=1.0d0
8545 cd      ekont=1.0d0
8546       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8547 cd      eello6_5=0.0d0
8548 cd      write (2,*) 'eello6_5',eello6_5
8549 #ifdef MOMENT
8550       call transpose2(AEA(1,1,1),auxmat(1,1))
8551       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8552       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8553       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8554 #endif
8555       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8556       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8557       s2 = scalar2(b1(1,k),vtemp1(1))
8558 #ifdef MOMENT
8559       call transpose2(AEA(1,1,2),atemp(1,1))
8560       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8561       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8562       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8563 #endif
8564       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8565       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8566       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8567 #ifdef MOMENT
8568       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8569       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8570       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8571       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8572       ss13 = scalar2(b1(1,k),vtemp4(1))
8573       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8574 #endif
8575 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8576 c      s1=0.0d0
8577 c      s2=0.0d0
8578 c      s8=0.0d0
8579 c      s12=0.0d0
8580 c      s13=0.0d0
8581       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8582 C Derivatives in gamma(i+2)
8583       if (calc_grad) then
8584       s1d =0.0d0
8585       s8d =0.0d0
8586 #ifdef MOMENT
8587       call transpose2(AEA(1,1,1),auxmatd(1,1))
8588       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8589       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8590       call transpose2(AEAderg(1,1,2),atempd(1,1))
8591       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8592       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8593 #endif
8594       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8595       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8596       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8597 c      s1d=0.0d0
8598 c      s2d=0.0d0
8599 c      s8d=0.0d0
8600 c      s12d=0.0d0
8601 c      s13d=0.0d0
8602       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8603 C Derivatives in gamma(i+3)
8604 #ifdef MOMENT
8605       call transpose2(AEA(1,1,1),auxmatd(1,1))
8606       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8607       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8608       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8609 #endif
8610       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8611       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8612       s2d = scalar2(b1(1,k),vtemp1d(1))
8613 #ifdef MOMENT
8614       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8615       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8616 #endif
8617       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8618 #ifdef MOMENT
8619       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8620       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8621       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8622 #endif
8623 c      s1d=0.0d0
8624 c      s2d=0.0d0
8625 c      s8d=0.0d0
8626 c      s12d=0.0d0
8627 c      s13d=0.0d0
8628 #ifdef MOMENT
8629       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8630      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8631 #else
8632       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8633      &               -0.5d0*ekont*(s2d+s12d)
8634 #endif
8635 C Derivatives in gamma(i+4)
8636       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8637       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8638       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8639 #ifdef MOMENT
8640       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8641       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8642       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8643 #endif
8644 c      s1d=0.0d0
8645 c      s2d=0.0d0
8646 c      s8d=0.0d0
8647 C      s12d=0.0d0
8648 c      s13d=0.0d0
8649 #ifdef MOMENT
8650       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8651 #else
8652       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8653 #endif
8654 C Derivatives in gamma(i+5)
8655 #ifdef MOMENT
8656       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8657       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8658       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8659 #endif
8660       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8661       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8662       s2d = scalar2(b1(1,k),vtemp1d(1))
8663 #ifdef MOMENT
8664       call transpose2(AEA(1,1,2),atempd(1,1))
8665       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8666       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8667 #endif
8668       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8669       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8670 #ifdef MOMENT
8671       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8672       ss13d = scalar2(b1(1,k),vtemp4d(1))
8673       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8674 #endif
8675 c      s1d=0.0d0
8676 c      s2d=0.0d0
8677 c      s8d=0.0d0
8678 c      s12d=0.0d0
8679 c      s13d=0.0d0
8680 #ifdef MOMENT
8681       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8682      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8683 #else
8684       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8685      &               -0.5d0*ekont*(s2d+s12d)
8686 #endif
8687 C Cartesian derivatives
8688       do iii=1,2
8689         do kkk=1,5
8690           do lll=1,3
8691 #ifdef MOMENT
8692             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8693             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8694             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8695 #endif
8696             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8697             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8698      &          vtemp1d(1))
8699             s2d = scalar2(b1(1,k),vtemp1d(1))
8700 #ifdef MOMENT
8701             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8702             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8703             s8d = -(atempd(1,1)+atempd(2,2))*
8704      &           scalar2(cc(1,1,l),vtemp2(1))
8705 #endif
8706             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8707      &           auxmatd(1,1))
8708             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8709             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8710 c      s1d=0.0d0
8711 c      s2d=0.0d0
8712 c      s8d=0.0d0
8713 c      s12d=0.0d0
8714 c      s13d=0.0d0
8715 #ifdef MOMENT
8716             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8717      &        - 0.5d0*(s1d+s2d)
8718 #else
8719             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8720      &        - 0.5d0*s2d
8721 #endif
8722 #ifdef MOMENT
8723             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8724      &        - 0.5d0*(s8d+s12d)
8725 #else
8726             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8727      &        - 0.5d0*s12d
8728 #endif
8729           enddo
8730         enddo
8731       enddo
8732 #ifdef MOMENT
8733       do kkk=1,5
8734         do lll=1,3
8735           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8736      &      achuj_tempd(1,1))
8737           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8738           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8739           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8740           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8741           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8742      &      vtemp4d(1))
8743           ss13d = scalar2(b1(1,k),vtemp4d(1))
8744           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8745           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8746         enddo
8747       enddo
8748 #endif
8749 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8750 cd     &  16*eel_turn6_num
8751 cd      goto 1112
8752       if (j.lt.nres-1) then
8753         j1=j+1
8754         j2=j-1
8755       else
8756         j1=j-1
8757         j2=j-2
8758       endif
8759       if (l.lt.nres-1) then
8760         l1=l+1
8761         l2=l-1
8762       else
8763         l1=l-1
8764         l2=l-2
8765       endif
8766       do ll=1,3
8767 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8768 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8769 cgrad        ghalf=0.5d0*ggg1(ll)
8770 cd        ghalf=0.0d0
8771         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8772         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8773         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8774      &    +ekont*derx_turn(ll,2,1)
8775         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8776         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8777      &    +ekont*derx_turn(ll,4,1)
8778         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8779         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8780         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8781 cgrad        ghalf=0.5d0*ggg2(ll)
8782 cd        ghalf=0.0d0
8783         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8784      &    +ekont*derx_turn(ll,2,2)
8785         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8786         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8787      &    +ekont*derx_turn(ll,4,2)
8788         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8789         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8790         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8791       enddo
8792 cd      goto 1112
8793 cgrad      do m=i+1,j-1
8794 cgrad        do ll=1,3
8795 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8796 cgrad        enddo
8797 cgrad      enddo
8798 cgrad      do m=k+1,l-1
8799 cgrad        do ll=1,3
8800 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8801 cgrad        enddo
8802 cgrad      enddo
8803 cgrad1112  continue
8804 cgrad      do m=i+2,j2
8805 cgrad        do ll=1,3
8806 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8807 cgrad        enddo
8808 cgrad      enddo
8809 cgrad      do m=k+2,l2
8810 cgrad        do ll=1,3
8811 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8812 cgrad        enddo
8813 cgrad      enddo
8814 cd      do iii=1,nres-3
8815 cd        write (2,*) iii,g_corr6_loc(iii)
8816 cd      enddo
8817       endif ! calc_grad
8818       eello_turn6=ekont*eel_turn6
8819 cd      write (2,*) 'ekont',ekont
8820 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8821       return
8822       end
8823 #endif
8824 crc-------------------------------------------------
8825 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8826       subroutine Eliptransfer(eliptran)
8827       implicit real*8 (a-h,o-z)
8828       include 'DIMENSIONS'
8829       include 'COMMON.GEO'
8830       include 'COMMON.VAR'
8831       include 'COMMON.LOCAL'
8832       include 'COMMON.CHAIN'
8833       include 'COMMON.DERIV'
8834       include 'COMMON.INTERACT'
8835       include 'COMMON.IOUNITS'
8836       include 'COMMON.CALC'
8837       include 'COMMON.CONTROL'
8838       include 'COMMON.SPLITELE'
8839       include 'COMMON.SBRIDGE'
8840 C this is done by Adasko
8841 C      print *,"wchodze"
8842 C structure of box:
8843 C      water
8844 C--bordliptop-- buffore starts
8845 C--bufliptop--- here true lipid starts
8846 C      lipid
8847 C--buflipbot--- lipid ends buffore starts
8848 C--bordlipbot--buffore ends
8849       eliptran=0.0
8850       do i=1,nres
8851 C       do i=1,1
8852         if (itype(i).eq.ntyp1) cycle
8853
8854         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8855         if (positi.le.0) positi=positi+boxzsize
8856 C        print *,i
8857 C first for peptide groups
8858 c for each residue check if it is in lipid or lipid water border area
8859        if ((positi.gt.bordlipbot)
8860      &.and.(positi.lt.bordliptop)) then
8861 C the energy transfer exist
8862         if (positi.lt.buflipbot) then
8863 C what fraction I am in
8864          fracinbuf=1.0d0-
8865      &        ((positi-bordlipbot)/lipbufthick)
8866 C lipbufthick is thickenes of lipid buffore
8867          sslip=sscalelip(fracinbuf)
8868          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8869          eliptran=eliptran+sslip*pepliptran
8870          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8871          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8872 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8873         elseif (positi.gt.bufliptop) then
8874          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8875          sslip=sscalelip(fracinbuf)
8876          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8877          eliptran=eliptran+sslip*pepliptran
8878          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8879          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8880 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8881 C          print *, "doing sscalefor top part"
8882 C         print *,i,sslip,fracinbuf,ssgradlip
8883         else
8884          eliptran=eliptran+pepliptran
8885 C         print *,"I am in true lipid"
8886         endif
8887 C       else
8888 C       eliptran=elpitran+0.0 ! I am in water
8889        endif
8890        enddo
8891 C       print *, "nic nie bylo w lipidzie?"
8892 C now multiply all by the peptide group transfer factor
8893 C       eliptran=eliptran*pepliptran
8894 C now the same for side chains
8895 CV       do i=1,1
8896        do i=1,nres
8897         if (itype(i).eq.ntyp1) cycle
8898         positi=(mod(c(3,i+nres),boxzsize))
8899         if (positi.le.0) positi=positi+boxzsize
8900 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8901 c for each residue check if it is in lipid or lipid water border area
8902 C       respos=mod(c(3,i+nres),boxzsize)
8903 C       print *,positi,bordlipbot,buflipbot
8904        if ((positi.gt.bordlipbot)
8905      & .and.(positi.lt.bordliptop)) then
8906 C the energy transfer exist
8907         if (positi.lt.buflipbot) then
8908          fracinbuf=1.0d0-
8909      &     ((positi-bordlipbot)/lipbufthick)
8910 C lipbufthick is thickenes of lipid buffore
8911          sslip=sscalelip(fracinbuf)
8912          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8913          eliptran=eliptran+sslip*liptranene(itype(i))
8914          gliptranx(3,i)=gliptranx(3,i)
8915      &+ssgradlip*liptranene(itype(i))
8916          gliptranc(3,i-1)= gliptranc(3,i-1)
8917      &+ssgradlip*liptranene(itype(i))
8918 C         print *,"doing sccale for lower part"
8919         elseif (positi.gt.bufliptop) then
8920          fracinbuf=1.0d0-
8921      &((bordliptop-positi)/lipbufthick)
8922          sslip=sscalelip(fracinbuf)
8923          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8924          eliptran=eliptran+sslip*liptranene(itype(i))
8925          gliptranx(3,i)=gliptranx(3,i)
8926      &+ssgradlip*liptranene(itype(i))
8927          gliptranc(3,i-1)= gliptranc(3,i-1)
8928      &+ssgradlip*liptranene(itype(i))
8929 C          print *, "doing sscalefor top part",sslip,fracinbuf
8930         else
8931          eliptran=eliptran+liptranene(itype(i))
8932 C         print *,"I am in true lipid"
8933         endif
8934         endif ! if in lipid or buffor
8935 C       else
8936 C       eliptran=elpitran+0.0 ! I am in water
8937        enddo
8938        return
8939        end
8940
8941
8942 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8943
8944       SUBROUTINE MATVEC2(A1,V1,V2)
8945       implicit real*8 (a-h,o-z)
8946       include 'DIMENSIONS'
8947       DIMENSION A1(2,2),V1(2),V2(2)
8948 c      DO 1 I=1,2
8949 c        VI=0.0
8950 c        DO 3 K=1,2
8951 c    3     VI=VI+A1(I,K)*V1(K)
8952 c        Vaux(I)=VI
8953 c    1 CONTINUE
8954
8955       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8956       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8957
8958       v2(1)=vaux1
8959       v2(2)=vaux2
8960       END
8961 C---------------------------------------
8962       SUBROUTINE MATMAT2(A1,A2,A3)
8963       implicit real*8 (a-h,o-z)
8964       include 'DIMENSIONS'
8965       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8966 c      DIMENSION AI3(2,2)
8967 c        DO  J=1,2
8968 c          A3IJ=0.0
8969 c          DO K=1,2
8970 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8971 c          enddo
8972 c          A3(I,J)=A3IJ
8973 c       enddo
8974 c      enddo
8975
8976       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8977       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8978       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8979       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8980
8981       A3(1,1)=AI3_11
8982       A3(2,1)=AI3_21
8983       A3(1,2)=AI3_12
8984       A3(2,2)=AI3_22
8985       END
8986
8987 c-------------------------------------------------------------------------
8988       double precision function scalar2(u,v)
8989       implicit none
8990       double precision u(2),v(2)
8991       double precision sc
8992       integer i
8993       scalar2=u(1)*v(1)+u(2)*v(2)
8994       return
8995       end
8996
8997 C-----------------------------------------------------------------------------
8998
8999       subroutine transpose2(a,at)
9000       implicit none
9001       double precision a(2,2),at(2,2)
9002       at(1,1)=a(1,1)
9003       at(1,2)=a(2,1)
9004       at(2,1)=a(1,2)
9005       at(2,2)=a(2,2)
9006       return
9007       end
9008 c--------------------------------------------------------------------------
9009       subroutine transpose(n,a,at)
9010       implicit none
9011       integer n,i,j
9012       double precision a(n,n),at(n,n)
9013       do i=1,n
9014         do j=1,n
9015           at(j,i)=a(i,j)
9016         enddo
9017       enddo
9018       return
9019       end
9020 C---------------------------------------------------------------------------
9021       subroutine prodmat3(a1,a2,kk,transp,prod)
9022       implicit none
9023       integer i,j
9024       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9025       logical transp
9026 crc      double precision auxmat(2,2),prod_(2,2)
9027
9028       if (transp) then
9029 crc        call transpose2(kk(1,1),auxmat(1,1))
9030 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9031 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9032
9033            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9034      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9035            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9036      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9037            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9038      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9039            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9040      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9041
9042       else
9043 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9044 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9045
9046            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9047      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9048            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9049      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9050            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9051      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9052            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9053      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9054
9055       endif
9056 c      call transpose2(a2(1,1),a2t(1,1))
9057
9058 crc      print *,transp
9059 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9060 crc      print *,((prod(i,j),i=1,2),j=1,2)
9061
9062       return
9063       end
9064 C-----------------------------------------------------------------------------
9065       double precision function scalar(u,v)
9066       implicit none
9067       double precision u(3),v(3)
9068       double precision sc
9069       integer i
9070       sc=0.0d0
9071       do i=1,3
9072         sc=sc+u(i)*v(i)
9073       enddo
9074       scalar=sc
9075       return
9076       end
9077 C-----------------------------------------------------------------------
9078       double precision function sscale(r)
9079       double precision r,gamm
9080       include "COMMON.SPLITELE"
9081       if(r.lt.r_cut-rlamb) then
9082         sscale=1.0d0
9083       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9084         gamm=(r-(r_cut-rlamb))/rlamb
9085         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9086       else
9087         sscale=0d0
9088       endif
9089       return
9090       end
9091 C-----------------------------------------------------------------------
9092 C-----------------------------------------------------------------------
9093       double precision function sscagrad(r)
9094       double precision r,gamm
9095       include "COMMON.SPLITELE"
9096       if(r.lt.r_cut-rlamb) then
9097         sscagrad=0.0d0
9098       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9099         gamm=(r-(r_cut-rlamb))/rlamb
9100         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9101       else
9102         sscagrad=0.0d0
9103       endif
9104       return
9105       end
9106 C-----------------------------------------------------------------------
9107 C-----------------------------------------------------------------------
9108       double precision function sscalelip(r)
9109       double precision r,gamm
9110       include "COMMON.SPLITELE"
9111 C      if(r.lt.r_cut-rlamb) then
9112 C        sscale=1.0d0
9113 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9114 C        gamm=(r-(r_cut-rlamb))/rlamb
9115         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9116 C      else
9117 C        sscale=0d0
9118 C      endif
9119       return
9120       end
9121 C-----------------------------------------------------------------------
9122       double precision function sscagradlip(r)
9123       double precision r,gamm
9124       include "COMMON.SPLITELE"
9125 C     if(r.lt.r_cut-rlamb) then
9126 C        sscagrad=0.0d0
9127 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9128 C        gamm=(r-(r_cut-rlamb))/rlamb
9129         sscagradlip=r*(6*r-6.0d0)
9130 C      else
9131 C        sscagrad=0.0d0
9132 C      endif
9133       return
9134       end
9135
9136 C-----------------------------------------------------------------------
9137        subroutine set_shield_fac
9138       implicit real*8 (a-h,o-z)
9139       include 'DIMENSIONS'
9140       include 'COMMON.CHAIN'
9141       include 'COMMON.DERIV'
9142       include 'COMMON.IOUNITS'
9143       include 'COMMON.SHIELD'
9144       include 'COMMON.INTERACT'
9145 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9146       double precision div77_81/0.974996043d0/,
9147      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9148
9149 C the vector between center of side_chain and peptide group
9150        double precision pep_side(3),long,side_calf(3),
9151      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9152      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9153 C the line belowe needs to be changed for FGPROC>1
9154       do i=1,nres-1
9155       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9156       ishield_list(i)=0
9157 Cif there two consequtive dummy atoms there is no peptide group between them
9158 C the line below has to be changed for FGPROC>1
9159       VolumeTotal=0.0
9160       do k=1,nres
9161        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9162        dist_pep_side=0.0
9163        dist_side_calf=0.0
9164        do j=1,3
9165 C first lets set vector conecting the ithe side-chain with kth side-chain
9166       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9167 C      pep_side(j)=2.0d0
9168 C and vector conecting the side-chain with its proper calfa
9169       side_calf(j)=c(j,k+nres)-c(j,k)
9170 C      side_calf(j)=2.0d0
9171       pept_group(j)=c(j,i)-c(j,i+1)
9172 C lets have their lenght
9173       dist_pep_side=pep_side(j)**2+dist_pep_side
9174       dist_side_calf=dist_side_calf+side_calf(j)**2
9175       dist_pept_group=dist_pept_group+pept_group(j)**2
9176       enddo
9177        dist_pep_side=dsqrt(dist_pep_side)
9178        dist_pept_group=dsqrt(dist_pept_group)
9179        dist_side_calf=dsqrt(dist_side_calf)
9180       do j=1,3
9181         pep_side_norm(j)=pep_side(j)/dist_pep_side
9182         side_calf_norm(j)=dist_side_calf
9183       enddo
9184 C now sscale fraction
9185        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9186 C       print *,buff_shield,"buff"
9187 C now sscale
9188         if (sh_frac_dist.le.0.0) cycle
9189 C If we reach here it means that this side chain reaches the shielding sphere
9190 C Lets add him to the list for gradient
9191         ishield_list(i)=ishield_list(i)+1
9192 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9193 C this list is essential otherwise problem would be O3
9194         shield_list(ishield_list(i),i)=k
9195 C Lets have the sscale value
9196         if (sh_frac_dist.gt.1.0) then
9197          scale_fac_dist=1.0d0
9198          do j=1,3
9199          sh_frac_dist_grad(j)=0.0d0
9200          enddo
9201         else
9202          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9203      &                   *(2.0*sh_frac_dist-3.0d0)
9204          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9205      &                  /dist_pep_side/buff_shield*0.5
9206 C remember for the final gradient multiply sh_frac_dist_grad(j)
9207 C for side_chain by factor -2 !
9208          do j=1,3
9209          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9210 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9211 C     &                    sh_frac_dist_grad(j)
9212          enddo
9213         endif
9214 C        if ((i.eq.3).and.(k.eq.2)) then
9215 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9216 C     & ,"TU"
9217 C        endif
9218
9219 C this is what is now we have the distance scaling now volume...
9220       short=short_r_sidechain(itype(k))
9221       long=long_r_sidechain(itype(k))
9222       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9223 C now costhet_grad
9224 C       costhet=0.0d0
9225        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9226 C       costhet_fac=0.0d0
9227        do j=1,3
9228          costhet_grad(j)=costhet_fac*pep_side(j)
9229        enddo
9230 C remember for the final gradient multiply costhet_grad(j)
9231 C for side_chain by factor -2 !
9232 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9233 C pep_side0pept_group is vector multiplication
9234       pep_side0pept_group=0.0
9235       do j=1,3
9236       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9237       enddo
9238       cosalfa=(pep_side0pept_group/
9239      & (dist_pep_side*dist_side_calf))
9240       fac_alfa_sin=1.0-cosalfa**2
9241       fac_alfa_sin=dsqrt(fac_alfa_sin)
9242       rkprim=fac_alfa_sin*(long-short)+short
9243 C now costhet_grad
9244        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9245        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9246
9247        do j=1,3
9248          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9249      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9250      &*(long-short)/fac_alfa_sin*cosalfa/
9251      &((dist_pep_side*dist_side_calf))*
9252      &((side_calf(j))-cosalfa*
9253      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9254
9255         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9256      &*(long-short)/fac_alfa_sin*cosalfa
9257      &/((dist_pep_side*dist_side_calf))*
9258      &(pep_side(j)-
9259      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9260        enddo
9261
9262       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9263      &                    /VSolvSphere_div
9264      &                    *wshield
9265 C now the gradient...
9266 C grad_shield is gradient of Calfa for peptide groups
9267 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9268 C     &               costhet,cosphi
9269 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9270 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9271       do j=1,3
9272       grad_shield(j,i)=grad_shield(j,i)
9273 C gradient po skalowaniu
9274      &                +(sh_frac_dist_grad(j)
9275 C  gradient po costhet
9276      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9277      &-scale_fac_dist*(cosphi_grad_long(j))
9278      &/(1.0-cosphi) )*div77_81
9279      &*VofOverlap
9280 C grad_shield_side is Cbeta sidechain gradient
9281       grad_shield_side(j,ishield_list(i),i)=
9282      &        (sh_frac_dist_grad(j)*(-2.0d0)
9283      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9284      &       +scale_fac_dist*(cosphi_grad_long(j))
9285      &        *2.0d0/(1.0-cosphi))
9286      &        *div77_81*VofOverlap
9287
9288        grad_shield_loc(j,ishield_list(i),i)=
9289      &   scale_fac_dist*cosphi_grad_loc(j)
9290      &        *2.0d0/(1.0-cosphi)
9291      &        *div77_81*VofOverlap
9292       enddo
9293       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9294       enddo
9295       fac_shield(i)=VolumeTotal*div77_81+div4_81
9296 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9297       enddo
9298       return
9299       end
9300 C--------------------------------------------------------------------------
9301 C first for shielding is setting of function of side-chains
9302        subroutine set_shield_fac2
9303       implicit real*8 (a-h,o-z)
9304       include 'DIMENSIONS'
9305       include 'COMMON.CHAIN'
9306       include 'COMMON.DERIV'
9307       include 'COMMON.IOUNITS'
9308       include 'COMMON.SHIELD'
9309       include 'COMMON.INTERACT'
9310 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9311       double precision div77_81/0.974996043d0/,
9312      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9313
9314 C the vector between center of side_chain and peptide group
9315        double precision pep_side(3),long,side_calf(3),
9316      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9317      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9318 C the line belowe needs to be changed for FGPROC>1
9319       do i=1,nres-1
9320       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9321       ishield_list(i)=0
9322 Cif there two consequtive dummy atoms there is no peptide group between them
9323 C the line below has to be changed for FGPROC>1
9324       VolumeTotal=0.0
9325       do k=1,nres
9326        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9327        dist_pep_side=0.0
9328        dist_side_calf=0.0
9329        do j=1,3
9330 C first lets set vector conecting the ithe side-chain with kth side-chain
9331       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9332 C      pep_side(j)=2.0d0
9333 C and vector conecting the side-chain with its proper calfa
9334       side_calf(j)=c(j,k+nres)-c(j,k)
9335 C      side_calf(j)=2.0d0
9336       pept_group(j)=c(j,i)-c(j,i+1)
9337 C lets have their lenght
9338       dist_pep_side=pep_side(j)**2+dist_pep_side
9339       dist_side_calf=dist_side_calf+side_calf(j)**2
9340       dist_pept_group=dist_pept_group+pept_group(j)**2
9341       enddo
9342        dist_pep_side=dsqrt(dist_pep_side)
9343        dist_pept_group=dsqrt(dist_pept_group)
9344        dist_side_calf=dsqrt(dist_side_calf)
9345       do j=1,3
9346         pep_side_norm(j)=pep_side(j)/dist_pep_side
9347         side_calf_norm(j)=dist_side_calf
9348       enddo
9349 C now sscale fraction
9350        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9351 C       print *,buff_shield,"buff"
9352 C now sscale
9353         if (sh_frac_dist.le.0.0) cycle
9354 C If we reach here it means that this side chain reaches the shielding sphere
9355 C Lets add him to the list for gradient
9356         ishield_list(i)=ishield_list(i)+1
9357 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9358 C this list is essential otherwise problem would be O3
9359         shield_list(ishield_list(i),i)=k
9360 C Lets have the sscale value
9361         if (sh_frac_dist.gt.1.0) then
9362          scale_fac_dist=1.0d0
9363          do j=1,3
9364          sh_frac_dist_grad(j)=0.0d0
9365          enddo
9366         else
9367          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9368      &                   *(2.0d0*sh_frac_dist-3.0d0)
9369          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9370      &                  /dist_pep_side/buff_shield*0.5d0
9371 C remember for the final gradient multiply sh_frac_dist_grad(j)
9372 C for side_chain by factor -2 !
9373          do j=1,3
9374          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9375 C         sh_frac_dist_grad(j)=0.0d0
9376 C         scale_fac_dist=1.0d0
9377 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9378 C     &                    sh_frac_dist_grad(j)
9379          enddo
9380         endif
9381 C this is what is now we have the distance scaling now volume...
9382       short=short_r_sidechain(itype(k))
9383       long=long_r_sidechain(itype(k))
9384       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9385       sinthet=short/dist_pep_side*costhet
9386 C now costhet_grad
9387 C       costhet=0.6d0
9388 C       sinthet=0.8
9389        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9390 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9391 C     &             -short/dist_pep_side**2/costhet)
9392 C       costhet_fac=0.0d0
9393        do j=1,3
9394          costhet_grad(j)=costhet_fac*pep_side(j)
9395        enddo
9396 C remember for the final gradient multiply costhet_grad(j)
9397 C for side_chain by factor -2 !
9398 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9399 C pep_side0pept_group is vector multiplication
9400       pep_side0pept_group=0.0d0
9401       do j=1,3
9402       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9403       enddo
9404       cosalfa=(pep_side0pept_group/
9405      & (dist_pep_side*dist_side_calf))
9406       fac_alfa_sin=1.0d0-cosalfa**2
9407       fac_alfa_sin=dsqrt(fac_alfa_sin)
9408       rkprim=fac_alfa_sin*(long-short)+short
9409 C      rkprim=short
9410
9411 C now costhet_grad
9412        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9413 C       cosphi=0.6
9414        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9415        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9416      &      dist_pep_side**2)
9417 C       sinphi=0.8
9418        do j=1,3
9419          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9420      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9421      &*(long-short)/fac_alfa_sin*cosalfa/
9422      &((dist_pep_side*dist_side_calf))*
9423      &((side_calf(j))-cosalfa*
9424      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9425 C       cosphi_grad_long(j)=0.0d0
9426         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9427      &*(long-short)/fac_alfa_sin*cosalfa
9428      &/((dist_pep_side*dist_side_calf))*
9429      &(pep_side(j)-
9430      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9431 C       cosphi_grad_loc(j)=0.0d0
9432        enddo
9433 C      print *,sinphi,sinthet
9434       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9435      &                    /VSolvSphere_div
9436 C     &                    *wshield
9437 C now the gradient...
9438       do j=1,3
9439       grad_shield(j,i)=grad_shield(j,i)
9440 C gradient po skalowaniu
9441      &                +(sh_frac_dist_grad(j)*VofOverlap
9442 C  gradient po costhet
9443      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9444      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9445      &       sinphi/sinthet*costhet*costhet_grad(j)
9446      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9447      & )*wshield
9448 C grad_shield_side is Cbeta sidechain gradient
9449       grad_shield_side(j,ishield_list(i),i)=
9450      &        (sh_frac_dist_grad(j)*(-2.0d0)
9451      &        *VofOverlap
9452      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9453      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9454      &       sinphi/sinthet*costhet*costhet_grad(j)
9455      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9456      &       )*wshield
9457
9458        grad_shield_loc(j,ishield_list(i),i)=
9459      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9460      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9461      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9462      &        ))
9463      &        *wshield
9464       enddo
9465       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9466       enddo
9467       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9468 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9469 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9470       enddo
9471       return
9472       end
9473 C--------------------------------------------------------------------------
9474       double precision function tschebyshev(m,n,x,y)
9475       implicit none
9476       include "DIMENSIONS"
9477       integer i,m,n
9478       double precision x(n),y,yy(0:maxvar),aux
9479 c Tschebyshev polynomial. Note that the first term is omitted
9480 c m=0: the constant term is included
9481 c m=1: the constant term is not included
9482       yy(0)=1.0d0
9483       yy(1)=y
9484       do i=2,n
9485         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9486       enddo
9487       aux=0.0d0
9488       do i=m,n
9489         aux=aux+x(i)*yy(i)
9490       enddo
9491       tschebyshev=aux
9492       return
9493       end
9494 C--------------------------------------------------------------------------
9495       double precision function gradtschebyshev(m,n,x,y)
9496       implicit none
9497       include "DIMENSIONS"
9498       integer i,m,n
9499       double precision x(n+1),y,yy(0:maxvar),aux
9500 c Tschebyshev polynomial. Note that the first term is omitted
9501 c m=0: the constant term is included
9502 c m=1: the constant term is not included
9503       yy(0)=1.0d0
9504       yy(1)=2.0d0*y
9505       do i=2,n
9506         yy(i)=2*y*yy(i-1)-yy(i-2)
9507       enddo
9508       aux=0.0d0
9509       do i=m,n
9510         aux=aux+x(i+1)*yy(i)*(i+1)
9511 C        print *, x(i+1),yy(i),i
9512       enddo
9513       gradtschebyshev=aux
9514       return
9515       end
9516 c----------------------------------------------------------------------------
9517       double precision function sscale2(r,r_cut,r0,rlamb)
9518       implicit none
9519       double precision r,gamm,r_cut,r0,rlamb,rr
9520       rr = dabs(r-r0)
9521 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9522 c      write (2,*) "rr",rr
9523       if(rr.lt.r_cut-rlamb) then
9524         sscale2=1.0d0
9525       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9526         gamm=(rr-(r_cut-rlamb))/rlamb
9527         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9528       else
9529         sscale2=0d0
9530       endif
9531       return
9532       end
9533 C-----------------------------------------------------------------------
9534       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9535       implicit none
9536       double precision r,gamm,r_cut,r0,rlamb,rr
9537       rr = dabs(r-r0)
9538       if(rr.lt.r_cut-rlamb) then
9539         sscalgrad2=0.0d0
9540       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9541         gamm=(rr-(r_cut-rlamb))/rlamb
9542         if (r.ge.r0) then
9543           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9544         else
9545           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9546         endif
9547       else
9548         sscalgrad2=0.0d0
9549       endif
9550       return
9551       end
9552 c----------------------------------------------------------------------------
9553       subroutine e_saxs(Esaxs_constr)
9554       implicit none
9555       include 'DIMENSIONS'
9556 #ifdef MPI
9557       include "mpif.h"
9558       include "COMMON.SETUP"
9559       integer IERR
9560 #endif
9561       include 'COMMON.SBRIDGE'
9562       include 'COMMON.CHAIN'
9563       include 'COMMON.GEO'
9564       include 'COMMON.LOCAL'
9565       include 'COMMON.INTERACT'
9566       include 'COMMON.VAR'
9567       include 'COMMON.IOUNITS'
9568       include 'COMMON.DERIV'
9569       include 'COMMON.CONTROL'
9570       include 'COMMON.NAMES'
9571       include 'COMMON.FFIELD'
9572       include 'COMMON.LANGEVIN'
9573       include 'COMMON.SAXS'
9574 c
9575       double precision Esaxs_constr
9576       integer i,iint,j,k,l
9577       double precision PgradC(maxSAXS,3,maxres),
9578      &  PgradX(maxSAXS,3,maxres)
9579 #ifdef MPI
9580       double precision PgradC_(maxSAXS,3,maxres),
9581      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9582 #endif
9583       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9584      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9585      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9586      & auxX,auxX1,CACAgrad,Cnorm
9587       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9588       double precision dist
9589       external dist
9590 c  SAXS restraint penalty function
9591 #ifdef DEBUG
9592       write(iout,*) "------- SAXS penalty function start -------"
9593       write (iout,*) "nsaxs",nsaxs
9594       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9595       write (iout,*) "Psaxs"
9596       do i=1,nsaxs
9597         write (iout,'(i5,e15.5)') i, Psaxs(i)
9598       enddo
9599 #endif
9600       Esaxs_constr = 0.0d0
9601       do k=1,nsaxs
9602         Pcalc(k)=0.0d0
9603         do j=1,nres
9604           do l=1,3
9605             PgradC(k,l,j)=0.0d0
9606             PgradX(k,l,j)=0.0d0
9607           enddo
9608         enddo
9609       enddo
9610       do i=iatsc_s,iatsc_e
9611        if (itype(i).eq.ntyp1) cycle
9612        do iint=1,nint_gr(i)
9613          do j=istart(i,iint),iend(i,iint)
9614            if (itype(j).eq.ntyp1) cycle
9615 #ifdef ALLSAXS
9616            dijCACA=dist(i,j)
9617            dijCASC=dist(i,j+nres)
9618            dijSCCA=dist(i+nres,j)
9619            dijSCSC=dist(i+nres,j+nres)
9620            sigma2CACA=2.0d0/(pstok**2)
9621            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9622            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9623            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9624            do k=1,nsaxs
9625              dk = distsaxs(k)
9626              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9627              if (itype(j).ne.10) then
9628              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9629              else
9630              endif
9631              expCASC = 0.0d0
9632              if (itype(i).ne.10) then
9633              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9634              else
9635              expSCCA = 0.0d0
9636              endif
9637              if (itype(i).ne.10 .and. itype(j).ne.10) then
9638              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9639              else
9640              expSCSC = 0.0d0
9641              endif
9642              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9643 #ifdef DEBUG
9644              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9645 #endif
9646              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9647              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9648              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9649              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9650              do l=1,3
9651 c CA CA
9652                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9653                PgradC(k,l,i) = PgradC(k,l,i)-aux
9654                PgradC(k,l,j) = PgradC(k,l,j)+aux
9655 c CA SC
9656                if (itype(j).ne.10) then
9657                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9658                PgradC(k,l,i) = PgradC(k,l,i)-aux
9659                PgradC(k,l,j) = PgradC(k,l,j)+aux
9660                PgradX(k,l,j) = PgradX(k,l,j)+aux
9661                endif
9662 c SC CA
9663                if (itype(i).ne.10) then
9664                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9665                PgradX(k,l,i) = PgradX(k,l,i)-aux
9666                PgradC(k,l,i) = PgradC(k,l,i)-aux
9667                PgradC(k,l,j) = PgradC(k,l,j)+aux
9668                endif
9669 c SC SC
9670                if (itype(i).ne.10 .and. itype(j).ne.10) then
9671                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9672                PgradC(k,l,i) = PgradC(k,l,i)-aux
9673                PgradC(k,l,j) = PgradC(k,l,j)+aux
9674                PgradX(k,l,i) = PgradX(k,l,i)-aux
9675                PgradX(k,l,j) = PgradX(k,l,j)+aux
9676                endif
9677              enddo ! l
9678            enddo ! k
9679 #else
9680            dijCACA=dist(i,j)
9681            sigma2CACA=scal_rad**2*0.25d0/
9682      &        (restok(itype(j))**2+restok(itype(i))**2)
9683
9684            IF (saxs_cutoff.eq.0) THEN
9685            do k=1,nsaxs
9686              dk = distsaxs(k)
9687              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9688              Pcalc(k) = Pcalc(k)+expCACA
9689              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9690              do l=1,3
9691                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9692                PgradC(k,l,i) = PgradC(k,l,i)-aux
9693                PgradC(k,l,j) = PgradC(k,l,j)+aux
9694              enddo ! l
9695            enddo ! k
9696            ELSE
9697            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9698            do k=1,nsaxs
9699              dk = distsaxs(k)
9700 c             write (2,*) "ijk",i,j,k
9701              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9702              if (sss2.eq.0.0d0) cycle
9703              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9704              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9705              Pcalc(k) = Pcalc(k)+expCACA
9706 #ifdef DEBUG
9707              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9708 #endif
9709              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9710      &             ssgrad2*expCACA/sss2
9711              do l=1,3
9712 c CA CA
9713                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9714                PgradC(k,l,i) = PgradC(k,l,i)+aux
9715                PgradC(k,l,j) = PgradC(k,l,j)-aux
9716              enddo ! l
9717            enddo ! k
9718            ENDIF
9719 #endif
9720          enddo ! j
9721        enddo ! iint
9722       enddo ! i
9723 #ifdef MPI
9724       if (nfgtasks.gt.1) then
9725         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9726      &    MPI_SUM,king,FG_COMM,IERR)
9727         if (fg_rank.eq.king) then
9728           do k=1,nsaxs
9729             Pcalc(k) = Pcalc_(k)
9730           enddo
9731         endif
9732         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9734         if (fg_rank.eq.king) then
9735           do i=1,nres
9736             do l=1,3
9737               do k=1,nsaxs
9738                 PgradC(k,l,i) = PgradC_(k,l,i)
9739               enddo
9740             enddo
9741           enddo
9742         endif
9743 #ifdef ALLSAXS
9744         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9746         if (fg_rank.eq.king) then
9747           do i=1,nres
9748             do l=1,3
9749               do k=1,nsaxs
9750                 PgradX(k,l,i) = PgradX_(k,l,i)
9751               enddo
9752             enddo
9753           enddo
9754         endif
9755 #endif
9756       endif
9757 #endif
9758 #ifdef MPI
9759       if (fg_rank.eq.king) then
9760 #endif
9761       Cnorm = 0.0d0
9762       do k=1,nsaxs
9763         Cnorm = Cnorm + Pcalc(k)
9764       enddo
9765       Esaxs_constr = dlog(Cnorm)-wsaxs0
9766       do k=1,nsaxs
9767         if (Pcalc(k).gt.0.0d0)
9768      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9769 #ifdef DEBUG
9770         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9771 #endif
9772       enddo
9773 #ifdef DEBUG
9774       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9775 #endif
9776       do i=nnt,nct
9777         do l=1,3
9778           auxC=0.0d0
9779           auxC1=0.0d0
9780           auxX=0.0d0
9781           auxX1=0.d0
9782           do k=1,nsaxs
9783             if (Pcalc(k).gt.0)
9784      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9785             auxC1 = auxC1+PgradC(k,l,i)
9786 #ifdef ALLSAXS
9787             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9788             auxX1 = auxX1+PgradX(k,l,i)
9789 #endif
9790           enddo
9791           gsaxsC(l,i) = auxC - auxC1/Cnorm
9792 #ifdef ALLSAXS
9793           gsaxsX(l,i) = auxX - auxX1/Cnorm
9794 #endif
9795 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9796 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9797         enddo
9798       enddo
9799 #ifdef MPI
9800       endif
9801 #endif
9802       return
9803       end
9804 c----------------------------------------------------------------------------
9805       subroutine e_saxsC(Esaxs_constr)
9806       implicit none
9807       include 'DIMENSIONS'
9808 #ifdef MPI
9809       include "mpif.h"
9810       include "COMMON.SETUP"
9811       integer IERR
9812 #endif
9813       include 'COMMON.SBRIDGE'
9814       include 'COMMON.CHAIN'
9815       include 'COMMON.GEO'
9816       include 'COMMON.LOCAL'
9817       include 'COMMON.INTERACT'
9818       include 'COMMON.VAR'
9819       include 'COMMON.IOUNITS'
9820       include 'COMMON.DERIV'
9821       include 'COMMON.CONTROL'
9822       include 'COMMON.NAMES'
9823       include 'COMMON.FFIELD'
9824       include 'COMMON.LANGEVIN'
9825       include 'COMMON.SAXS'
9826 c
9827       double precision Esaxs_constr
9828       integer i,iint,j,k,l
9829       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9830 #ifdef MPI
9831       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9832 #endif
9833       double precision dk,dijCASPH,dijSCSPH,
9834      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9835      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9836      & auxX,auxX1,Cnorm
9837 c  SAXS restraint penalty function
9838 #ifdef DEBUG
9839       write(iout,*) "------- SAXS penalty function start -------"
9840       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9841      & " isaxs_end",isaxs_end
9842       write (iout,*) "nnt",nnt," ntc",nct
9843       do i=nnt,nct
9844         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9845      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9846       enddo
9847       do i=nnt,nct
9848         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9849       enddo
9850 #endif
9851       Esaxs_constr = 0.0d0
9852       logPtot=0.0d0
9853       do j=isaxs_start,isaxs_end
9854         Pcalc_=0.0d0
9855         do i=1,nres
9856           do l=1,3
9857             PgradC(l,i)=0.0d0
9858             PgradX(l,i)=0.0d0
9859           enddo
9860         enddo
9861         do i=nnt,nct
9862           dijCASPH=0.0d0
9863           dijSCSPH=0.0d0
9864           do l=1,3
9865             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9866           enddo
9867           if (itype(i).ne.10) then
9868           do l=1,3
9869             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9870           enddo
9871           endif
9872           sigma2CA=2.0d0/pstok**2
9873           sigma2SC=4.0d0/restok(itype(i))**2
9874           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9875           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9876           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9877 #ifdef DEBUG
9878           write(*,*) "processor i j Pcalc",
9879      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9880 #endif
9881           CASPHgrad = sigma2CA*expCASPH
9882           SCSPHgrad = sigma2SC*expSCSPH
9883           do l=1,3
9884             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9885             PgradX(l,i) = PgradX(l,i) + aux
9886             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9887           enddo ! l
9888         enddo ! i
9889         do i=nnt,nct
9890           do l=1,3
9891             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9892             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9893           enddo
9894         enddo
9895         logPtot = logPtot - dlog(Pcalc_)
9896 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9897 c     &    " logPtot",logPtot
9898       enddo ! j
9899 #ifdef MPI
9900       if (nfgtasks.gt.1) then
9901 c        write (iout,*) "logPtot before reduction",logPtot
9902         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9903      &    MPI_SUM,king,FG_COMM,IERR)
9904         logPtot = logPtot_
9905 c        write (iout,*) "logPtot after reduction",logPtot
9906         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9907      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9908         if (fg_rank.eq.king) then
9909           do i=1,nres
9910             do l=1,3
9911               gsaxsC(l,i) = gsaxsC_(l,i)
9912             enddo
9913           enddo
9914         endif
9915         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9916      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9917         if (fg_rank.eq.king) then
9918           do i=1,nres
9919             do l=1,3
9920               gsaxsX(l,i) = gsaxsX_(l,i)
9921             enddo
9922           enddo
9923         endif
9924       endif
9925 #endif
9926       Esaxs_constr = logPtot
9927       return
9928       end
9929 C--------------------------------------------------------------------------
9930 c MODELLER restraint function
9931       subroutine e_modeller(ehomology_constr)
9932       implicit real*8 (a-h,o-z)
9933       include 'DIMENSIONS'
9934       integer nnn, i, j, k, ki, irec, l
9935       integer katy, odleglosci, test7
9936       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
9937       real*8 distance(max_template),distancek(max_template),
9938      &    min_odl,godl(max_template),dih_diff(max_template)
9939
9940 c
9941 c     FP - 30/10/2014 Temporary specifications for homology restraints
9942 c
9943       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
9944      &                 sgtheta
9945       double precision, dimension (maxres) :: guscdiff,usc_diff
9946       double precision, dimension (max_template) ::
9947      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
9948      &           theta_diff
9949
9950       include 'COMMON.SBRIDGE'
9951       include 'COMMON.CHAIN'
9952       include 'COMMON.GEO'
9953       include 'COMMON.DERIV'
9954       include 'COMMON.LOCAL'
9955       include 'COMMON.INTERACT'
9956       include 'COMMON.VAR'
9957       include 'COMMON.IOUNITS'
9958       include 'COMMON.CONTROL'
9959       include 'COMMON.HOMRESTR'
9960       include 'COMMON.HOMOLOGY'
9961       include 'COMMON.SETUP'
9962       include 'COMMON.NAMES'
9963
9964       do i=1,max_template
9965         distancek(i)=9999999.9
9966       enddo
9967
9968       odleg=0.0d0
9969
9970 c Pseudo-energy and gradient from homology restraints (MODELLER-like
9971 c function)
9972 C AL 5/2/14 - Introduce list of restraints
9973 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
9974 #ifdef DEBUG
9975       write(iout,*) "------- dist restrs start -------"
9976 #endif
9977       do ii = link_start_homo,link_end_homo
9978          i = ires_homo(ii)
9979          j = jres_homo(ii)
9980          dij=dist(i,j)
9981 c        write (iout,*) "dij(",i,j,") =",dij
9982          nexl=0
9983          do k=1,constr_homology
9984            if(.not.l_homo(k,ii)) then
9985               nexl=nexl+1
9986               cycle
9987            endif
9988            distance(k)=odl(k,ii)-dij
9989 c          write (iout,*) "distance(",k,") =",distance(k)
9990 c
9991 c          For Gaussian-type Urestr
9992 c
9993            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
9994 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
9995 c          write (iout,*) "distancek(",k,") =",distancek(k)
9996 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
9997 c
9998 c          For Lorentzian-type Urestr
9999 c
10000            if (waga_dist.lt.0.0d0) then
10001               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10002               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10003      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10004            endif
10005          enddo
10006
10007 c         min_odl=minval(distancek)
10008          if (nexl.gt.0) then
10009            min_odl=0.0d0
10010          else
10011            do kk=1,constr_homology
10012             if(l_homo(kk,ii)) then
10013               min_odl=distancek(kk)
10014               exit
10015             endif
10016            enddo
10017            do kk=1,constr_homology
10018             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10019      &              min_odl=distancek(kk)
10020            enddo
10021          endif
10022 c        write (iout,* )"min_odl",min_odl
10023 #ifdef DEBUG
10024          write (iout,*) "ij dij",i,j,dij
10025          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10026          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10027          write (iout,* )"min_odl",min_odl
10028 #endif
10029 #ifdef OLDRESTR
10030          odleg2=0.0d0
10031 #else
10032          if (waga_dist.ge.0.0d0) then
10033            odleg2=nexl
10034          else
10035            odleg2=0.0d0
10036          endif
10037 #endif
10038          do k=1,constr_homology
10039 c Nie wiem po co to liczycie jeszcze raz!
10040 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10041 c     &              (2*(sigma_odl(i,j,k))**2))
10042            if(.not.l_homo(k,ii)) cycle
10043            if (waga_dist.ge.0.0d0) then
10044 c
10045 c          For Gaussian-type Urestr
10046 c
10047             godl(k)=dexp(-distancek(k)+min_odl)
10048             odleg2=odleg2+godl(k)
10049 c
10050 c          For Lorentzian-type Urestr
10051 c
10052            else
10053             odleg2=odleg2+distancek(k)
10054            endif
10055
10056 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10057 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10058 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10059 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10060
10061          enddo
10062 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10063 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10064 #ifdef DEBUG
10065          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10066          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10067 #endif
10068            if (waga_dist.ge.0.0d0) then
10069 c
10070 c          For Gaussian-type Urestr
10071 c
10072               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10073 c
10074 c          For Lorentzian-type Urestr
10075 c
10076            else
10077               odleg=odleg+odleg2/constr_homology
10078            endif
10079 c
10080 #ifdef GRAD
10081 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10082 c Gradient
10083 c
10084 c          For Gaussian-type Urestr
10085 c
10086          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10087          sum_sgodl=0.0d0
10088          do k=1,constr_homology
10089 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10090 c     &           *waga_dist)+min_odl
10091 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10092 c
10093          if(.not.l_homo(k,ii)) cycle
10094          if (waga_dist.ge.0.0d0) then
10095 c          For Gaussian-type Urestr
10096 c
10097            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10098 c
10099 c          For Lorentzian-type Urestr
10100 c
10101          else
10102            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10103      &           sigma_odlir(k,ii)**2)**2)
10104          endif
10105            sum_sgodl=sum_sgodl+sgodl
10106
10107 c            sgodl2=sgodl2+sgodl
10108 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10109 c      write(iout,*) "constr_homology=",constr_homology
10110 c      write(iout,*) i, j, k, "TEST K"
10111          enddo
10112          if (waga_dist.ge.0.0d0) then
10113 c
10114 c          For Gaussian-type Urestr
10115 c
10116             grad_odl3=waga_homology(iset)*waga_dist
10117      &                *sum_sgodl/(sum_godl*dij)
10118 c
10119 c          For Lorentzian-type Urestr
10120 c
10121          else
10122 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10123 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10124             grad_odl3=-waga_homology(iset)*waga_dist*
10125      &                sum_sgodl/(constr_homology*dij)
10126          endif
10127 c
10128 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10129
10130
10131 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10132 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10133 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10134
10135 ccc      write(iout,*) godl, sgodl, grad_odl3
10136
10137 c          grad_odl=grad_odl+grad_odl3
10138
10139          do jik=1,3
10140             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10141 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10142 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10143 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10144             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10145             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10146 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10147 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10148 c         if (i.eq.25.and.j.eq.27) then
10149 c         write(iout,*) "jik",jik,"i",i,"j",j
10150 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10151 c         write(iout,*) "grad_odl3",grad_odl3
10152 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10153 c         write(iout,*) "ggodl",ggodl
10154 c         write(iout,*) "ghpbc(",jik,i,")",
10155 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10156 c     &                 ghpbc(jik,j)
10157 c         endif
10158          enddo
10159 #endif
10160 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10161 ccc     & dLOG(odleg2),"-odleg=", -odleg
10162
10163       enddo ! ii-loop for dist
10164 #ifdef DEBUG
10165       write(iout,*) "------- dist restrs end -------"
10166 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10167 c    &     waga_d.eq.1.0d0) call sum_gradient
10168 #endif
10169 c Pseudo-energy and gradient from dihedral-angle restraints from
10170 c homology templates
10171 c      write (iout,*) "End of distance loop"
10172 c      call flush(iout)
10173       kat=0.0d0
10174 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10175 #ifdef DEBUG
10176       write(iout,*) "------- dih restrs start -------"
10177       do i=idihconstr_start_homo,idihconstr_end_homo
10178         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10179       enddo
10180 #endif
10181       do i=idihconstr_start_homo,idihconstr_end_homo
10182         kat2=0.0d0
10183 c        betai=beta(i,i+1,i+2,i+3)
10184         betai = phi(i)
10185 c       write (iout,*) "betai =",betai
10186         do k=1,constr_homology
10187           dih_diff(k)=pinorm(dih(k,i)-betai)
10188 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10189 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10190 c     &                                   -(6.28318-dih_diff(i,k))
10191 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10192 c     &                                   6.28318+dih_diff(i,k)
10193 #ifdef OLD_DIHED
10194           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10195 #else
10196           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10197 #endif
10198 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10199           gdih(k)=dexp(kat3)
10200           kat2=kat2+gdih(k)
10201 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10202 c          write(*,*)""
10203         enddo
10204 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10205 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10206 #ifdef DEBUG
10207         write (iout,*) "i",i," betai",betai," kat2",kat2
10208         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10209 #endif
10210         if (kat2.le.1.0d-14) cycle
10211         kat=kat-dLOG(kat2/constr_homology)
10212 c       write (iout,*) "kat",kat ! sum of -ln-s
10213
10214 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10215 ccc     & dLOG(kat2), "-kat=", -kat
10216
10217 #ifdef GRAD
10218 c ----------------------------------------------------------------------
10219 c Gradient
10220 c ----------------------------------------------------------------------
10221
10222         sum_gdih=kat2
10223         sum_sgdih=0.0d0
10224         do k=1,constr_homology
10225 #ifdef OLD_DIHED
10226           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10227 #else
10228           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10229 #endif
10230 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10231           sum_sgdih=sum_sgdih+sgdih
10232         enddo
10233 c       grad_dih3=sum_sgdih/sum_gdih
10234         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10235
10236 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10237 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10238 ccc     & gloc(nphi+i-3,icg)
10239         gloc(i,icg)=gloc(i,icg)+grad_dih3
10240 c        if (i.eq.25) then
10241 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10242 c        endif
10243 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10244 ccc     & gloc(nphi+i-3,icg)
10245 #endif
10246       enddo ! i-loop for dih
10247 #ifdef DEBUG
10248       write(iout,*) "------- dih restrs end -------"
10249 #endif
10250
10251 c Pseudo-energy and gradient for theta angle restraints from
10252 c homology templates
10253 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10254 c adapted
10255
10256 c
10257 c     For constr_homology reference structures (FP)
10258 c
10259 c     Uconst_back_tot=0.0d0
10260       Eval=0.0d0
10261       Erot=0.0d0
10262 c     Econstr_back legacy
10263 #ifdef GRAD
10264       do i=1,nres
10265 c     do i=ithet_start,ithet_end
10266        dutheta(i)=0.0d0
10267 c     enddo
10268 c     do i=loc_start,loc_end
10269         do j=1,3
10270           duscdiff(j,i)=0.0d0
10271           duscdiffx(j,i)=0.0d0
10272         enddo
10273       enddo
10274 #endif
10275 c
10276 c     do iref=1,nref
10277 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10278 c     write (iout,*) "waga_theta",waga_theta
10279       if (waga_theta.gt.0.0d0) then
10280 #ifdef DEBUG
10281       write (iout,*) "usampl",usampl
10282       write(iout,*) "------- theta restrs start -------"
10283 c     do i=ithet_start,ithet_end
10284 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10285 c     enddo
10286 #endif
10287 c     write (iout,*) "maxres",maxres,"nres",nres
10288
10289       do i=ithet_start,ithet_end
10290 c
10291 c     do i=1,nfrag_back
10292 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10293 c
10294 c Deviation of theta angles wrt constr_homology ref structures
10295 c
10296         utheta_i=0.0d0 ! argument of Gaussian for single k
10297         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10298 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10299 c       over residues in a fragment
10300 c       write (iout,*) "theta(",i,")=",theta(i)
10301         do k=1,constr_homology
10302 c
10303 c         dtheta_i=theta(j)-thetaref(j,iref)
10304 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10305           theta_diff(k)=thetatpl(k,i)-theta(i)
10306 c
10307           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10308 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10309           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10310           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10311 c         Gradient for single Gaussian restraint in subr Econstr_back
10312 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10313 c
10314         enddo
10315 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10316 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10317
10318 c
10319 #ifdef GRAD
10320 c         Gradient for multiple Gaussian restraint
10321         sum_gtheta=gutheta_i
10322         sum_sgtheta=0.0d0
10323         do k=1,constr_homology
10324 c        New generalized expr for multiple Gaussian from Econstr_back
10325          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10326 c
10327 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10328           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10329         enddo
10330 c
10331 c       Final value of gradient using same var as in Econstr_back
10332         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10333      &               *waga_homology(iset)
10334 c       dutheta(i)=sum_sgtheta/sum_gtheta
10335 c
10336 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10337 #endif
10338         Eval=Eval-dLOG(gutheta_i/constr_homology)
10339 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10340 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10341 c       Uconst_back=Uconst_back+utheta(i)
10342       enddo ! (i-loop for theta)
10343 #ifdef DEBUG
10344       write(iout,*) "------- theta restrs end -------"
10345 #endif
10346       endif
10347 c
10348 c Deviation of local SC geometry
10349 c
10350 c Separation of two i-loops (instructed by AL - 11/3/2014)
10351 c
10352 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10353 c     write (iout,*) "waga_d",waga_d
10354
10355 #ifdef DEBUG
10356       write(iout,*) "------- SC restrs start -------"
10357       write (iout,*) "Initial duscdiff,duscdiffx"
10358       do i=loc_start,loc_end
10359         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10360      &                 (duscdiffx(jik,i),jik=1,3)
10361       enddo
10362 #endif
10363       do i=loc_start,loc_end
10364         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10365         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10366 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10367 c       write(iout,*) "xxtab, yytab, zztab"
10368 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10369         do k=1,constr_homology
10370 c
10371           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10372 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10373           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10374           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10375 c         write(iout,*) "dxx, dyy, dzz"
10376 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10377 c
10378           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10379 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10380 c         uscdiffk(k)=usc_diff(i)
10381           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10382           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10383 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10384 c     &      xxref(j),yyref(j),zzref(j)
10385         enddo
10386 c
10387 c       Gradient
10388 c
10389 c       Generalized expression for multiple Gaussian acc to that for a single
10390 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10391 c
10392 c       Original implementation
10393 c       sum_guscdiff=guscdiff(i)
10394 c
10395 c       sum_sguscdiff=0.0d0
10396 c       do k=1,constr_homology
10397 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10398 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10399 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10400 c       enddo
10401 c
10402 c       Implementation of new expressions for gradient (Jan. 2015)
10403 c
10404 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10405 #ifdef GRAD
10406         do k=1,constr_homology
10407 c
10408 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10409 c       before. Now the drivatives should be correct
10410 c
10411           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10412 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10413           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10414           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10415 c
10416 c         New implementation
10417 c
10418           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10419      &                 sigma_d(k,i) ! for the grad wrt r'
10420 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10421 c
10422 c
10423 c        New implementation
10424          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10425          do jik=1,3
10426             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10427      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10428      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10429             duscdiff(jik,i)=duscdiff(jik,i)+
10430      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10431      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10432             duscdiffx(jik,i)=duscdiffx(jik,i)+
10433      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10434      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10435 c
10436 #ifdef DEBUG
10437              write(iout,*) "jik",jik,"i",i
10438              write(iout,*) "dxx, dyy, dzz"
10439              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10440              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10441 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10442 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10443 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10444 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10445 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10446 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10447 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10448 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10449 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10450 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10451 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10452 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10453 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10454 c            endif
10455 #endif
10456          enddo
10457         enddo
10458 #endif
10459 c
10460 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10461 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10462 c
10463 c        write (iout,*) i," uscdiff",uscdiff(i)
10464 c
10465 c Put together deviations from local geometry
10466
10467 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10468 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10469         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10470 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10471 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10472 c       Uconst_back=Uconst_back+usc_diff(i)
10473 c
10474 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10475 c
10476 c     New implment: multiplied by sum_sguscdiff
10477 c
10478
10479       enddo ! (i-loop for dscdiff)
10480
10481 c      endif
10482
10483 #ifdef DEBUG
10484       write(iout,*) "------- SC restrs end -------"
10485         write (iout,*) "------ After SC loop in e_modeller ------"
10486         do i=loc_start,loc_end
10487          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10488          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10489         enddo
10490       if (waga_theta.eq.1.0d0) then
10491       write (iout,*) "in e_modeller after SC restr end: dutheta"
10492       do i=ithet_start,ithet_end
10493         write (iout,*) i,dutheta(i)
10494       enddo
10495       endif
10496       if (waga_d.eq.1.0d0) then
10497       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10498       do i=1,nres
10499         write (iout,*) i,(duscdiff(j,i),j=1,3)
10500         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10501       enddo
10502       endif
10503 #endif
10504
10505 c Total energy from homology restraints
10506 #ifdef DEBUG
10507       write (iout,*) "odleg",odleg," kat",kat
10508       write (iout,*) "odleg",odleg," kat",kat
10509       write (iout,*) "Eval",Eval," Erot",Erot
10510       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10511       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10512       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10513 #endif
10514 c
10515 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10516 c
10517 c     ehomology_constr=odleg+kat
10518 c
10519 c     For Lorentzian-type Urestr
10520 c
10521
10522       if (waga_dist.ge.0.0d0) then
10523 c
10524 c          For Gaussian-type Urestr
10525 c
10526 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10527 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10528         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10529      &              waga_theta*Eval+waga_d*Erot
10530 c     write (iout,*) "ehomology_constr=",ehomology_constr
10531       else
10532 c
10533 c          For Lorentzian-type Urestr
10534 c
10535 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10536 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10537         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10538      &              waga_theta*Eval+waga_d*Erot
10539 c     write (iout,*) "ehomology_constr=",ehomology_constr
10540       endif
10541 #ifdef DEBUG
10542       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10543      & "Eval",waga_theta,eval,
10544      &   "Erot",waga_d,Erot
10545       write (iout,*) "ehomology_constr",ehomology_constr
10546 #endif
10547       return
10548
10549   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10550   747 format(a12,i4,i4,i4,f8.3,f8.3)
10551   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10552   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10553   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10554      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10555       end