source/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       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  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      write(iout,*) 'po elektostatyce'
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 continue
  51       call vec_and_deriv
  52       if (shield_mode.eq.1) then
  53        call set_shield_fac
  54       else if  (shield_mode.eq.2) then
  55        call set_shield_fac2
  56       endif
  57       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  58 C            write(iout,*) 'po eelec'
  59
  60 C Calculate excluded-volume interaction energy between peptide groups
  61 C and side chains.
  62 C
  63       call escp(evdw2,evdw2_14)
  64 c
  65 c Calculate the bond-stretching energy
  66 c
  67
  68       call ebond(estr)
  69 C       write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79 C      print *,'Bend energy finished.'
  80       if (wang.gt.0d0) then
  81        if (tor_mode.eq.0) then
  82          call ebend(ebe)
  83        else
  84 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  85 C energy function
  86          call ebend_kcc(ebe)
  87        endif
  88       else
  89         ebe=0.0d0
  90       endif
  91       ethetacnstr=0.0d0
  92       if (with_theta_constr) call etheta_constr(ethetacnstr)
  93 c      call ebend(ebe,ethetacnstr)
  94 cd    print *,'Bend energy finished.'
  95 C
  96 C Calculate the SC local energy.
  97 C
  98       call esc(escloc)
  99 C       print *,'SCLOC energy finished.'
 100 C
 101 C Calculate the virtual-bond torsional energy.
 102 C
 103       if (wtor.gt.0.0d0) then
 104          if (tor_mode.eq.0) then
 105            call etor(etors,fact(1))
 106          else
 107 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 108 C energy function
 109            call etor_kcc(etors,fact(1))
 110          endif
 111       else
 112         etors=0.0d0
 113       endif
 114       edihcnstr=0.0d0
 115       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 116 c      print *,"Processor",myrank," computed Utor"
 117 C
 118 C 6/23/01 Calculate double-torsional energy
 119 C
 120       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 121         call etor_d(etors_d,fact(2))
 122       else
 123         etors_d=0
 124       endif
 125 c      print *,"Processor",myrank," computed Utord"
 126 C
 127       if (wsccor.gt.0.0d0) then
 128         call eback_sc_corr(esccor)
 129       else
 130         esccor=0.0d0
 131       endif
 132
 133       if (wliptran.gt.0) then
 134         call Eliptransfer(eliptran)
 135       else
 136         eliptran=0.0d0
 137       endif
 138 #ifdef FOURBODY
 139 C
 140 C 12/1/95 Multi-body terms
 141 C
 142       n_corr=0
 143       n_corr1=0
 144       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 145      &    .or. wturn6.gt.0.0d0) then
 146 c         write(iout,*)"calling multibody_eello"
 147          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 148 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 149 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 150       else
 151          ecorr=0.0d0
 152          ecorr5=0.0d0
 153          ecorr6=0.0d0
 154          eturn6=0.0d0
 155       endif
 156       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 157 c         write (iout,*) "Calling multibody_hbond"
 158          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 159       endif
 160 #endif
 161 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 162       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 163         call e_saxs(Esaxs_constr)
 164 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 165       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 166         call e_saxsC(Esaxs_constr)
 167 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 168       else
 169         Esaxs_constr = 0.0d0
 170       endif
 171
 172 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 173       if (constr_homology.ge.1) then
 174         call e_modeller(ehomology_constr)
 175       else
 176         ehomology_constr=0.0d0
 177       endif
 178
 179 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 180 #ifdef DFA
 181 C     BARTEK for dfa test!
 182       if (wdfa_dist.gt.0) call edfad(edfadis)
 183 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 184       if (wdfa_tor.gt.0) call edfat(edfator)
 185 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 186       if (wdfa_nei.gt.0) call edfan(edfanei)
 187 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 188       if (wdfa_beta.gt.0) call edfab(edfabet)
 189 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 190 #endif
 191
 192 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 193 #ifdef SPLITELE
 194       if (shield_mode.gt.0) then
 195       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 196      & +welec*fact(1)*ees
 197      & +fact(1)*wvdwpp*evdw1
 198      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 199      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 200      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 201      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 202      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 203      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 204      & +wliptran*eliptran*esaxs_constr
 205      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 206      & +wdfa_beta*edfabet
 207       else
 208       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 209      & +wvdwpp*evdw1
 210      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 211      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 212      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 213      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 214      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 215      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 216      & +wliptran*eliptran+wsaxs*esaxs_constr
 217      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 218      & +wdfa_beta*edfabet
 219       endif
 220 #else
 221       if (shield_mode.gt.0) then
 222       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 223      & +welec*fact(1)*(ees+evdw1)
 224      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 225      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 226      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 227      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 228      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 229      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 230      & +wliptran*eliptran+wsaxs*esaxs_constr
 231      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 232      & +wdfa_beta*edfabet
 233       else
 234       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 235      & +welec*fact(1)*(ees+evdw1)
 236      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 237      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 238      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 239      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 240      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 241      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 242      & +wliptran*eliptran+wsaxs*esaxs_constr
 243      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 244      & +wdfa_beta*edfabet
 245       endif
 246 #endif
 247       energia(0)=etot
 248       energia(1)=evdw
 249 #ifdef SCP14
 250       energia(2)=evdw2-evdw2_14
 251       energia(17)=evdw2_14
 252 #else
 253       energia(2)=evdw2
 254       energia(17)=0.0d0
 255 #endif
 256 #ifdef SPLITELE
 257       energia(3)=ees
 258       energia(16)=evdw1
 259 #else
 260       energia(3)=ees+evdw1
 261       energia(16)=0.0d0
 262 #endif
 263       energia(4)=ecorr
 264       energia(5)=ecorr5
 265       energia(6)=ecorr6
 266       energia(7)=eel_loc
 267       energia(8)=eello_turn3
 268       energia(9)=eello_turn4
 269       energia(10)=eturn6
 270       energia(11)=ebe
 271       energia(12)=escloc
 272       energia(13)=etors
 273       energia(14)=etors_d
 274       energia(15)=ehpb
 275       energia(18)=estr
 276       energia(19)=esccor
 277       energia(20)=edihcnstr
 278       energia(21)=evdw_t
 279       energia(22)=eliptran
 280       energia(24)=ethetacnstr
 281       energia(26)=esaxs_constr
 282       energia(27)=ehomology_constr
 283       energia(28)=edfadis
 284       energia(29)=edfator
 285       energia(30)=edfanei
 286       energia(31)=edfabet
 287 c detecting NaNQ
 288 #ifdef ISNAN
 289 #ifdef AIX
 290       if (isnan(etot).ne.0) energia(0)=1.0d+99
 291 #else
 292       if (isnan(etot)) energia(0)=1.0d+99
 293 #endif
 294 #else
 295       i=0
 296 #ifdef WINPGI
 297       idumm=proc_proc(etot,i)
 298 #else
 299       call proc_proc(etot,i)
 300 #endif
 301       if(i.eq.1)energia(0)=1.0d+99
 302 #endif
 303 #ifdef MPL
 304 c     endif
 305 #endif
 306 #ifdef DEBUG
 307       call enerprint(energia,fact)
 308 #endif
 309       if (calc_grad) then
 310 C
 311 C Sum up the components of the Cartesian gradient.
 312 C
 313 #ifdef SPLITELE
 314       do i=1,nct
 315         do j=1,3
 316       if (shield_mode.eq.0) then
 317           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 318      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 319      &                wbond*gradb(j,i)+
 320      &                wstrain*ghpbc(j,i)+
 321      &                wcorr*fact(3)*gradcorr(j,i)+
 322      &                wel_loc*fact(2)*gel_loc(j,i)+
 323      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 324      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 325      &                wcorr5*fact(4)*gradcorr5(j,i)+
 326      &                wcorr6*fact(5)*gradcorr6(j,i)+
 327      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 328      &                wsccor*fact(2)*gsccorc(j,i)+
 329      &                wliptran*gliptranc(j,i)+
 330      &                wdfa_dist*gdfad(j,i)+
 331      &                wdfa_tor*gdfat(j,i)+
 332      &                wdfa_nei*gdfan(j,i)+
 333      &                wdfa_beta*gdfab(j,i)
 334           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 335      &                  wbond*gradbx(j,i)+
 336      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 337      &                  wsccor*fact(2)*gsccorx(j,i)
 338      &                 +wliptran*gliptranx(j,i)
 339         else
 340           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 341      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 342      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 343      &                wbond*gradb(j,i)+
 344      &                wstrain*ghpbc(j,i)+
 345      &                wcorr*fact(3)*gradcorr(j,i)+
 346      &                wel_loc*fact(2)*gel_loc(j,i)+
 347      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 348      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 349      &                wcorr5*fact(4)*gradcorr5(j,i)+
 350      &                wcorr6*fact(5)*gradcorr6(j,i)+
 351      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 352      &                wsccor*fact(2)*gsccorc(j,i)
 353      &               +wliptran*gliptranc(j,i)
 354      &                 +welec*gshieldc(j,i)
 355      &                 +welec*gshieldc_loc(j,i)
 356      &                 +wcorr*gshieldc_ec(j,i)
 357      &                 +wcorr*gshieldc_loc_ec(j,i)
 358      &                 +wturn3*gshieldc_t3(j,i)
 359      &                 +wturn3*gshieldc_loc_t3(j,i)
 360      &                 +wturn4*gshieldc_t4(j,i)
 361      &                 +wturn4*gshieldc_loc_t4(j,i)
 362      &                 +wel_loc*gshieldc_ll(j,i)
 363      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 364      &                wdfa_dist*gdfad(j,i)+
 365      &                wdfa_tor*gdfat(j,i)+
 366      &                wdfa_nei*gdfan(j,i)+
 367      &                wdfa_beta*gdfab(j,i)
 368           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 369      &                 +fact(1)*wscp*gradx_scp(j,i)+
 370      &                  wbond*gradbx(j,i)+
 371      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 372      &                  wsccor*fact(2)*gsccorx(j,i)
 373      &                 +wliptran*gliptranx(j,i)
 374      &                 +welec*gshieldx(j,i)
 375      &                 +wcorr*gshieldx_ec(j,i)
 376      &                 +wturn3*gshieldx_t3(j,i)
 377      &                 +wturn4*gshieldx_t4(j,i)
 378      &                 +wel_loc*gshieldx_ll(j,i)
 379         endif
 380         enddo
 381 #else
 382       do i=1,nct
 383         do j=1,3
 384                 if (shield_mode.eq.0) then
 385           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 386      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 387      &                wbond*gradb(j,i)+
 388      &                wcorr*fact(3)*gradcorr(j,i)+
 389      &                wel_loc*fact(2)*gel_loc(j,i)+
 390      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 391      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 392      &                wcorr5*fact(4)*gradcorr5(j,i)+
 393      &                wcorr6*fact(5)*gradcorr6(j,i)+
 394      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 395      &                wsccor*fact(2)*gsccorc(j,i)
 396      &               +wliptran*gliptranc(j,i)+
 397      &                wdfa_dist*gdfad(j,i)+
 398      &                wdfa_tor*gdfat(j,i)+
 399      &                wdfa_nei*gdfan(j,i)+
 400      &                wdfa_beta*gdfab(j,i)
 401
 402           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 403      &                  wbond*gradbx(j,i)+
 404      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 405      &                  wsccor*fact(1)*gsccorx(j,i)
 406      &                 +wliptran*gliptranx(j,i)
 407               else
 408           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 409      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 410      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 411      &                wbond*gradb(j,i)+
 412      &                wcorr*fact(3)*gradcorr(j,i)+
 413      &                wel_loc*fact(2)*gel_loc(j,i)+
 414      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 415      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 416      &                wcorr5*fact(4)*gradcorr5(j,i)+
 417      &                wcorr6*fact(5)*gradcorr6(j,i)+
 418      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 419      &                wsccor*fact(2)*gsccorc(j,i)
 420      &               +wliptran*gliptranc(j,i)
 421      &                 +welec*gshieldc(j,i)
 422      &                 +welec*gshieldc_loc(j,i)
 423      &                 +wcorr*gshieldc_ec(j,i)
 424      &                 +wcorr*gshieldc_loc_ec(j,i)
 425      &                 +wturn3*gshieldc_t3(j,i)
 426      &                 +wturn3*gshieldc_loc_t3(j,i)
 427      &                 +wturn4*gshieldc_t4(j,i)
 428      &                 +wturn4*gshieldc_loc_t4(j,i)
 429      &                 +wel_loc*gshieldc_ll(j,i)
 430      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 431      &                wdfa_dist*gdfad(j,i)+
 432      &                wdfa_tor*gdfat(j,i)+
 433      &                wdfa_nei*gdfan(j,i)+
 434      &                wdfa_beta*gdfab(j,i)
 435           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 436      &                  fact(1)*wscp*gradx_scp(j,i)+
 437      &                  wbond*gradbx(j,i)+
 438      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 439      &                  wsccor*fact(1)*gsccorx(j,i)
 440      &                 +wliptran*gliptranx(j,i)
 441      &                 +welec*gshieldx(j,i)
 442      &                 +wcorr*gshieldx_ec(j,i)
 443      &                 +wturn3*gshieldx_t3(j,i)
 444      &                 +wturn4*gshieldx_t4(j,i)
 445      &                 +wel_loc*gshieldx_ll(j,i)
 446
 447          endif
 448         enddo
 449 #endif
 450       enddo
 451
 452
 453       do i=1,nres-3
 454         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 455      &   +wcorr5*fact(4)*g_corr5_loc(i)
 456      &   +wcorr6*fact(5)*g_corr6_loc(i)
 457      &   +wturn4*fact(3)*gel_loc_turn4(i)
 458      &   +wturn3*fact(2)*gel_loc_turn3(i)
 459      &   +wturn6*fact(5)*gel_loc_turn6(i)
 460      &   +wel_loc*fact(2)*gel_loc_loc(i)
 461 c     &   +wsccor*fact(1)*gsccor_loc(i)
 462 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 463       enddo
 464       endif
 465       if (dyn_ss) call dyn_set_nss
 466       return
 467       end
 468 C------------------------------------------------------------------------
 469       subroutine enerprint(energia,fact)
 470       implicit real*8 (a-h,o-z)
 471       include 'DIMENSIONS'
 472       include 'DIMENSIONS.ZSCOPT'
 473       include 'COMMON.IOUNITS'
 474       include 'COMMON.FFIELD'
 475       include 'COMMON.SBRIDGE'
 476       include 'COMMON.CONTROL'
 477       double precision energia(0:max_ene),fact(6)
 478       etot=energia(0)
 479       evdw=energia(1)+fact(6)*energia(21)
 480 #ifdef SCP14
 481       evdw2=energia(2)+energia(17)
 482 #else
 483       evdw2=energia(2)
 484 #endif
 485       ees=energia(3)
 486 #ifdef SPLITELE
 487       evdw1=energia(16)
 488 #endif
 489       ecorr=energia(4)
 490       ecorr5=energia(5)
 491       ecorr6=energia(6)
 492       eel_loc=energia(7)
 493       eello_turn3=energia(8)
 494       eello_turn4=energia(9)
 495       eello_turn6=energia(10)
 496       ebe=energia(11)
 497       escloc=energia(12)
 498       etors=energia(13)
 499       etors_d=energia(14)
 500       ehpb=energia(15)
 501       esccor=energia(19)
 502       edihcnstr=energia(20)
 503       estr=energia(18)
 504       ethetacnstr=energia(24)
 505       eliptran=energia(22)
 506       esaxs=energia(26)
 507       ehomology_constr=energia(27)
 508 C     Bartek
 509       edfadis = energia(28)
 510       edfator = energia(29)
 511       edfanei = energia(30)
 512       edfabet = energia(31)
 513 #ifdef SPLITELE
 514       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 515      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 516      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 517 #ifdef FOURBODY
 518      &  ecorr,wcorr*fact(3),
 519      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 520 #endif
 521      &  eel_loc,
 522      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 523      &  eello_turn4,wturn4*fact(3),
 524 #ifdef FOURBODY
 525      &  eello_turn6,wturn6*fact(5),
 526 #endif
 527      &  esccor,wsccor*fact(1),edihcnstr,
 528      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 529      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 530      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 531      &  edfabet,wdfa_beta,
 532      &  etot
 533    10 format (/'Virtual-chain energies:'//
 534      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 535      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 536      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 537      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 538      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 539      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 540      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 541      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 542      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 543      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 544      & ' (SS bridges & dist. cnstr.)'/
 545 #ifdef FOURBODY
 546      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 547      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 548      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 549 #endif
 550      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 551      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 552      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 553 #ifdef FOURBODY
 554      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 555 #endif
 556      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 557      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 558      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 559      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 560      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 561      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 562      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 563      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 564      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 565      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 566      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 567      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 568      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 569      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 570      & 'ETOT=  ',1pE16.6,' (total)')
 571
 572 #else
 573       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 574      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 575      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 576 #ifdef FOURBODY
 577      &  ecorr,wcorr*fact(3),
 578      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 579 #endif
 580      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 581      &  eello_turn4,wturn4*fact(3),
 582 #ifdef FOURBODY
 583      &  eello_turn6,wturn6*fact(5),
 584 #endif
 585      &  esccor,wsccor*fact(1),edihcnstr,
 586      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 587      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 588      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 589      &  edfabet,wdfa_beta,
 590      &  etot
 591    10 format (/'Virtual-chain energies:'//
 592      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 593      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 594      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 595      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 596      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 597      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 598      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 599      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 600      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 601      & ' (SS bridges & dist. restr.)'/
 602 #ifdef FOURBODY
 603      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 604      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 605      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 606 #endif
 607      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 608      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 609      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 610 #ifdef FOURBODY
 611      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 612 #endif
 613      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 614      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 615      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 616      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 617      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 618      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 619      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 620      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 621      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 622      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 623      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 624      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 625      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 626      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 627      & 'ETOT=  ',1pE16.6,' (total)')
 628 #endif
 629       return
 630       end
 631 C-----------------------------------------------------------------------
 632       subroutine elj(evdw,evdw_t)
 633 C
 634 C This subroutine calculates the interaction energy of nonbonded side chains
 635 C assuming the LJ potential of interaction.
 636 C
 637       implicit real*8 (a-h,o-z)
 638       include 'DIMENSIONS'
 639       include 'DIMENSIONS.ZSCOPT'
 640       include "DIMENSIONS.COMPAR"
 641       parameter (accur=1.0d-10)
 642       include 'COMMON.GEO'
 643       include 'COMMON.VAR'
 644       include 'COMMON.LOCAL'
 645       include 'COMMON.CHAIN'
 646       include 'COMMON.DERIV'
 647       include 'COMMON.INTERACT'
 648       include 'COMMON.TORSION'
 649       include 'COMMON.ENEPS'
 650       include 'COMMON.SBRIDGE'
 651       include 'COMMON.NAMES'
 652       include 'COMMON.IOUNITS'
 653 #ifdef FOURBODY
 654       include 'COMMON.CONTACTS'
 655       include 'COMMON.CONTMAT'
 656 #endif
 657       dimension gg(3)
 658       integer icant
 659       external icant
 660 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 661 c ROZNICA z cluster
 662       do i=1,210
 663         do j=1,2
 664           eneps_temp(j,i)=0.0d0
 665         enddo
 666       enddo
 667 cROZNICA
 668
 669       evdw=0.0D0
 670       evdw_t=0.0d0
 671       do i=iatsc_s,iatsc_e
 672         itypi=iabs(itype(i))
 673         if (itypi.eq.ntyp1) cycle
 674         itypi1=iabs(itype(i+1))
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678 C Change 12/1/95
 679         num_conti=0
 680 C
 681 C Calculate SC interaction energy.
 682 C
 683         do iint=1,nint_gr(i)
 684 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 685 cd   &                  'iend=',iend(i,iint)
 686           do j=istart(i,iint),iend(i,iint)
 687             itypj=iabs(itype(j))
 688             if (itypj.eq.ntyp1) cycle
 689             xj=c(1,nres+j)-xi
 690             yj=c(2,nres+j)-yi
 691             zj=c(3,nres+j)-zi
 692 C Change 12/1/95 to calculate four-body interactions
 693             rij=xj*xj+yj*yj+zj*zj
 694             rrij=1.0D0/rij
 695             sqrij=dsqrt(rij)
 696             sss1=sscale(sqrij)
 697             if (sss1.eq.0.0d0) cycle
 698             sssgrad1=sscagrad(sqrij)
 699 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 700             eps0ij=eps(itypi,itypj)
 701             fac=rrij**expon2
 702             e1=fac*fac*aa
 703             e2=fac*bb
 704             evdwij=e1+e2
 705             ij=icant(itypi,itypj)
 706 c ROZNICA z cluster
 707             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 708             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 709 c
 710
 711 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 712 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 713 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 714 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 715 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 716 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 717             if (bb.gt.0.0d0) then
 718               evdw=evdw+sss1*evdwij
 719             else
 720               evdw_t=evdw_t+sss1*evdwij
 721             endif
 722             if (calc_grad) then
 723 C
 724 C Calculate the components of the gradient in DC and X
 725 C
 726             fac=-rrij*(e1+evdwij)*sss1
 727      &          +evdwij*sssgrad1/sqrij/expon
 728             gg(1)=xj*fac
 729             gg(2)=yj*fac
 730             gg(3)=zj*fac
 731             do k=1,3
 732               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 733               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 734             enddo
 735             do k=i,j-1
 736               do l=1,3
 737                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 738               enddo
 739             enddo
 740             endif
 741 #ifdef FOURBODY
 742 C
 743 C 12/1/95, revised on 5/20/97
 744 C
 745 C Calculate the contact function. The ith column of the array JCONT will
 746 C contain the numbers of atoms that make contacts with the atom I (of numbers
 747 C greater than I). The arrays FACONT and GACONT will contain the values of
 748 C the contact function and its derivative.
 749 C
 750 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 751 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 752 C Uncomment next line, if the correlation interactions are contact function only
 753             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 754               rij=dsqrt(rij)
 755               sigij=sigma(itypi,itypj)
 756               r0ij=rs0(itypi,itypj)
 757 C
 758 C Check whether the SC's are not too far to make a contact.
 759 C
 760               rcut=1.5d0*r0ij
 761               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 762 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 763 C
 764               if (fcont.gt.0.0D0) then
 765 C If the SC-SC distance if close to sigma, apply spline.
 766 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 767 cAdam &             fcont1,fprimcont1)
 768 cAdam           fcont1=1.0d0-fcont1
 769 cAdam           if (fcont1.gt.0.0d0) then
 770 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 771 cAdam             fcont=fcont*fcont1
 772 cAdam           endif
 773 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 774 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 775 cga             do k=1,3
 776 cga               gg(k)=gg(k)*eps0ij
 777 cga             enddo
 778 cga             eps0ij=-evdwij*eps0ij
 779 C Uncomment for AL's type of SC correlation interactions.
 780 cadam           eps0ij=-evdwij
 781                 num_conti=num_conti+1
 782                 jcont(num_conti,i)=j
 783                 facont(num_conti,i)=fcont*eps0ij
 784                 fprimcont=eps0ij*fprimcont/rij
 785                 fcont=expon*fcont
 786 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 787 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 788 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 789 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 790                 gacont(1,num_conti,i)=-fprimcont*xj
 791                 gacont(2,num_conti,i)=-fprimcont*yj
 792                 gacont(3,num_conti,i)=-fprimcont*zj
 793 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 794 cd              write (iout,'(2i3,3f10.5)')
 795 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 796               endif
 797             endif
 798 #endif
 799           enddo      ! j
 800         enddo        ! iint
 801 #ifdef FOURBODY
 802 C Change 12/1/95
 803         num_cont(i)=num_conti
 804 #endif
 805       enddo          ! i
 806       if (calc_grad) then
 807       do i=1,nct
 808         do j=1,3
 809           gvdwc(j,i)=expon*gvdwc(j,i)
 810           gvdwx(j,i)=expon*gvdwx(j,i)
 811         enddo
 812       enddo
 813       endif
 814 C******************************************************************************
 815 C
 816 C                              N O T E !!!
 817 C
 818 C To save time, the factor of EXPON has been extracted from ALL components
 819 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 820 C use!
 821 C
 822 C******************************************************************************
 823       return
 824       end
 825 C-----------------------------------------------------------------------------
 826       subroutine eljk(evdw,evdw_t)
 827 C
 828 C This subroutine calculates the interaction energy of nonbonded side chains
 829 C assuming the LJK potential of interaction.
 830 C
 831       implicit real*8 (a-h,o-z)
 832       include 'DIMENSIONS'
 833       include 'DIMENSIONS.ZSCOPT'
 834       include "DIMENSIONS.COMPAR"
 835       include 'COMMON.GEO'
 836       include 'COMMON.VAR'
 837       include 'COMMON.LOCAL'
 838       include 'COMMON.CHAIN'
 839       include 'COMMON.DERIV'
 840       include 'COMMON.INTERACT'
 841       include 'COMMON.ENEPS'
 842       include 'COMMON.IOUNITS'
 843       include 'COMMON.NAMES'
 844       dimension gg(3)
 845       logical scheck
 846       integer icant
 847       external icant
 848 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 849       do i=1,210
 850         do j=1,2
 851           eneps_temp(j,i)=0.0d0
 852         enddo
 853       enddo
 854       evdw=0.0D0
 855       evdw_t=0.0d0
 856       do i=iatsc_s,iatsc_e
 857         itypi=iabs(itype(i))
 858         if (itypi.eq.ntyp1) cycle
 859         itypi1=iabs(itype(i+1))
 860         xi=c(1,nres+i)
 861         yi=c(2,nres+i)
 862         zi=c(3,nres+i)
 863 C
 864 C Calculate SC interaction energy.
 865 C
 866         do iint=1,nint_gr(i)
 867           do j=istart(i,iint),iend(i,iint)
 868             itypj=iabs(itype(j))
 869             if (itypj.eq.ntyp1) cycle
 870             xj=c(1,nres+j)-xi
 871             yj=c(2,nres+j)-yi
 872             zj=c(3,nres+j)-zi
 873             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 874             fac_augm=rrij**expon
 875             e_augm=augm(itypi,itypj)*fac_augm
 876             r_inv_ij=dsqrt(rrij)
 877             rij=1.0D0/r_inv_ij
 878             sss1=sscale(rij)
 879             if (sss1.eq.0.0d0) cycle
 880             sssgrad1=sscagrad(rij)
 881             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 882             fac=r_shift_inv**expon
 883             e1=fac*fac*aa
 884             e2=fac*bb
 885             evdwij=e_augm+e1+e2
 886             ij=icant(itypi,itypj)
 887             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 888      &        /dabs(eps(itypi,itypj))
 889             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 890 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 891 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 892 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 893 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 894 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 895 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 896 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 897             if (bb.gt.0.0d0) then
 898               evdw=evdw+evdwij*sss1
 899             else
 900               evdw_t=evdw_t+evdwij*sss1
 901             endif
 902             if (calc_grad) then
 903 C
 904 C Calculate the components of the gradient in DC and X
 905 C
 906            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 907      &          +evdwij*sssgrad1*r_inv_ij/expon
 908             gg(1)=xj*fac
 909             gg(2)=yj*fac
 910             gg(3)=zj*fac
 911             do k=1,3
 912               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 913               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 914             enddo
 915             do k=i,j-1
 916               do l=1,3
 917                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 918               enddo
 919             enddo
 920             endif
 921           enddo      ! j
 922         enddo        ! iint
 923       enddo          ! i
 924       if (calc_grad) then
 925       do i=1,nct
 926         do j=1,3
 927           gvdwc(j,i)=expon*gvdwc(j,i)
 928           gvdwx(j,i)=expon*gvdwx(j,i)
 929         enddo
 930       enddo
 931       endif
 932       return
 933       end
 934 C-----------------------------------------------------------------------------
 935       subroutine ebp(evdw,evdw_t)
 936 C
 937 C This subroutine calculates the interaction energy of nonbonded side chains
 938 C assuming the Berne-Pechukas potential of interaction.
 939 C
 940       implicit real*8 (a-h,o-z)
 941       include 'DIMENSIONS'
 942       include 'DIMENSIONS.ZSCOPT'
 943       include "DIMENSIONS.COMPAR"
 944       include 'COMMON.GEO'
 945       include 'COMMON.VAR'
 946       include 'COMMON.LOCAL'
 947       include 'COMMON.CHAIN'
 948       include 'COMMON.DERIV'
 949       include 'COMMON.NAMES'
 950       include 'COMMON.INTERACT'
 951       include 'COMMON.ENEPS'
 952       include 'COMMON.IOUNITS'
 953       include 'COMMON.CALC'
 954       common /srutu/ icall
 955 c     double precision rrsave(maxdim)
 956       logical lprn
 957       integer icant
 958       external icant
 959       do i=1,210
 960         do j=1,2
 961           eneps_temp(j,i)=0.0d0
 962         enddo
 963       enddo
 964       evdw=0.0D0
 965       evdw_t=0.0d0
 966 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 967 c     if (icall.eq.0) then
 968 c       lprn=.true.
 969 c     else
 970         lprn=.false.
 971 c     endif
 972       ind=0
 973       do i=iatsc_s,iatsc_e
 974         itypi=iabs(itype(i))
 975         if (itypi.eq.ntyp1) cycle
 976         itypi1=iabs(itype(i+1))
 977         xi=c(1,nres+i)
 978         yi=c(2,nres+i)
 979         zi=c(3,nres+i)
 980         dxi=dc_norm(1,nres+i)
 981         dyi=dc_norm(2,nres+i)
 982         dzi=dc_norm(3,nres+i)
 983         dsci_inv=vbld_inv(i+nres)
 984 C
 985 C Calculate SC interaction energy.
 986 C
 987         do iint=1,nint_gr(i)
 988           do j=istart(i,iint),iend(i,iint)
 989             ind=ind+1
 990             itypj=iabs(itype(j))
 991             if (itypj.eq.ntyp1) cycle
 992             dscj_inv=vbld_inv(j+nres)
 993             chi1=chi(itypi,itypj)
 994             chi2=chi(itypj,itypi)
 995             chi12=chi1*chi2
 996             chip1=chip(itypi)
 997             chip2=chip(itypj)
 998             chip12=chip1*chip2
 999             alf1=alp(itypi)
1000             alf2=alp(itypj)
1001             alf12=0.5D0*(alf1+alf2)
1002 C For diagnostics only!!!
1003 c           chi1=0.0D0
1004 c           chi2=0.0D0
1005 c           chi12=0.0D0
1006 c           chip1=0.0D0
1007 c           chip2=0.0D0
1008 c           chip12=0.0D0
1009 c           alf1=0.0D0
1010 c           alf2=0.0D0
1011 c           alf12=0.0D0
1012             xj=c(1,nres+j)-xi
1013             yj=c(2,nres+j)-yi
1014             zj=c(3,nres+j)-zi
1015             dxj=dc_norm(1,nres+j)
1016             dyj=dc_norm(2,nres+j)
1017             dzj=dc_norm(3,nres+j)
1018             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1019 cd          if (icall.eq.0) then
1020 cd            rrsave(ind)=rrij
1021 cd          else
1022 cd            rrij=rrsave(ind)
1023 cd          endif
1024             rij=dsqrt(rrij)
1025             sss1=sscale(1.0d0/rij)
1026             if (sss1.eq.0.0d0) cycle
1027             sssgrad1=sscagrad(1.0d0/rij)
1028
1029 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1030             call sc_angular
1031 C Calculate whole angle-dependent part of epsilon and contributions
1032 C to its derivatives
1033             fac=(rrij*sigsq)**expon2
1034             e1=fac*fac*aa
1035             e2=fac*bb
1036             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1037             eps2der=evdwij*eps3rt
1038             eps3der=evdwij*eps2rt
1039             evdwij=evdwij*eps2rt*eps3rt
1040             ij=icant(itypi,itypj)
1041             aux=eps1*eps2rt**2*eps3rt**2
1042             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1043      &        /dabs(eps(itypi,itypj))
1044             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1045             if (bb.gt.0.0d0) then
1046               evdw=evdw+sss1*evdwij
1047             else
1048               evdw_t=evdw_t+sss1*evdwij
1049             endif
1050             if (calc_grad) then
1051             if (lprn) then
1052             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1053             epsi=bb**2/aa
1054             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1055      &        restyp(itypi),i,restyp(itypj),j,
1056      &        epsi,sigm,chi1,chi2,chip1,chip2,
1057      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1058      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1059      &        evdwij
1060             endif
1061 C Calculate gradient components.
1062             e1=e1*eps1*eps2rt**2*eps3rt**2
1063             fac=-expon*(e1+evdwij)
1064             sigder=fac/sigsq
1065             fac=rrij*fac
1066      &           +evdwij*sssgrad1/sss1*rij
1067 C Calculate radial part of the gradient
1068             gg(1)=xj*fac
1069             gg(2)=yj*fac
1070             gg(3)=zj*fac
1071 C Calculate the angular part of the gradient and sum add the contributions
1072 C to the appropriate components of the Cartesian gradient.
1073             call sc_grad
1074             endif
1075           enddo      ! j
1076         enddo        ! iint
1077       enddo          ! i
1078 c     stop
1079       return
1080       end
1081 C-----------------------------------------------------------------------------
1082       subroutine egb(evdw,evdw_t)
1083 C
1084 C This subroutine calculates the interaction energy of nonbonded side chains
1085 C assuming the Gay-Berne potential of interaction.
1086 C
1087       implicit real*8 (a-h,o-z)
1088       include 'DIMENSIONS'
1089       include 'DIMENSIONS.ZSCOPT'
1090       include "DIMENSIONS.COMPAR"
1091       include 'COMMON.CONTROL'
1092       include 'COMMON.GEO'
1093       include 'COMMON.VAR'
1094       include 'COMMON.LOCAL'
1095       include 'COMMON.CHAIN'
1096       include 'COMMON.DERIV'
1097       include 'COMMON.NAMES'
1098       include 'COMMON.INTERACT'
1099       include 'COMMON.ENEPS'
1100       include 'COMMON.IOUNITS'
1101       include 'COMMON.CALC'
1102       include 'COMMON.SBRIDGE'
1103       logical lprn
1104       common /srutu/icall
1105       integer icant,xshift,yshift,zshift
1106       external icant
1107       do i=1,210
1108         do j=1,2
1109           eneps_temp(j,i)=0.0d0
1110         enddo
1111       enddo
1112 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1113       evdw=0.0D0
1114       evdw_t=0.0d0
1115       lprn=.false.
1116 c      if (icall.gt.0) lprn=.true.
1117       ind=0
1118       do i=iatsc_s,iatsc_e
1119         itypi=iabs(itype(i))
1120         if (itypi.eq.ntyp1) cycle
1121         itypi1=iabs(itype(i+1))
1122         xi=c(1,nres+i)
1123         yi=c(2,nres+i)
1124         zi=c(3,nres+i)
1125 C returning the ith atom to box
1126           xi=mod(xi,boxxsize)
1127           if (xi.lt.0) xi=xi+boxxsize
1128           yi=mod(yi,boxysize)
1129           if (yi.lt.0) yi=yi+boxysize
1130           zi=mod(zi,boxzsize)
1131           if (zi.lt.0) zi=zi+boxzsize
1132        if ((zi.gt.bordlipbot)
1133      &.and.(zi.lt.bordliptop)) then
1134 C the energy transfer exist
1135         if (zi.lt.buflipbot) then
1136 C what fraction I am in
1137          fracinbuf=1.0d0-
1138      &        ((zi-bordlipbot)/lipbufthick)
1139 C lipbufthick is thickenes of lipid buffore
1140          sslipi=sscalelip(fracinbuf)
1141          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1142         elseif (zi.gt.bufliptop) then
1143          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1144          sslipi=sscalelip(fracinbuf)
1145          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1146         else
1147          sslipi=1.0d0
1148          ssgradlipi=0.0
1149         endif
1150        else
1151          sslipi=0.0d0
1152          ssgradlipi=0.0
1153        endif
1154
1155         dxi=dc_norm(1,nres+i)
1156         dyi=dc_norm(2,nres+i)
1157         dzi=dc_norm(3,nres+i)
1158         dsci_inv=vbld_inv(i+nres)
1159 C
1160 C Calculate SC interaction energy.
1161 C
1162         do iint=1,nint_gr(i)
1163           do j=istart(i,iint),iend(i,iint)
1164             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1165               call dyn_ssbond_ene(i,j,evdwij)
1166               evdw=evdw+evdwij
1167 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1168 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1169 C triple bond artifac removal
1170              do k=j+1,iend(i,iint)
1171 C search over all next residues
1172               if (dyn_ss_mask(k)) then
1173 C check if they are cysteins
1174 C              write(iout,*) 'k=',k
1175               call triple_ssbond_ene(i,j,k,evdwij)
1176 C call the energy function that removes the artifical triple disulfide
1177 C bond the soubroutine is located in ssMD.F
1178               evdw=evdw+evdwij
1179 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1180 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1181               endif!dyn_ss_mask(k)
1182              enddo! k
1183             ELSE
1184             ind=ind+1
1185             itypj=iabs(itype(j))
1186             if (itypj.eq.ntyp1) cycle
1187             dscj_inv=vbld_inv(j+nres)
1188             sig0ij=sigma(itypi,itypj)
1189             chi1=chi(itypi,itypj)
1190             chi2=chi(itypj,itypi)
1191             chi12=chi1*chi2
1192             chip1=chip(itypi)
1193             chip2=chip(itypj)
1194             chip12=chip1*chip2
1195             alf1=alp(itypi)
1196             alf2=alp(itypj)
1197             alf12=0.5D0*(alf1+alf2)
1198 C For diagnostics only!!!
1199 c           chi1=0.0D0
1200 c           chi2=0.0D0
1201 c           chi12=0.0D0
1202 c           chip1=0.0D0
1203 c           chip2=0.0D0
1204 c           chip12=0.0D0
1205 c           alf1=0.0D0
1206 c           alf2=0.0D0
1207 c           alf12=0.0D0
1208             xj=c(1,nres+j)
1209             yj=c(2,nres+j)
1210             zj=c(3,nres+j)
1211 C returning jth atom to box
1212           xj=mod(xj,boxxsize)
1213           if (xj.lt.0) xj=xj+boxxsize
1214           yj=mod(yj,boxysize)
1215           if (yj.lt.0) yj=yj+boxysize
1216           zj=mod(zj,boxzsize)
1217           if (zj.lt.0) zj=zj+boxzsize
1218        if ((zj.gt.bordlipbot)
1219      &.and.(zj.lt.bordliptop)) then
1220 C the energy transfer exist
1221         if (zj.lt.buflipbot) then
1222 C what fraction I am in
1223          fracinbuf=1.0d0-
1224      &        ((zj-bordlipbot)/lipbufthick)
1225 C lipbufthick is thickenes of lipid buffore
1226          sslipj=sscalelip(fracinbuf)
1227          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1228         elseif (zj.gt.bufliptop) then
1229          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1230          sslipj=sscalelip(fracinbuf)
1231          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1232         else
1233          sslipj=1.0d0
1234          ssgradlipj=0.0
1235         endif
1236        else
1237          sslipj=0.0d0
1238          ssgradlipj=0.0
1239        endif
1240       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1241      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1242       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1243      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1244 C       if (aa.ne.aa_aq(itypi,itypj)) then
1245
1246 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1247 C     & bb_aq(itypi,itypj)-bb,
1248 C     & sslipi,sslipj
1249 C         endif
1250
1251 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1252 C checking the distance
1253       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1254       xj_safe=xj
1255       yj_safe=yj
1256       zj_safe=zj
1257       subchap=0
1258 C finding the closest
1259       do xshift=-1,1
1260       do yshift=-1,1
1261       do zshift=-1,1
1262           xj=xj_safe+xshift*boxxsize
1263           yj=yj_safe+yshift*boxysize
1264           zj=zj_safe+zshift*boxzsize
1265           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1266           if(dist_temp.lt.dist_init) then
1267             dist_init=dist_temp
1268             xj_temp=xj
1269             yj_temp=yj
1270             zj_temp=zj
1271             subchap=1
1272           endif
1273        enddo
1274        enddo
1275        enddo
1276        if (subchap.eq.1) then
1277           xj=xj_temp-xi
1278           yj=yj_temp-yi
1279           zj=zj_temp-zi
1280        else
1281           xj=xj_safe-xi
1282           yj=yj_safe-yi
1283           zj=zj_safe-zi
1284        endif
1285
1286             dxj=dc_norm(1,nres+j)
1287             dyj=dc_norm(2,nres+j)
1288             dzj=dc_norm(3,nres+j)
1289 c            write (iout,*) i,j,xj,yj,zj
1290             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1291             rij=dsqrt(rrij)
1292             sss=sscale(1.0d0/rij)
1293             sssgrad=sscagrad(1.0d0/rij)
1294             if (sss.le.0.0) cycle
1295 C Calculate angle-dependent terms of energy and contributions to their
1296 C derivatives.
1297
1298             call sc_angular
1299             sigsq=1.0D0/sigsq
1300             sig=sig0ij*dsqrt(sigsq)
1301             rij_shift=1.0D0/rij-sig+sig0ij
1302 C I hate to put IF's in the loops, but here don't have another choice!!!!
1303             if (rij_shift.le.0.0D0) then
1304               evdw=1.0D20
1305               return
1306             endif
1307             sigder=-sig*sigsq
1308 c---------------------------------------------------------------
1309             rij_shift=1.0D0/rij_shift
1310             fac=rij_shift**expon
1311             e1=fac*fac*aa
1312             e2=fac*bb
1313             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1314             eps2der=evdwij*eps3rt
1315             eps3der=evdwij*eps2rt
1316             evdwij=evdwij*eps2rt*eps3rt
1317             if (bb.gt.0) then
1318               evdw=evdw+evdwij*sss
1319             else
1320               evdw_t=evdw_t+evdwij*sss
1321             endif
1322             ij=icant(itypi,itypj)
1323             aux=eps1*eps2rt**2*eps3rt**2
1324             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1325      &        /dabs(eps(itypi,itypj))
1326             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1327 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1328 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1329 c     &         aux*e2/eps(itypi,itypj)
1330 c            if (lprn) then
1331             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1332             epsi=bb**2/aa
1333 c#define DEBUG
1334 #ifdef DEBUG
1335             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1336      &        restyp(itypi),i,restyp(itypj),j,
1337      &        epsi,sigm,chi1,chi2,chip1,chip2,
1338      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1339      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1340      &        evdwij
1341              write (iout,*) "partial sum", evdw, evdw_t
1342 #endif
1343 c#undef DEBUG
1344 c            endif
1345             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1346      &                        'evdw',i,j,evdwij
1347             if (calc_grad) then
1348 C Calculate gradient components.
1349             e1=e1*eps1*eps2rt**2*eps3rt**2
1350             fac=-expon*(e1+evdwij)*rij_shift
1351             sigder=fac*sigder
1352             fac=rij*fac
1353             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1354 C Calculate the radial part of the gradient
1355             gg(1)=xj*fac
1356             gg(2)=yj*fac
1357             gg(3)=zj*fac
1358 C Calculate angular part of the gradient.
1359             call sc_grad
1360             endif
1361 C            write(iout,*)  "partial sum", evdw, evdw_t
1362             ENDIF    ! dyn_ss
1363           enddo      ! j
1364         enddo        ! iint
1365       enddo          ! i
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine egbv(evdw,evdw_t)
1370 C
1371 C This subroutine calculates the interaction energy of nonbonded side chains
1372 C assuming the Gay-Berne-Vorobjev potential of interaction.
1373 C
1374       implicit real*8 (a-h,o-z)
1375       include 'DIMENSIONS'
1376       include 'DIMENSIONS.ZSCOPT'
1377       include "DIMENSIONS.COMPAR"
1378       include 'COMMON.GEO'
1379       include 'COMMON.VAR'
1380       include 'COMMON.LOCAL'
1381       include 'COMMON.CHAIN'
1382       include 'COMMON.DERIV'
1383       include 'COMMON.NAMES'
1384       include 'COMMON.INTERACT'
1385       include 'COMMON.ENEPS'
1386       include 'COMMON.IOUNITS'
1387       include 'COMMON.CALC'
1388       common /srutu/ icall
1389       logical lprn
1390       integer icant
1391       external icant
1392       do i=1,210
1393         do j=1,2
1394           eneps_temp(j,i)=0.0d0
1395         enddo
1396       enddo
1397       evdw=0.0D0
1398       evdw_t=0.0d0
1399 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1400       evdw=0.0D0
1401       lprn=.false.
1402 c      if (icall.gt.0) lprn=.true.
1403       ind=0
1404       do i=iatsc_s,iatsc_e
1405         itypi=iabs(itype(i))
1406         if (itypi.eq.ntyp1) cycle
1407         itypi1=iabs(itype(i+1))
1408         xi=c(1,nres+i)
1409         yi=c(2,nres+i)
1410         zi=c(3,nres+i)
1411         dxi=dc_norm(1,nres+i)
1412         dyi=dc_norm(2,nres+i)
1413         dzi=dc_norm(3,nres+i)
1414         dsci_inv=vbld_inv(i+nres)
1415 C
1416 C Calculate SC interaction energy.
1417 C
1418         do iint=1,nint_gr(i)
1419           do j=istart(i,iint),iend(i,iint)
1420             ind=ind+1
1421             itypj=iabs(itype(j))
1422             if (itypj.eq.ntyp1) cycle
1423             dscj_inv=vbld_inv(j+nres)
1424             sig0ij=sigma(itypi,itypj)
1425             r0ij=r0(itypi,itypj)
1426             chi1=chi(itypi,itypj)
1427             chi2=chi(itypj,itypi)
1428             chi12=chi1*chi2
1429             chip1=chip(itypi)
1430             chip2=chip(itypj)
1431             chip12=chip1*chip2
1432             alf1=alp(itypi)
1433             alf2=alp(itypj)
1434             alf12=0.5D0*(alf1+alf2)
1435 C For diagnostics only!!!
1436 c           chi1=0.0D0
1437 c           chi2=0.0D0
1438 c           chi12=0.0D0
1439 c           chip1=0.0D0
1440 c           chip2=0.0D0
1441 c           chip12=0.0D0
1442 c           alf1=0.0D0
1443 c           alf2=0.0D0
1444 c           alf12=0.0D0
1445             xj=c(1,nres+j)-xi
1446             yj=c(2,nres+j)-yi
1447             zj=c(3,nres+j)-zi
1448             dxj=dc_norm(1,nres+j)
1449             dyj=dc_norm(2,nres+j)
1450             dzj=dc_norm(3,nres+j)
1451             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1452             rij=dsqrt(rrij)
1453             sss=sscale(1.0d0/rij)
1454             if (sss.eq.0.0d0) cycle
1455             sssgrad=sscagrad(1.0d0/rij)
1456 C Calculate angle-dependent terms of energy and contributions to their
1457 C derivatives.
1458             call sc_angular
1459             sigsq=1.0D0/sigsq
1460             sig=sig0ij*dsqrt(sigsq)
1461             rij_shift=1.0D0/rij-sig+r0ij
1462 C I hate to put IF's in the loops, but here don't have another choice!!!!
1463             if (rij_shift.le.0.0D0) then
1464               evdw=1.0D20
1465               return
1466             endif
1467             sigder=-sig*sigsq
1468 c---------------------------------------------------------------
1469             rij_shift=1.0D0/rij_shift
1470             fac=rij_shift**expon
1471             e1=fac*fac*aa
1472             e2=fac*bb
1473             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1474             eps2der=evdwij*eps3rt
1475             eps3der=evdwij*eps2rt
1476             fac_augm=rrij**expon
1477             e_augm=augm(itypi,itypj)*fac_augm
1478             evdwij=evdwij*eps2rt*eps3rt
1479             if (bb.gt.0.0d0) then
1480               evdw=evdw+(evdwij+e_augm)*sss
1481             else
1482               evdw_t=evdw_t+(evdwij+e_augm)*sss
1483             endif
1484             ij=icant(itypi,itypj)
1485             aux=eps1*eps2rt**2*eps3rt**2
1486             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1487      &        /dabs(eps(itypi,itypj))
1488             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1489 c            eneps_temp(ij)=eneps_temp(ij)
1490 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1491 c            if (lprn) then
1492 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1493 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1494 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1495 c     &        restyp(itypi),i,restyp(itypj),j,
1496 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1497 c     &        chi1,chi2,chip1,chip2,
1498 c     &        eps1,eps2rt**2,eps3rt**2,
1499 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1500 c     &        evdwij+e_augm
1501 c            endif
1502             if (calc_grad) then
1503 C Calculate gradient components.
1504             e1=e1*eps1*eps2rt**2*eps3rt**2
1505             fac=-expon*(e1+evdwij)*rij_shift
1506             sigder=fac*sigder
1507             fac=rij*fac-2*expon*rrij*e_augm
1508             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1509 C Calculate the radial part of the gradient
1510             gg(1)=xj*fac
1511             gg(2)=yj*fac
1512             gg(3)=zj*fac
1513 C Calculate angular part of the gradient.
1514             call sc_grad
1515             endif
1516           enddo      ! j
1517         enddo        ! iint
1518       enddo          ! i
1519       return
1520       end
1521 C-----------------------------------------------------------------------------
1522       subroutine sc_angular
1523 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1524 C om12. Called by ebp, egb, and egbv.
1525       implicit none
1526       include 'COMMON.CALC'
1527       erij(1)=xj*rij
1528       erij(2)=yj*rij
1529       erij(3)=zj*rij
1530       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1531       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1532       om12=dxi*dxj+dyi*dyj+dzi*dzj
1533       chiom12=chi12*om12
1534 C Calculate eps1(om12) and its derivative in om12
1535       faceps1=1.0D0-om12*chiom12
1536       faceps1_inv=1.0D0/faceps1
1537       eps1=dsqrt(faceps1_inv)
1538 C Following variable is eps1*deps1/dom12
1539       eps1_om12=faceps1_inv*chiom12
1540 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1541 C and om12.
1542       om1om2=om1*om2
1543       chiom1=chi1*om1
1544       chiom2=chi2*om2
1545       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1546       sigsq=1.0D0-facsig*faceps1_inv
1547       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1548       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1549       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1550 C Calculate eps2 and its derivatives in om1, om2, and om12.
1551       chipom1=chip1*om1
1552       chipom2=chip2*om2
1553       chipom12=chip12*om12
1554       facp=1.0D0-om12*chipom12
1555       facp_inv=1.0D0/facp
1556       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1557 C Following variable is the square root of eps2
1558       eps2rt=1.0D0-facp1*facp_inv
1559 C Following three variables are the derivatives of the square root of eps
1560 C in om1, om2, and om12.
1561       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1562       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1563       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1564 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1565       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1566 C Calculate whole angle-dependent part of epsilon and contributions
1567 C to its derivatives
1568       return
1569       end
1570 C----------------------------------------------------------------------------
1571       subroutine sc_grad
1572       implicit real*8 (a-h,o-z)
1573       include 'DIMENSIONS'
1574       include 'DIMENSIONS.ZSCOPT'
1575       include 'COMMON.CHAIN'
1576       include 'COMMON.DERIV'
1577       include 'COMMON.CALC'
1578       double precision dcosom1(3),dcosom2(3)
1579       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1580       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1581       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1582      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1583       do k=1,3
1584         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1585         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1586       enddo
1587       do k=1,3
1588         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1589       enddo
1590       do k=1,3
1591         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1592      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1593      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1594         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1595      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1596      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1597       enddo
1598 C
1599 C Calculate the components of the gradient in DC and X
1600 C
1601       do k=i,j-1
1602         do l=1,3
1603           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1604         enddo
1605       enddo
1606       return
1607       end
1608 c------------------------------------------------------------------------------
1609       subroutine vec_and_deriv
1610       implicit real*8 (a-h,o-z)
1611       include 'DIMENSIONS'
1612       include 'DIMENSIONS.ZSCOPT'
1613       include 'COMMON.IOUNITS'
1614       include 'COMMON.GEO'
1615       include 'COMMON.VAR'
1616       include 'COMMON.LOCAL'
1617       include 'COMMON.CHAIN'
1618       include 'COMMON.VECTORS'
1619       include 'COMMON.DERIV'
1620       include 'COMMON.INTERACT'
1621       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1622 C Compute the local reference systems. For reference system (i), the
1623 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1624 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1625       do i=1,nres-1
1626 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1627           if (i.eq.nres-1) then
1628 C Case of the last full residue
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(nres))
1632             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1633 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1634 c     &         " uz",uz(:,i)
1635             do k=1,3
1636               uz(k,i)=fac*uz(k,i)
1637             enddo
1638             if (calc_grad) then
1639 C Compute the derivatives of uz
1640             uzder(1,1,1)= 0.0d0
1641             uzder(2,1,1)=-dc_norm(3,i-1)
1642             uzder(3,1,1)= dc_norm(2,i-1)
1643             uzder(1,2,1)= dc_norm(3,i-1)
1644             uzder(2,2,1)= 0.0d0
1645             uzder(3,2,1)=-dc_norm(1,i-1)
1646             uzder(1,3,1)=-dc_norm(2,i-1)
1647             uzder(2,3,1)= dc_norm(1,i-1)
1648             uzder(3,3,1)= 0.0d0
1649             uzder(1,1,2)= 0.0d0
1650             uzder(2,1,2)= dc_norm(3,i)
1651             uzder(3,1,2)=-dc_norm(2,i)
1652             uzder(1,2,2)=-dc_norm(3,i)
1653             uzder(2,2,2)= 0.0d0
1654             uzder(3,2,2)= dc_norm(1,i)
1655             uzder(1,3,2)= dc_norm(2,i)
1656             uzder(2,3,2)=-dc_norm(1,i)
1657             uzder(3,3,2)= 0.0d0
1658             endif ! calc_grad
1659 C Compute the Y-axis
1660             facy=fac
1661             do k=1,3
1662               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1663             enddo
1664             if (calc_grad) then
1665 C Compute the derivatives of uy
1666             do j=1,3
1667               do k=1,3
1668                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1669      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1670                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1671               enddo
1672               uyder(j,j,1)=uyder(j,j,1)-costh
1673               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1674             enddo
1675             do j=1,2
1676               do k=1,3
1677                 do l=1,3
1678                   uygrad(l,k,j,i)=uyder(l,k,j)
1679                   uzgrad(l,k,j,i)=uzder(l,k,j)
1680                 enddo
1681               enddo
1682             enddo
1683             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1684             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1685             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1686             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1687             endif
1688           else
1689 C Other residues
1690 C Compute the Z-axis
1691             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1692             costh=dcos(pi-theta(i+2))
1693             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1694             do k=1,3
1695               uz(k,i)=fac*uz(k,i)
1696             enddo
1697             if (calc_grad) then
1698 C Compute the derivatives of uz
1699             uzder(1,1,1)= 0.0d0
1700             uzder(2,1,1)=-dc_norm(3,i+1)
1701             uzder(3,1,1)= dc_norm(2,i+1)
1702             uzder(1,2,1)= dc_norm(3,i+1)
1703             uzder(2,2,1)= 0.0d0
1704             uzder(3,2,1)=-dc_norm(1,i+1)
1705             uzder(1,3,1)=-dc_norm(2,i+1)
1706             uzder(2,3,1)= dc_norm(1,i+1)
1707             uzder(3,3,1)= 0.0d0
1708             uzder(1,1,2)= 0.0d0
1709             uzder(2,1,2)= dc_norm(3,i)
1710             uzder(3,1,2)=-dc_norm(2,i)
1711             uzder(1,2,2)=-dc_norm(3,i)
1712             uzder(2,2,2)= 0.0d0
1713             uzder(3,2,2)= dc_norm(1,i)
1714             uzder(1,3,2)= dc_norm(2,i)
1715             uzder(2,3,2)=-dc_norm(1,i)
1716             uzder(3,3,2)= 0.0d0
1717             endif
1718 C Compute the Y-axis
1719             facy=fac
1720             do k=1,3
1721               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1722             enddo
1723             if (calc_grad) then
1724 C Compute the derivatives of uy
1725             do j=1,3
1726               do k=1,3
1727                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1728      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1729                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1730               enddo
1731               uyder(j,j,1)=uyder(j,j,1)-costh
1732               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1733             enddo
1734             do j=1,2
1735               do k=1,3
1736                 do l=1,3
1737                   uygrad(l,k,j,i)=uyder(l,k,j)
1738                   uzgrad(l,k,j,i)=uzder(l,k,j)
1739                 enddo
1740               enddo
1741             enddo
1742             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1743             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1744             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1745             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1746           endif
1747           endif
1748       enddo
1749       if (calc_grad) then
1750       do i=1,nres-1
1751         vbld_inv_temp(1)=vbld_inv(i+1)
1752         if (i.lt.nres-1) then
1753           vbld_inv_temp(2)=vbld_inv(i+2)
1754         else
1755           vbld_inv_temp(2)=vbld_inv(i)
1756         endif
1757         do j=1,2
1758           do k=1,3
1759             do l=1,3
1760               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1761               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1762             enddo
1763           enddo
1764         enddo
1765       enddo
1766       endif
1767       return
1768       end
1769 C--------------------------------------------------------------------------
1770       subroutine set_matrices
1771       implicit real*8 (a-h,o-z)
1772       include 'DIMENSIONS'
1773 #ifdef MPI
1774       include "mpif.h"
1775       integer IERR
1776       integer status(MPI_STATUS_SIZE)
1777 #endif
1778       include 'DIMENSIONS.ZSCOPT'
1779       include 'COMMON.IOUNITS'
1780       include 'COMMON.GEO'
1781       include 'COMMON.VAR'
1782       include 'COMMON.LOCAL'
1783       include 'COMMON.CHAIN'
1784       include 'COMMON.DERIV'
1785       include 'COMMON.INTERACT'
1786       include 'COMMON.CORRMAT'
1787       include 'COMMON.TORSION'
1788       include 'COMMON.VECTORS'
1789       include 'COMMON.FFIELD'
1790       double precision auxvec(2),auxmat(2,2)
1791 C
1792 C Compute the virtual-bond-torsional-angle dependent quantities needed
1793 C to calculate the el-loc multibody terms of various order.
1794 C
1795 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1796       do i=3,nres+1
1797         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1798           iti = itype2loc(itype(i-2))
1799         else
1800           iti=nloctyp
1801         endif
1802 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1803         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1804           iti1 = itype2loc(itype(i-1))
1805         else
1806           iti1=nloctyp
1807         endif
1808 #ifdef NEWCORR
1809         cost1=dcos(theta(i-1))
1810         sint1=dsin(theta(i-1))
1811         sint1sq=sint1*sint1
1812         sint1cub=sint1sq*sint1
1813         sint1cost1=2*sint1*cost1
1814 #ifdef DEBUG
1815         write (iout,*) "bnew1",i,iti
1816         write (iout,*) (bnew1(k,1,iti),k=1,3)
1817         write (iout,*) (bnew1(k,2,iti),k=1,3)
1818         write (iout,*) "bnew2",i,iti
1819         write (iout,*) (bnew2(k,1,iti),k=1,3)
1820         write (iout,*) (bnew2(k,2,iti),k=1,3)
1821 #endif
1822         do k=1,2
1823           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1824           b1(k,i-2)=sint1*b1k
1825           gtb1(k,i-2)=cost1*b1k-sint1sq*
1826      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1827           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1828           b2(k,i-2)=sint1*b2k
1829           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1830      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1831         enddo
1832         do k=1,2
1833           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1834           cc(1,k,i-2)=sint1sq*aux
1835           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1836      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1837           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1838           dd(1,k,i-2)=sint1sq*aux
1839           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1840      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1841         enddo
1842         cc(2,1,i-2)=cc(1,2,i-2)
1843         cc(2,2,i-2)=-cc(1,1,i-2)
1844         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1845         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1846         dd(2,1,i-2)=dd(1,2,i-2)
1847         dd(2,2,i-2)=-dd(1,1,i-2)
1848         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1849         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1850         do k=1,2
1851           do l=1,2
1852             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1853             EE(l,k,i-2)=sint1sq*aux
1854             if (calc_grad)
1855      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1856           enddo
1857         enddo
1858         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1859         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1860         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1861         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1862         if (calc_grad) then
1863         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1864         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1865         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1866         endif
1867 c        b1tilde(1,i-2)=b1(1,i-2)
1868 c        b1tilde(2,i-2)=-b1(2,i-2)
1869 c        b2tilde(1,i-2)=b2(1,i-2)
1870 c        b2tilde(2,i-2)=-b2(2,i-2)
1871 #ifdef DEBUG
1872         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1873         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1874         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1875         write (iout,*) 'theta=', theta(i-1)
1876 #endif
1877 #else
1878 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1879 c          iti = itype2loc(itype(i-2))
1880 c        else
1881 c          iti=nloctyp
1882 c        endif
1883 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1884 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1885 c          iti1 = itype2loc(itype(i-1))
1886 c        else
1887 c          iti1=nloctyp
1888 c        endif
1889         b1(1,i-2)=b(3,iti)
1890         b1(2,i-2)=b(5,iti)
1891         b2(1,i-2)=b(2,iti)
1892         b2(2,i-2)=b(4,iti)
1893         do k=1,2
1894           do l=1,2
1895            CC(k,l,i-2)=ccold(k,l,iti)
1896            DD(k,l,i-2)=ddold(k,l,iti)
1897            EE(k,l,i-2)=eeold(k,l,iti)
1898           enddo
1899         enddo
1900 #endif
1901         b1tilde(1,i-2)= b1(1,i-2)
1902         b1tilde(2,i-2)=-b1(2,i-2)
1903         b2tilde(1,i-2)= b2(1,i-2)
1904         b2tilde(2,i-2)=-b2(2,i-2)
1905 c
1906         Ctilde(1,1,i-2)= CC(1,1,i-2)
1907         Ctilde(1,2,i-2)= CC(1,2,i-2)
1908         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1909         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1910 c
1911         Dtilde(1,1,i-2)= DD(1,1,i-2)
1912         Dtilde(1,2,i-2)= DD(1,2,i-2)
1913         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1914         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1915 #ifdef DEBUG
1916         write(iout,*) "i",i," iti",iti
1917         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1918         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1919 #endif
1920       enddo
1921       do i=3,nres+1
1922         if (i .lt. nres+1) then
1923           sin1=dsin(phi(i))
1924           cos1=dcos(phi(i))
1925           sintab(i-2)=sin1
1926           costab(i-2)=cos1
1927           obrot(1,i-2)=cos1
1928           obrot(2,i-2)=sin1
1929           sin2=dsin(2*phi(i))
1930           cos2=dcos(2*phi(i))
1931           sintab2(i-2)=sin2
1932           costab2(i-2)=cos2
1933           obrot2(1,i-2)=cos2
1934           obrot2(2,i-2)=sin2
1935           Ug(1,1,i-2)=-cos1
1936           Ug(1,2,i-2)=-sin1
1937           Ug(2,1,i-2)=-sin1
1938           Ug(2,2,i-2)= cos1
1939           Ug2(1,1,i-2)=-cos2
1940           Ug2(1,2,i-2)=-sin2
1941           Ug2(2,1,i-2)=-sin2
1942           Ug2(2,2,i-2)= cos2
1943         else
1944           costab(i-2)=1.0d0
1945           sintab(i-2)=0.0d0
1946           obrot(1,i-2)=1.0d0
1947           obrot(2,i-2)=0.0d0
1948           obrot2(1,i-2)=0.0d0
1949           obrot2(2,i-2)=0.0d0
1950           Ug(1,1,i-2)=1.0d0
1951           Ug(1,2,i-2)=0.0d0
1952           Ug(2,1,i-2)=0.0d0
1953           Ug(2,2,i-2)=1.0d0
1954           Ug2(1,1,i-2)=0.0d0
1955           Ug2(1,2,i-2)=0.0d0
1956           Ug2(2,1,i-2)=0.0d0
1957           Ug2(2,2,i-2)=0.0d0
1958         endif
1959         if (i .gt. 3 .and. i .lt. nres+1) then
1960           obrot_der(1,i-2)=-sin1
1961           obrot_der(2,i-2)= cos1
1962           Ugder(1,1,i-2)= sin1
1963           Ugder(1,2,i-2)=-cos1
1964           Ugder(2,1,i-2)=-cos1
1965           Ugder(2,2,i-2)=-sin1
1966           dwacos2=cos2+cos2
1967           dwasin2=sin2+sin2
1968           obrot2_der(1,i-2)=-dwasin2
1969           obrot2_der(2,i-2)= dwacos2
1970           Ug2der(1,1,i-2)= dwasin2
1971           Ug2der(1,2,i-2)=-dwacos2
1972           Ug2der(2,1,i-2)=-dwacos2
1973           Ug2der(2,2,i-2)=-dwasin2
1974         else
1975           obrot_der(1,i-2)=0.0d0
1976           obrot_der(2,i-2)=0.0d0
1977           Ugder(1,1,i-2)=0.0d0
1978           Ugder(1,2,i-2)=0.0d0
1979           Ugder(2,1,i-2)=0.0d0
1980           Ugder(2,2,i-2)=0.0d0
1981           obrot2_der(1,i-2)=0.0d0
1982           obrot2_der(2,i-2)=0.0d0
1983           Ug2der(1,1,i-2)=0.0d0
1984           Ug2der(1,2,i-2)=0.0d0
1985           Ug2der(2,1,i-2)=0.0d0
1986           Ug2der(2,2,i-2)=0.0d0
1987         endif
1988 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1989         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1990           iti = itype2loc(itype(i-2))
1991         else
1992           iti=nloctyp
1993         endif
1994 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1995         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1996           iti1 = itype2loc(itype(i-1))
1997         else
1998           iti1=nloctyp
1999         endif
2000 cd        write (iout,*) '*******i',i,' iti1',iti
2001 cd        write (iout,*) 'b1',b1(:,iti)
2002 cd        write (iout,*) 'b2',b2(:,iti)
2003 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2004 c        if (i .gt. iatel_s+2) then
2005         if (i .gt. nnt+2) then
2006           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2007 #ifdef NEWCORR
2008           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2009 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2010 #endif
2011 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2012 c     &    EE(1,2,iti),EE(2,2,i)
2013           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2014           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2015 c          write(iout,*) "Macierz EUG",
2016 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2017 c     &    eug(2,2,i-2)
2018 #ifdef FOURBODY
2019           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2020      &    then
2021           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2022           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2023           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2024           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2025           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2026           endif
2027 #endif
2028         else
2029           do k=1,2
2030             Ub2(k,i-2)=0.0d0
2031             Ctobr(k,i-2)=0.0d0
2032             Dtobr2(k,i-2)=0.0d0
2033             do l=1,2
2034               EUg(l,k,i-2)=0.0d0
2035               CUg(l,k,i-2)=0.0d0
2036               DUg(l,k,i-2)=0.0d0
2037               DtUg2(l,k,i-2)=0.0d0
2038             enddo
2039           enddo
2040         endif
2041         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2042         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2043         do k=1,2
2044           muder(k,i-2)=Ub2der(k,i-2)
2045         enddo
2046 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2047         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2048           if (itype(i-1).le.ntyp) then
2049             iti1 = itype2loc(itype(i-1))
2050           else
2051             iti1=nloctyp
2052           endif
2053         else
2054           iti1=nloctyp
2055         endif
2056         do k=1,2
2057           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2058         enddo
2059 #ifdef MUOUT
2060         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2061      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2062      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2063      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2064      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2065      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2066 #endif
2067 cd        write (iout,*) 'mu1',mu1(:,i-2)
2068 cd        write (iout,*) 'mu2',mu2(:,i-2)
2069 #ifdef FOURBODY
2070         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2071      &  then
2072         if (calc_grad) then
2073         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2074         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2075         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2076         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2077         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2078         endif
2079 C Vectors and matrices dependent on a single virtual-bond dihedral.
2080         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2081         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2082         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2083         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2084         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2085         if (calc_grad) then
2086         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2087         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2088         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2089         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2090         endif
2091         endif
2092 #endif
2093       enddo
2094 #ifdef FOURBODY
2095 C Matrices dependent on two consecutive virtual-bond dihedrals.
2096 C The order of matrices is from left to right.
2097       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2098      &then
2099       do i=2,nres-1
2100         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2101         if (calc_grad) then
2102         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2103         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2104         endif
2105         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2106         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2107         if (calc_grad) then
2108         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2109         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2110         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2111         endif
2112       enddo
2113       endif
2114 #endif
2115       return
2116       end
2117 C--------------------------------------------------------------------------
2118       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2119 C
2120 C This subroutine calculates the average interaction energy and its gradient
2121 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2122 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2123 C The potential depends both on the distance of peptide-group centers and on
2124 C the orientation of the CA-CA virtual bonds.
2125 C
2126       implicit real*8 (a-h,o-z)
2127 #ifdef MPI
2128       include 'mpif.h'
2129 #endif
2130       include 'DIMENSIONS'
2131       include 'DIMENSIONS.ZSCOPT'
2132       include 'COMMON.CONTROL'
2133       include 'COMMON.IOUNITS'
2134       include 'COMMON.GEO'
2135       include 'COMMON.VAR'
2136       include 'COMMON.LOCAL'
2137       include 'COMMON.CHAIN'
2138       include 'COMMON.DERIV'
2139       include 'COMMON.INTERACT'
2140 #ifdef FOURBODY
2141       include 'COMMON.CONTACTS'
2142       include 'COMMON.CONTMAT'
2143 #endif
2144       include 'COMMON.CORRMAT'
2145       include 'COMMON.TORSION'
2146       include 'COMMON.VECTORS'
2147       include 'COMMON.FFIELD'
2148       include 'COMMON.TIME1'
2149       include 'COMMON.SPLITELE'
2150       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2151      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2152       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2153      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2154       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2155      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2156      &    num_conti,j1,j2
2157 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2158 #ifdef MOMENT
2159       double precision scal_el /1.0d0/
2160 #else
2161       double precision scal_el /0.5d0/
2162 #endif
2163 C 12/13/98
2164 C 13-go grudnia roku pamietnego...
2165       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2166      &                   0.0d0,1.0d0,0.0d0,
2167      &                   0.0d0,0.0d0,1.0d0/
2168 cd      write(iout,*) 'In EELEC'
2169 cd      do i=1,nloctyp
2170 cd        write(iout,*) 'Type',i
2171 cd        write(iout,*) 'B1',B1(:,i)
2172 cd        write(iout,*) 'B2',B2(:,i)
2173 cd        write(iout,*) 'CC',CC(:,:,i)
2174 cd        write(iout,*) 'DD',DD(:,:,i)
2175 cd        write(iout,*) 'EE',EE(:,:,i)
2176 cd      enddo
2177 cd      call check_vecgrad
2178 cd      stop
2179       if (icheckgrad.eq.1) then
2180         do i=1,nres-1
2181           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2182           do k=1,3
2183             dc_norm(k,i)=dc(k,i)*fac
2184           enddo
2185 c          write (iout,*) 'i',i,' fac',fac
2186         enddo
2187       endif
2188       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2189      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2190      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2191 c        call vec_and_deriv
2192 #ifdef TIMING
2193         time01=MPI_Wtime()
2194 #endif
2195         call set_matrices
2196 #ifdef TIMING
2197         time_mat=time_mat+MPI_Wtime()-time01
2198 #endif
2199       endif
2200 cd      do i=1,nres-1
2201 cd        write (iout,*) 'i=',i
2202 cd        do k=1,3
2203 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2204 cd        enddo
2205 cd        do k=1,3
2206 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2207 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2208 cd        enddo
2209 cd      enddo
2210       t_eelecij=0.0d0
2211       ees=0.0D0
2212       evdw1=0.0D0
2213       eel_loc=0.0d0
2214       eello_turn3=0.0d0
2215       eello_turn4=0.0d0
2216       ind=0
2217 #ifdef FOURBODY
2218       do i=1,nres
2219         num_cont_hb(i)=0
2220       enddo
2221 #endif
2222 cd      print '(a)','Enter EELEC'
2223 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2224       do i=1,nres
2225         gel_loc_loc(i)=0.0d0
2226         gcorr_loc(i)=0.0d0
2227       enddo
2228 c
2229 c
2230 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2231 C
2232 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2233 C
2234 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2235       do i=iturn3_start,iturn3_end
2236 c        if (i.le.1) cycle
2237 C        write(iout,*) "tu jest i",i
2238         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2239 C changes suggested by Ana to avoid out of bounds
2240 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2241 c     & .or.((i+4).gt.nres)
2242 c     & .or.((i-1).le.0)
2243 C end of changes by Ana
2244 C dobra zmiana wycofana
2245      &  .or. itype(i+2).eq.ntyp1
2246      &  .or. itype(i+3).eq.ntyp1) cycle
2247 C Adam: Instructions below will switch off existing interactions
2248 c        if(i.gt.1)then
2249 c          if(itype(i-1).eq.ntyp1)cycle
2250 c        end if
2251 c        if(i.LT.nres-3)then
2252 c          if (itype(i+4).eq.ntyp1) cycle
2253 c        end if
2254         dxi=dc(1,i)
2255         dyi=dc(2,i)
2256         dzi=dc(3,i)
2257         dx_normi=dc_norm(1,i)
2258         dy_normi=dc_norm(2,i)
2259         dz_normi=dc_norm(3,i)
2260         xmedi=c(1,i)+0.5d0*dxi
2261         ymedi=c(2,i)+0.5d0*dyi
2262         zmedi=c(3,i)+0.5d0*dzi
2263           xmedi=mod(xmedi,boxxsize)
2264           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2265           ymedi=mod(ymedi,boxysize)
2266           if (ymedi.lt.0) ymedi=ymedi+boxysize
2267           zmedi=mod(zmedi,boxzsize)
2268           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2269         num_conti=0
2270         call eelecij(i,i+2,ees,evdw1,eel_loc)
2271         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2272 #ifdef FOURBODY
2273         num_cont_hb(i)=num_conti
2274 #endif
2275       enddo
2276       do i=iturn4_start,iturn4_end
2277         if (i.lt.1) cycle
2278         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2279 C changes suggested by Ana to avoid out of bounds
2280 c     & .or.((i+5).gt.nres)
2281 c     & .or.((i-1).le.0)
2282 C end of changes suggested by Ana
2283      &    .or. itype(i+3).eq.ntyp1
2284      &    .or. itype(i+4).eq.ntyp1
2285 c     &    .or. itype(i+5).eq.ntyp1
2286 c     &    .or. itype(i).eq.ntyp1
2287 c     &    .or. itype(i-1).eq.ntyp1
2288      &                             ) cycle
2289         dxi=dc(1,i)
2290         dyi=dc(2,i)
2291         dzi=dc(3,i)
2292         dx_normi=dc_norm(1,i)
2293         dy_normi=dc_norm(2,i)
2294         dz_normi=dc_norm(3,i)
2295         xmedi=c(1,i)+0.5d0*dxi
2296         ymedi=c(2,i)+0.5d0*dyi
2297         zmedi=c(3,i)+0.5d0*dzi
2298 C Return atom into box, boxxsize is size of box in x dimension
2299 c  194   continue
2300 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2301 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2302 C Condition for being inside the proper box
2303 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2304 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2305 c        go to 194
2306 c        endif
2307 c  195   continue
2308 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2309 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2310 C Condition for being inside the proper box
2311 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2312 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2313 c        go to 195
2314 c        endif
2315 c  196   continue
2316 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2317 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2318 C Condition for being inside the proper box
2319 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2320 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2321 c        go to 196
2322 c        endif
2323           xmedi=mod(xmedi,boxxsize)
2324           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2325           ymedi=mod(ymedi,boxysize)
2326           if (ymedi.lt.0) ymedi=ymedi+boxysize
2327           zmedi=mod(zmedi,boxzsize)
2328           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2329 #ifdef FOURBODY
2330         num_conti=num_cont_hb(i)
2331 #endif
2332 c        write(iout,*) "JESTEM W PETLI"
2333         call eelecij(i,i+3,ees,evdw1,eel_loc)
2334         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2335      &   call eturn4(i,eello_turn4)
2336 #ifdef FOURBODY
2337         num_cont_hb(i)=num_conti
2338 #endif
2339       enddo   ! i
2340 C Loop over all neighbouring boxes
2341 C      do xshift=-1,1
2342 C      do yshift=-1,1
2343 C      do zshift=-1,1
2344 c
2345 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2346 c
2347 CTU KURWA
2348       do i=iatel_s,iatel_e
2349 C        do i=75,75
2350 c        if (i.le.1) cycle
2351         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2352 C changes suggested by Ana to avoid out of bounds
2353 c     & .or.((i+2).gt.nres)
2354 c     & .or.((i-1).le.0)
2355 C end of changes by Ana
2356 c     &  .or. itype(i+2).eq.ntyp1
2357 c     &  .or. itype(i-1).eq.ntyp1
2358      &                ) cycle
2359         dxi=dc(1,i)
2360         dyi=dc(2,i)
2361         dzi=dc(3,i)
2362         dx_normi=dc_norm(1,i)
2363         dy_normi=dc_norm(2,i)
2364         dz_normi=dc_norm(3,i)
2365         xmedi=c(1,i)+0.5d0*dxi
2366         ymedi=c(2,i)+0.5d0*dyi
2367         zmedi=c(3,i)+0.5d0*dzi
2368           xmedi=mod(xmedi,boxxsize)
2369           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2370           ymedi=mod(ymedi,boxysize)
2371           if (ymedi.lt.0) ymedi=ymedi+boxysize
2372           zmedi=mod(zmedi,boxzsize)
2373           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2374 C          xmedi=xmedi+xshift*boxxsize
2375 C          ymedi=ymedi+yshift*boxysize
2376 C          zmedi=zmedi+zshift*boxzsize
2377
2378 C Return tom into box, boxxsize is size of box in x dimension
2379 c  164   continue
2380 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2381 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2382 C Condition for being inside the proper box
2383 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2384 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2385 c        go to 164
2386 c        endif
2387 c  165   continue
2388 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2389 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2390 C Condition for being inside the proper box
2391 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2392 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2393 c        go to 165
2394 c        endif
2395 c  166   continue
2396 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2397 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2398 cC Condition for being inside the proper box
2399 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2400 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2401 c        go to 166
2402 c        endif
2403
2404 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2405 #ifdef FOURBODY
2406         num_conti=num_cont_hb(i)
2407 #endif
2408 C I TU KURWA
2409         do j=ielstart(i),ielend(i)
2410 C          do j=16,17
2411 C          write (iout,*) i,j
2412 C         if (j.le.1) cycle
2413           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2414 C changes suggested by Ana to avoid out of bounds
2415 c     & .or.((j+2).gt.nres)
2416 c     & .or.((j-1).le.0)
2417 C end of changes by Ana
2418 c     & .or.itype(j+2).eq.ntyp1
2419 c     & .or.itype(j-1).eq.ntyp1
2420      &) cycle
2421           call eelecij(i,j,ees,evdw1,eel_loc)
2422         enddo ! j
2423 #ifdef FOURBODY
2424         num_cont_hb(i)=num_conti
2425 #endif
2426       enddo   ! i
2427 C     enddo   ! zshift
2428 C      enddo   ! yshift
2429 C      enddo   ! xshift
2430
2431 c      write (iout,*) "Number of loop steps in EELEC:",ind
2432 cd      do i=1,nres
2433 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2434 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2435 cd      enddo
2436 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2437 ccc      eel_loc=eel_loc+eello_turn3
2438 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2439       return
2440       end
2441 C-------------------------------------------------------------------------------
2442       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2443       implicit real*8 (a-h,o-z)
2444       include 'DIMENSIONS'
2445       include 'DIMENSIONS.ZSCOPT'
2446 #ifdef MPI
2447       include "mpif.h"
2448 #endif
2449       include 'COMMON.CONTROL'
2450       include 'COMMON.IOUNITS'
2451       include 'COMMON.GEO'
2452       include 'COMMON.VAR'
2453       include 'COMMON.LOCAL'
2454       include 'COMMON.CHAIN'
2455       include 'COMMON.DERIV'
2456       include 'COMMON.INTERACT'
2457 #ifdef FOURBODY
2458       include 'COMMON.CONTACTS'
2459       include 'COMMON.CONTMAT'
2460 #endif
2461       include 'COMMON.CORRMAT'
2462       include 'COMMON.TORSION'
2463       include 'COMMON.VECTORS'
2464       include 'COMMON.FFIELD'
2465       include 'COMMON.TIME1'
2466       include 'COMMON.SPLITELE'
2467       include 'COMMON.SHIELD'
2468       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2469      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2470       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2471      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2472      &    gmuij2(4),gmuji2(4)
2473       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2474      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2475      &    num_conti,j1,j2
2476 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2477 #ifdef MOMENT
2478       double precision scal_el /1.0d0/
2479 #else
2480       double precision scal_el /0.5d0/
2481 #endif
2482 C 12/13/98
2483 C 13-go grudnia roku pamietnego...
2484       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2485      &                   0.0d0,1.0d0,0.0d0,
2486      &                   0.0d0,0.0d0,1.0d0/
2487        integer xshift,yshift,zshift
2488 c          time00=MPI_Wtime()
2489 cd      write (iout,*) "eelecij",i,j
2490 c          ind=ind+1
2491           iteli=itel(i)
2492           itelj=itel(j)
2493           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2494           aaa=app(iteli,itelj)
2495           bbb=bpp(iteli,itelj)
2496           ael6i=ael6(iteli,itelj)
2497           ael3i=ael3(iteli,itelj)
2498           dxj=dc(1,j)
2499           dyj=dc(2,j)
2500           dzj=dc(3,j)
2501           dx_normj=dc_norm(1,j)
2502           dy_normj=dc_norm(2,j)
2503           dz_normj=dc_norm(3,j)
2504 C          xj=c(1,j)+0.5D0*dxj-xmedi
2505 C          yj=c(2,j)+0.5D0*dyj-ymedi
2506 C          zj=c(3,j)+0.5D0*dzj-zmedi
2507           xj=c(1,j)+0.5D0*dxj
2508           yj=c(2,j)+0.5D0*dyj
2509           zj=c(3,j)+0.5D0*dzj
2510           xj=mod(xj,boxxsize)
2511           if (xj.lt.0) xj=xj+boxxsize
2512           yj=mod(yj,boxysize)
2513           if (yj.lt.0) yj=yj+boxysize
2514           zj=mod(zj,boxzsize)
2515           if (zj.lt.0) zj=zj+boxzsize
2516           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2517       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2518       xj_safe=xj
2519       yj_safe=yj
2520       zj_safe=zj
2521       isubchap=0
2522       do xshift=-1,1
2523       do yshift=-1,1
2524       do zshift=-1,1
2525           xj=xj_safe+xshift*boxxsize
2526           yj=yj_safe+yshift*boxysize
2527           zj=zj_safe+zshift*boxzsize
2528           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2529           if(dist_temp.lt.dist_init) then
2530             dist_init=dist_temp
2531             xj_temp=xj
2532             yj_temp=yj
2533             zj_temp=zj
2534             isubchap=1
2535           endif
2536        enddo
2537        enddo
2538        enddo
2539        if (isubchap.eq.1) then
2540           xj=xj_temp-xmedi
2541           yj=yj_temp-ymedi
2542           zj=zj_temp-zmedi
2543        else
2544           xj=xj_safe-xmedi
2545           yj=yj_safe-ymedi
2546           zj=zj_safe-zmedi
2547        endif
2548 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2549 c  174   continue
2550 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2551 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2552 C Condition for being inside the proper box
2553 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2554 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2555 c        go to 174
2556 c        endif
2557 c  175   continue
2558 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2559 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2560 C Condition for being inside the proper box
2561 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2562 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2563 c        go to 175
2564 c        endif
2565 c  176   continue
2566 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2567 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2568 C Condition for being inside the proper box
2569 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2570 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2571 c        go to 176
2572 c        endif
2573 C        endif !endPBC condintion
2574 C        xj=xj-xmedi
2575 C        yj=yj-ymedi
2576 C        zj=zj-zmedi
2577           rij=xj*xj+yj*yj+zj*zj
2578
2579           sss=sscale(sqrt(rij))
2580           if (sss.eq.0.0d0) return
2581           sssgrad=sscagrad(sqrt(rij))
2582 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2583 c     &       " rlamb",rlamb," sss",sss
2584 c            if (sss.gt.0.0d0) then
2585           rrmij=1.0D0/rij
2586           rij=dsqrt(rij)
2587           rmij=1.0D0/rij
2588           r3ij=rrmij*rmij
2589           r6ij=r3ij*r3ij
2590           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2591           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2592           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2593           fac=cosa-3.0D0*cosb*cosg
2594           ev1=aaa*r6ij*r6ij
2595 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2596           if (j.eq.i+2) ev1=scal_el*ev1
2597           ev2=bbb*r6ij
2598           fac3=ael6i*r6ij
2599           fac4=ael3i*r3ij
2600           evdwij=(ev1+ev2)
2601           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2602           el2=fac4*fac
2603 C MARYSIA
2604 C          eesij=(el1+el2)
2605 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2606           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2607           if (shield_mode.gt.0) then
2608 C          fac_shield(i)=0.4
2609 C          fac_shield(j)=0.6
2610           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2611           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2612           eesij=(el1+el2)
2613           ees=ees+eesij
2614           else
2615           fac_shield(i)=1.0
2616           fac_shield(j)=1.0
2617           eesij=(el1+el2)
2618           ees=ees+eesij
2619           endif
2620           evdw1=evdw1+evdwij*sss
2621 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2622 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2623 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2624 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2625
2626           if (energy_dec) then
2627               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2628      &'evdw1',i,j,evdwij
2629      &,iteli,itelj,aaa,evdw1,sss
2630               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2631      &fac_shield(i),fac_shield(j)
2632           endif
2633
2634 C
2635 C Calculate contributions to the Cartesian gradient.
2636 C
2637 #ifdef SPLITELE
2638           facvdw=-6*rrmij*(ev1+evdwij)*sss
2639           facel=-3*rrmij*(el1+eesij)
2640           fac1=fac
2641           erij(1)=xj*rmij
2642           erij(2)=yj*rmij
2643           erij(3)=zj*rmij
2644
2645 *
2646 * Radial derivatives. First process both termini of the fragment (i,j)
2647 *
2648           if (calc_grad) then
2649           ggg(1)=facel*xj
2650           ggg(2)=facel*yj
2651           ggg(3)=facel*zj
2652           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2653      &  (shield_mode.gt.0)) then
2654 C          print *,i,j
2655           do ilist=1,ishield_list(i)
2656            iresshield=shield_list(ilist,i)
2657            do k=1,3
2658            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2659      &      *2.0
2660            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2661      &              rlocshield
2662      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2663             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2664 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2665 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2666 C             if (iresshield.gt.i) then
2667 C               do ishi=i+1,iresshield-1
2668 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2669 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2670 C
2671 C              enddo
2672 C             else
2673 C               do ishi=iresshield,i
2674 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2675 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2676 C
2677 C               enddo
2678 C              endif
2679            enddo
2680           enddo
2681           do ilist=1,ishield_list(j)
2682            iresshield=shield_list(ilist,j)
2683            do k=1,3
2684            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2685      &     *2.0
2686            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2687      &              rlocshield
2688      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2689            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2690
2691 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2692 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2693 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2694 C             if (iresshield.gt.j) then
2695 C               do ishi=j+1,iresshield-1
2696 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2697 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2698 C
2699 C               enddo
2700 C            else
2701 C               do ishi=iresshield,j
2702 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2703 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2704 C               enddo
2705 C              endif
2706            enddo
2707           enddo
2708
2709           do k=1,3
2710             gshieldc(k,i)=gshieldc(k,i)+
2711      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2712             gshieldc(k,j)=gshieldc(k,j)+
2713      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2714             gshieldc(k,i-1)=gshieldc(k,i-1)+
2715      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2716             gshieldc(k,j-1)=gshieldc(k,j-1)+
2717      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2718
2719            enddo
2720            endif
2721 c          do k=1,3
2722 c            ghalf=0.5D0*ggg(k)
2723 c            gelc(k,i)=gelc(k,i)+ghalf
2724 c            gelc(k,j)=gelc(k,j)+ghalf
2725 c          enddo
2726 c 9/28/08 AL Gradient compotents will be summed only at the end
2727 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2728           do k=1,3
2729             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2730 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2731             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2732 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2733 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2734 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2735 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2736 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2737           enddo
2738 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2739
2740 *
2741 * Loop over residues i+1 thru j-1.
2742 *
2743 cgrad          do k=i+1,j-1
2744 cgrad            do l=1,3
2745 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2746 cgrad            enddo
2747 cgrad          enddo
2748           if (sss.gt.0.0) then
2749           facvdw=facvdw+sssgrad*rmij*evdwij
2750           ggg(1)=facvdw*xj
2751           ggg(2)=facvdw*yj
2752           ggg(3)=facvdw*zj
2753           else
2754           ggg(1)=0.0
2755           ggg(2)=0.0
2756           ggg(3)=0.0
2757           endif
2758 c          do k=1,3
2759 c            ghalf=0.5D0*ggg(k)
2760 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2761 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2762 c          enddo
2763 c 9/28/08 AL Gradient compotents will be summed only at the end
2764           do k=1,3
2765             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2766             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2767           enddo
2768 *
2769 * Loop over residues i+1 thru j-1.
2770 *
2771 cgrad          do k=i+1,j-1
2772 cgrad            do l=1,3
2773 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2774 cgrad            enddo
2775 cgrad          enddo
2776           endif ! calc_grad
2777 #else
2778 C MARYSIA
2779           facvdw=(ev1+evdwij)
2780           facel=(el1+eesij)
2781           fac1=fac
2782           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2783      &       +(evdwij+eesij)*sssgrad*rrmij
2784           erij(1)=xj*rmij
2785           erij(2)=yj*rmij
2786           erij(3)=zj*rmij
2787 *
2788 * Radial derivatives. First process both termini of the fragment (i,j)
2789 *
2790           if (calc_grad) then
2791           ggg(1)=fac*xj
2792 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2793           ggg(2)=fac*yj
2794 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2795           ggg(3)=fac*zj
2796 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2797 c          do k=1,3
2798 c            ghalf=0.5D0*ggg(k)
2799 c            gelc(k,i)=gelc(k,i)+ghalf
2800 c            gelc(k,j)=gelc(k,j)+ghalf
2801 c          enddo
2802 c 9/28/08 AL Gradient compotents will be summed only at the end
2803           do k=1,3
2804             gelc_long(k,j)=gelc(k,j)+ggg(k)
2805             gelc_long(k,i)=gelc(k,i)-ggg(k)
2806           enddo
2807 *
2808 * Loop over residues i+1 thru j-1.
2809 *
2810 cgrad          do k=i+1,j-1
2811 cgrad            do l=1,3
2812 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2813 cgrad            enddo
2814 cgrad          enddo
2815 c 9/28/08 AL Gradient compotents will be summed only at the end
2816           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2817           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2818           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2819           do k=1,3
2820             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2821             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2822           enddo
2823           endif ! calc_grad
2824 #endif
2825 *
2826 * Angular part
2827 *
2828           if (calc_grad) then
2829           ecosa=2.0D0*fac3*fac1+fac4
2830           fac4=-3.0D0*fac4
2831           fac3=-6.0D0*fac3
2832           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2833           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2834           do k=1,3
2835             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2836             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2837           enddo
2838 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2839 cd   &          (dcosg(k),k=1,3)
2840           do k=1,3
2841             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2842      &      fac_shield(i)**2*fac_shield(j)**2
2843           enddo
2844 c          do k=1,3
2845 c            ghalf=0.5D0*ggg(k)
2846 c            gelc(k,i)=gelc(k,i)+ghalf
2847 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2848 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2849 c            gelc(k,j)=gelc(k,j)+ghalf
2850 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2851 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2852 c          enddo
2853 cgrad          do k=i+1,j-1
2854 cgrad            do l=1,3
2855 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2856 cgrad            enddo
2857 cgrad          enddo
2858 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2859           do k=1,3
2860             gelc(k,i)=gelc(k,i)
2861      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2862      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2863      &           *fac_shield(i)**2*fac_shield(j)**2
2864             gelc(k,j)=gelc(k,j)
2865      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2866      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2867      &           *fac_shield(i)**2*fac_shield(j)**2
2868             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2869             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2870           enddo
2871 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2872
2873 C MARYSIA
2874 c          endif !sscale
2875           endif ! calc_grad
2876           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2877      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2878      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2879 C
2880 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2881 C   energy of a peptide unit is assumed in the form of a second-order
2882 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2883 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2884 C   are computed for EVERY pair of non-contiguous peptide groups.
2885 C
2886
2887           if (j.lt.nres-1) then
2888             j1=j+1
2889             j2=j-1
2890           else
2891             j1=j-1
2892             j2=j-2
2893           endif
2894           kkk=0
2895           lll=0
2896           do k=1,2
2897             do l=1,2
2898               kkk=kkk+1
2899               muij(kkk)=mu(k,i)*mu(l,j)
2900 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2901 #ifdef NEWCORR
2902              if (calc_grad) then
2903              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2904 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2905              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2906              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2907 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2908              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2909              endif
2910 #endif
2911             enddo
2912           enddo
2913 #ifdef DEBUG
2914           write (iout,*) 'EELEC: i',i,' j',j
2915           write (iout,*) 'j',j,' j1',j1,' j2',j2
2916           write(iout,*) 'muij',muij
2917           write (iout,*) "uy",uy(:,i)
2918           write (iout,*) "uz",uz(:,j)
2919           write (iout,*) "erij",erij
2920 #endif
2921           ury=scalar(uy(1,i),erij)
2922           urz=scalar(uz(1,i),erij)
2923           vry=scalar(uy(1,j),erij)
2924           vrz=scalar(uz(1,j),erij)
2925           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2926           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2927           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2928           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2929           fac=dsqrt(-ael6i)*r3ij
2930           a22=a22*fac
2931           a23=a23*fac
2932           a32=a32*fac
2933           a33=a33*fac
2934 cd          write (iout,'(4i5,4f10.5)')
2935 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2936 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2937 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2938 cd     &      uy(:,j),uz(:,j)
2939 cd          write (iout,'(4f10.5)')
2940 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2941 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2942 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2943 cd           write (iout,'(9f10.5/)')
2944 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2945 C Derivatives of the elements of A in virtual-bond vectors
2946           if (calc_grad) then
2947           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2948           do k=1,3
2949             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2950             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2951             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2952             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2953             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2954             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2955             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2956             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2957             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2958             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2959             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2960             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2961           enddo
2962 C Compute radial contributions to the gradient
2963           facr=-3.0d0*rrmij
2964           a22der=a22*facr
2965           a23der=a23*facr
2966           a32der=a32*facr
2967           a33der=a33*facr
2968           agg(1,1)=a22der*xj
2969           agg(2,1)=a22der*yj
2970           agg(3,1)=a22der*zj
2971           agg(1,2)=a23der*xj
2972           agg(2,2)=a23der*yj
2973           agg(3,2)=a23der*zj
2974           agg(1,3)=a32der*xj
2975           agg(2,3)=a32der*yj
2976           agg(3,3)=a32der*zj
2977           agg(1,4)=a33der*xj
2978           agg(2,4)=a33der*yj
2979           agg(3,4)=a33der*zj
2980 C Add the contributions coming from er
2981           fac3=-3.0d0*fac
2982           do k=1,3
2983             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2984             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2985             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2986             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2987           enddo
2988           do k=1,3
2989 C Derivatives in DC(i)
2990 cgrad            ghalf1=0.5d0*agg(k,1)
2991 cgrad            ghalf2=0.5d0*agg(k,2)
2992 cgrad            ghalf3=0.5d0*agg(k,3)
2993 cgrad            ghalf4=0.5d0*agg(k,4)
2994             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2995      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2996             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2997      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2998             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2999      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3000             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3001      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3002 C Derivatives in DC(i+1)
3003             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3004      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3005             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3006      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3007             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3008      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3009             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3010      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3011 C Derivatives in DC(j)
3012             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3013      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3014             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3015      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3016             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3017      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3018             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3019      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3020 C Derivatives in DC(j+1) or DC(nres-1)
3021             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3022      &      -3.0d0*vryg(k,3)*ury)
3023             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3024      &      -3.0d0*vrzg(k,3)*ury)
3025             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3026      &      -3.0d0*vryg(k,3)*urz)
3027             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3028      &      -3.0d0*vrzg(k,3)*urz)
3029 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3030 cgrad              do l=1,4
3031 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3032 cgrad              enddo
3033 cgrad            endif
3034           enddo
3035           endif ! calc_grad
3036           acipa(1,1)=a22
3037           acipa(1,2)=a23
3038           acipa(2,1)=a32
3039           acipa(2,2)=a33
3040           a22=-a22
3041           a23=-a23
3042           if (calc_grad) then
3043           do l=1,2
3044             do k=1,3
3045               agg(k,l)=-agg(k,l)
3046               aggi(k,l)=-aggi(k,l)
3047               aggi1(k,l)=-aggi1(k,l)
3048               aggj(k,l)=-aggj(k,l)
3049               aggj1(k,l)=-aggj1(k,l)
3050             enddo
3051           enddo
3052           endif ! calc_grad
3053           if (j.lt.nres-1) then
3054             a22=-a22
3055             a32=-a32
3056             do l=1,3,2
3057               do k=1,3
3058                 agg(k,l)=-agg(k,l)
3059                 aggi(k,l)=-aggi(k,l)
3060                 aggi1(k,l)=-aggi1(k,l)
3061                 aggj(k,l)=-aggj(k,l)
3062                 aggj1(k,l)=-aggj1(k,l)
3063               enddo
3064             enddo
3065           else
3066             a22=-a22
3067             a23=-a23
3068             a32=-a32
3069             a33=-a33
3070             do l=1,4
3071               do k=1,3
3072                 agg(k,l)=-agg(k,l)
3073                 aggi(k,l)=-aggi(k,l)
3074                 aggi1(k,l)=-aggi1(k,l)
3075                 aggj(k,l)=-aggj(k,l)
3076                 aggj1(k,l)=-aggj1(k,l)
3077               enddo
3078             enddo
3079           endif
3080           ENDIF ! WCORR
3081           IF (wel_loc.gt.0.0d0) THEN
3082 C Contribution to the local-electrostatic energy coming from the i-j pair
3083           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3084      &     +a33*muij(4)
3085 #ifdef DEBUG
3086           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3087      &     " a33",a33
3088           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3089      &     " wel_loc",wel_loc
3090 #endif
3091           if (shield_mode.eq.0) then
3092            fac_shield(i)=1.0
3093            fac_shield(j)=1.0
3094 C          else
3095 C           fac_shield(i)=0.4
3096 C           fac_shield(j)=0.6
3097           endif
3098           eel_loc_ij=eel_loc_ij
3099      &    *fac_shield(i)*fac_shield(j)*sss
3100           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3101      &            'eelloc',i,j,eel_loc_ij
3102 c           if (eel_loc_ij.ne.0)
3103 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3104 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3105
3106           eel_loc=eel_loc+eel_loc_ij
3107 C Now derivative over eel_loc
3108           if (calc_grad) then
3109           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3110      &  (shield_mode.gt.0)) then
3111 C          print *,i,j
3112
3113           do ilist=1,ishield_list(i)
3114            iresshield=shield_list(ilist,i)
3115            do k=1,3
3116            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3117      &                                          /fac_shield(i)
3118 C     &      *2.0
3119            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3120      &              rlocshield
3121      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3122             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3123      &      +rlocshield
3124            enddo
3125           enddo
3126           do ilist=1,ishield_list(j)
3127            iresshield=shield_list(ilist,j)
3128            do k=1,3
3129            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3130      &                                       /fac_shield(j)
3131 C     &     *2.0
3132            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3133      &              rlocshield
3134      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3135            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3136      &             +rlocshield
3137
3138            enddo
3139           enddo
3140
3141           do k=1,3
3142             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3143      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3144             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3145      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3146             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3147      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3148             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3149      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3150            enddo
3151            endif
3152
3153
3154 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3155 c     &                     ' eel_loc_ij',eel_loc_ij
3156 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3157 C Calculate patrial derivative for theta angle
3158 #ifdef NEWCORR
3159          geel_loc_ij=(a22*gmuij1(1)
3160      &     +a23*gmuij1(2)
3161      &     +a32*gmuij1(3)
3162      &     +a33*gmuij1(4))
3163      &    *fac_shield(i)*fac_shield(j)*sss
3164 c         write(iout,*) "derivative over thatai"
3165 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3166 c     &   a33*gmuij1(4)
3167          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3168      &      geel_loc_ij*wel_loc
3169 c         write(iout,*) "derivative over thatai-1"
3170 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3171 c     &   a33*gmuij2(4)
3172          geel_loc_ij=
3173      &     a22*gmuij2(1)
3174      &     +a23*gmuij2(2)
3175      &     +a32*gmuij2(3)
3176      &     +a33*gmuij2(4)
3177          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3178      &      geel_loc_ij*wel_loc
3179      &    *fac_shield(i)*fac_shield(j)*sss
3180
3181 c  Derivative over j residue
3182          geel_loc_ji=a22*gmuji1(1)
3183      &     +a23*gmuji1(2)
3184      &     +a32*gmuji1(3)
3185      &     +a33*gmuji1(4)
3186 c         write(iout,*) "derivative over thataj"
3187 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3188 c     &   a33*gmuji1(4)
3189
3190         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3191      &      geel_loc_ji*wel_loc
3192      &    *fac_shield(i)*fac_shield(j)
3193
3194          geel_loc_ji=
3195      &     +a22*gmuji2(1)
3196      &     +a23*gmuji2(2)
3197      &     +a32*gmuji2(3)
3198      &     +a33*gmuji2(4)
3199 c         write(iout,*) "derivative over thataj-1"
3200 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3201 c     &   a33*gmuji2(4)
3202          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3203      &      geel_loc_ji*wel_loc
3204      &    *fac_shield(i)*fac_shield(j)*sss
3205 #endif
3206 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3207
3208 C Partial derivatives in virtual-bond dihedral angles gamma
3209           if (i.gt.1)
3210      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3211      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3212      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3213      &    *fac_shield(i)*fac_shield(j)
3214
3215           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3216      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3217      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3218      &    *fac_shield(i)*fac_shield(j)
3219 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3220           aux=eel_loc_ij/sss*sssgrad*rmij
3221           ggg(1)=aux*xj
3222           ggg(2)=aux*yj
3223           ggg(3)=aux*zj
3224           do l=1,3
3225             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3226      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3227      &    *fac_shield(i)*fac_shield(j)*sss
3228             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3229             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3230 cgrad            ghalf=0.5d0*ggg(l)
3231 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3232 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3233           enddo
3234 cgrad          do k=i+1,j2
3235 cgrad            do l=1,3
3236 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3237 cgrad            enddo
3238 cgrad          enddo
3239 C Remaining derivatives of eello
3240           do l=1,3
3241             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3242      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3243      &    *fac_shield(i)*fac_shield(j)
3244
3245             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3246      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3247      &    *fac_shield(i)*fac_shield(j)
3248
3249             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3250      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3251      &    *fac_shield(i)*fac_shield(j)
3252
3253             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3254      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3255      &    *fac_shield(i)*fac_shield(j)
3256
3257           enddo
3258           endif ! calc_grad
3259           ENDIF
3260
3261
3262 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3263 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3264 #ifdef FOURBODY
3265           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3266      &       .and. num_conti.le.maxconts) then
3267 c            write (iout,*) i,j," entered corr"
3268 C
3269 C Calculate the contact function. The ith column of the array JCONT will
3270 C contain the numbers of atoms that make contacts with the atom I (of numbers
3271 C greater than I). The arrays FACONT and GACONT will contain the values of
3272 C the contact function and its derivative.
3273 c           r0ij=1.02D0*rpp(iteli,itelj)
3274 c           r0ij=1.11D0*rpp(iteli,itelj)
3275             r0ij=2.20D0*rpp(iteli,itelj)
3276 c           r0ij=1.55D0*rpp(iteli,itelj)
3277             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3278             if (fcont.gt.0.0D0) then
3279               num_conti=num_conti+1
3280               if (num_conti.gt.maxconts) then
3281                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3282      &                         ' will skip next contacts for this conf.'
3283               else
3284                 jcont_hb(num_conti,i)=j
3285 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3286 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3287                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3288      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3289 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3290 C  terms.
3291                 d_cont(num_conti,i)=rij
3292 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3293 C     --- Electrostatic-interaction matrix ---
3294                 a_chuj(1,1,num_conti,i)=a22
3295                 a_chuj(1,2,num_conti,i)=a23
3296                 a_chuj(2,1,num_conti,i)=a32
3297                 a_chuj(2,2,num_conti,i)=a33
3298 C     --- Gradient of rij
3299                 if (calc_grad) then
3300                 do kkk=1,3
3301                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3302                 enddo
3303                 kkll=0
3304                 do k=1,2
3305                   do l=1,2
3306                     kkll=kkll+1
3307                     do m=1,3
3308                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3309                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3310                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3311                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3312                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3313                     enddo
3314                   enddo
3315                 enddo
3316                 endif ! calc_grad
3317                 ENDIF
3318                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3319 C Calculate contact energies
3320                 cosa4=4.0D0*cosa
3321                 wij=cosa-3.0D0*cosb*cosg
3322                 cosbg1=cosb+cosg
3323                 cosbg2=cosb-cosg
3324 c               fac3=dsqrt(-ael6i)/r0ij**3
3325                 fac3=dsqrt(-ael6i)*r3ij
3326 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3327                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3328                 if (ees0tmp.gt.0) then
3329                   ees0pij=dsqrt(ees0tmp)
3330                 else
3331                   ees0pij=0
3332                 endif
3333 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3334                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3335                 if (ees0tmp.gt.0) then
3336                   ees0mij=dsqrt(ees0tmp)
3337                 else
3338                   ees0mij=0
3339                 endif
3340 c               ees0mij=0.0D0
3341                 if (shield_mode.eq.0) then
3342                 fac_shield(i)=1.0d0
3343                 fac_shield(j)=1.0d0
3344                 else
3345                 ees0plist(num_conti,i)=j
3346 C                fac_shield(i)=0.4d0
3347 C                fac_shield(j)=0.6d0
3348                 endif
3349                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3350      &          *fac_shield(i)*fac_shield(j)
3351                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3352      &          *fac_shield(i)*fac_shield(j)
3353 C Diagnostics. Comment out or remove after debugging!
3354 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3355 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3356 c               ees0m(num_conti,i)=0.0D0
3357 C End diagnostics.
3358 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3359 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3360 C Angular derivatives of the contact function
3361
3362                 ees0pij1=fac3/ees0pij
3363                 ees0mij1=fac3/ees0mij
3364                 fac3p=-3.0D0*fac3*rrmij
3365                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3366                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3367 c               ees0mij1=0.0D0
3368                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3369                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3370                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3371                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3372                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3373                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3374                 ecosap=ecosa1+ecosa2
3375                 ecosbp=ecosb1+ecosb2
3376                 ecosgp=ecosg1+ecosg2
3377                 ecosam=ecosa1-ecosa2
3378                 ecosbm=ecosb1-ecosb2
3379                 ecosgm=ecosg1-ecosg2
3380 C Diagnostics
3381 c               ecosap=ecosa1
3382 c               ecosbp=ecosb1
3383 c               ecosgp=ecosg1
3384 c               ecosam=0.0D0
3385 c               ecosbm=0.0D0
3386 c               ecosgm=0.0D0
3387 C End diagnostics
3388                 facont_hb(num_conti,i)=fcont
3389
3390                 if (calc_grad) then
3391                 fprimcont=fprimcont/rij
3392 cd              facont_hb(num_conti,i)=1.0D0
3393 C Following line is for diagnostics.
3394 cd              fprimcont=0.0D0
3395                 do k=1,3
3396                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3397                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3398                 enddo
3399                 do k=1,3
3400                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3401                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3402                 enddo
3403                 gggp(1)=gggp(1)+ees0pijp*xj
3404      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3405                 gggp(2)=gggp(2)+ees0pijp*yj
3406      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3407                 gggp(3)=gggp(3)+ees0pijp*zj
3408      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3409                 gggm(1)=gggm(1)+ees0mijp*xj
3410      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3411                 gggm(2)=gggm(2)+ees0mijp*yj
3412      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3413                 gggm(3)=gggm(3)+ees0mijp*zj
3414      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3415 C Derivatives due to the contact function
3416                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3417                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3418                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3419                 do k=1,3
3420 c
3421 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3422 c          following the change of gradient-summation algorithm.
3423 c
3424 cgrad                  ghalfp=0.5D0*gggp(k)
3425 cgrad                  ghalfm=0.5D0*gggm(k)
3426                   gacontp_hb1(k,num_conti,i)=!ghalfp
3427      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3428      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3429      &          *fac_shield(i)*fac_shield(j)*sss
3430
3431                   gacontp_hb2(k,num_conti,i)=!ghalfp
3432      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3433      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3434      &          *fac_shield(i)*fac_shield(j)*sss
3435
3436                   gacontp_hb3(k,num_conti,i)=gggp(k)
3437      &          *fac_shield(i)*fac_shield(j)*sss
3438
3439                   gacontm_hb1(k,num_conti,i)=!ghalfm
3440      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3441      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3442      &          *fac_shield(i)*fac_shield(j)*sss
3443
3444                   gacontm_hb2(k,num_conti,i)=!ghalfm
3445      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3446      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3447      &          *fac_shield(i)*fac_shield(j)*sss
3448
3449                   gacontm_hb3(k,num_conti,i)=gggm(k)
3450      &          *fac_shield(i)*fac_shield(j)*sss
3451
3452                 enddo
3453 C Diagnostics. Comment out or remove after debugging!
3454 cdiag           do k=1,3
3455 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3456 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3457 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3458 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3459 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3460 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3461 cdiag           enddo
3462
3463                  endif ! calc_grad
3464
3465               ENDIF ! wcorr
3466               endif  ! num_conti.le.maxconts
3467             endif  ! fcont.gt.0
3468           endif    ! j.gt.i+1
3469 #endif
3470           if (calc_grad) then
3471           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3472             do k=1,4
3473               do l=1,3
3474                 ghalf=0.5d0*agg(l,k)
3475                 aggi(l,k)=aggi(l,k)+ghalf
3476                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3477                 aggj(l,k)=aggj(l,k)+ghalf
3478               enddo
3479             enddo
3480             if (j.eq.nres-1 .and. i.lt.j-2) then
3481               do k=1,4
3482                 do l=1,3
3483                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3484                 enddo
3485               enddo
3486             endif
3487           endif
3488           endif ! calc_grad
3489 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3490       return
3491       end
3492 C-----------------------------------------------------------------------------
3493       subroutine eturn3(i,eello_turn3)
3494 C Third- and fourth-order contributions from turns
3495       implicit real*8 (a-h,o-z)
3496       include 'DIMENSIONS'
3497       include 'DIMENSIONS.ZSCOPT'
3498       include 'COMMON.IOUNITS'
3499       include 'COMMON.GEO'
3500       include 'COMMON.VAR'
3501       include 'COMMON.LOCAL'
3502       include 'COMMON.CHAIN'
3503       include 'COMMON.DERIV'
3504       include 'COMMON.INTERACT'
3505       include 'COMMON.CONTACTS'
3506       include 'COMMON.TORSION'
3507       include 'COMMON.VECTORS'
3508       include 'COMMON.FFIELD'
3509       include 'COMMON.CONTROL'
3510       include 'COMMON.SHIELD'
3511       include 'COMMON.CORRMAT'
3512       dimension ggg(3)
3513       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3514      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3515      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3516      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3517      &  auxgmat2(2,2),auxgmatt2(2,2)
3518       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3519      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3520       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3521      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3522      &    num_conti,j1,j2
3523       j=i+2
3524 c      write (iout,*) "eturn3",i,j,j1,j2
3525       a_temp(1,1)=a22
3526       a_temp(1,2)=a23
3527       a_temp(2,1)=a32
3528       a_temp(2,2)=a33
3529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3530 C
3531 C               Third-order contributions
3532 C
3533 C                 (i+2)o----(i+3)
3534 C                      | |
3535 C                      | |
3536 C                 (i+1)o----i
3537 C
3538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3539 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3540         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3541 c auxalary matices for theta gradient
3542 c auxalary matrix for i+1 and constant i+2
3543         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3544 c auxalary matrix for i+2 and constant i+1
3545         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3546         call transpose2(auxmat(1,1),auxmat1(1,1))
3547         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3548         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3549         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3550         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3551         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3552         if (shield_mode.eq.0) then
3553         fac_shield(i)=1.0
3554         fac_shield(j)=1.0
3555 C        else
3556 C        fac_shield(i)=0.4
3557 C        fac_shield(j)=0.6
3558         endif
3559         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3560      &  *fac_shield(i)*fac_shield(j)
3561         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3562      &  *fac_shield(i)*fac_shield(j)
3563         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3564      &    eello_t3
3565         if (calc_grad) then
3566 C#ifdef NEWCORR
3567 C Derivatives in theta
3568         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3569      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3570      &   *fac_shield(i)*fac_shield(j)
3571         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3572      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3573      &   *fac_shield(i)*fac_shield(j)
3574 C#endif
3575
3576 C Derivatives in shield mode
3577           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3578      &  (shield_mode.gt.0)) then
3579 C          print *,i,j
3580
3581           do ilist=1,ishield_list(i)
3582            iresshield=shield_list(ilist,i)
3583            do k=1,3
3584            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3585 C     &      *2.0
3586            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3587      &              rlocshield
3588      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3589             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3590      &      +rlocshield
3591            enddo
3592           enddo
3593           do ilist=1,ishield_list(j)
3594            iresshield=shield_list(ilist,j)
3595            do k=1,3
3596            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3597 C     &     *2.0
3598            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3599      &              rlocshield
3600      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3601            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3602      &             +rlocshield
3603
3604            enddo
3605           enddo
3606
3607           do k=1,3
3608             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3609      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3610             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3611      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3612             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3613      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3614             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3615      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3616            enddo
3617            endif
3618
3619 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3620 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3621 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3622 cd     &    ' eello_turn3_num',4*eello_turn3_num
3623 C Derivatives in gamma(i)
3624         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3625         call transpose2(auxmat2(1,1),auxmat3(1,1))
3626         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3627         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3628      &   *fac_shield(i)*fac_shield(j)
3629 C Derivatives in gamma(i+1)
3630         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3631         call transpose2(auxmat2(1,1),auxmat3(1,1))
3632         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3633         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3634      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3635      &   *fac_shield(i)*fac_shield(j)
3636 C Cartesian derivatives
3637         do l=1,3
3638 c            ghalf1=0.5d0*agg(l,1)
3639 c            ghalf2=0.5d0*agg(l,2)
3640 c            ghalf3=0.5d0*agg(l,3)
3641 c            ghalf4=0.5d0*agg(l,4)
3642           a_temp(1,1)=aggi(l,1)!+ghalf1
3643           a_temp(1,2)=aggi(l,2)!+ghalf2
3644           a_temp(2,1)=aggi(l,3)!+ghalf3
3645           a_temp(2,2)=aggi(l,4)!+ghalf4
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649      &   *fac_shield(i)*fac_shield(j)
3650
3651           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3652           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3653           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3654           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3655           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3656           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3657      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3658      &   *fac_shield(i)*fac_shield(j)
3659           a_temp(1,1)=aggj(l,1)!+ghalf1
3660           a_temp(1,2)=aggj(l,2)!+ghalf2
3661           a_temp(2,1)=aggj(l,3)!+ghalf3
3662           a_temp(2,2)=aggj(l,4)!+ghalf4
3663           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3664           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3665      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3666      &   *fac_shield(i)*fac_shield(j)
3667           a_temp(1,1)=aggj1(l,1)
3668           a_temp(1,2)=aggj1(l,2)
3669           a_temp(2,1)=aggj1(l,3)
3670           a_temp(2,2)=aggj1(l,4)
3671           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3672           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3673      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3674      &   *fac_shield(i)*fac_shield(j)
3675         enddo
3676
3677         endif ! calc_grad
3678
3679       return
3680       end
3681 C-------------------------------------------------------------------------------
3682       subroutine eturn4(i,eello_turn4)
3683 C Third- and fourth-order contributions from turns
3684       implicit real*8 (a-h,o-z)
3685       include 'DIMENSIONS'
3686       include 'DIMENSIONS.ZSCOPT'
3687       include 'COMMON.IOUNITS'
3688       include 'COMMON.GEO'
3689       include 'COMMON.VAR'
3690       include 'COMMON.LOCAL'
3691       include 'COMMON.CHAIN'
3692       include 'COMMON.DERIV'
3693       include 'COMMON.INTERACT'
3694       include 'COMMON.CONTACTS'
3695       include 'COMMON.TORSION'
3696       include 'COMMON.VECTORS'
3697       include 'COMMON.FFIELD'
3698       include 'COMMON.CONTROL'
3699       include 'COMMON.SHIELD'
3700       include 'COMMON.CORRMAT'
3701       dimension ggg(3)
3702       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3703      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3704      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3705      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3706      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3707      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3708      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3709       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3710      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3711       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3712      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3713      &    num_conti,j1,j2
3714       j=i+3
3715 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3716 C
3717 C               Fourth-order contributions
3718 C
3719 C                 (i+3)o----(i+4)
3720 C                     /  |
3721 C               (i+2)o   |
3722 C                     \  |
3723 C                 (i+1)o----i
3724 C
3725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3726 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3727 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3728 c        write(iout,*)"WCHODZE W PROGRAM"
3729         a_temp(1,1)=a22
3730         a_temp(1,2)=a23
3731         a_temp(2,1)=a32
3732         a_temp(2,2)=a33
3733         iti1=itype2loc(itype(i+1))
3734         iti2=itype2loc(itype(i+2))
3735         iti3=itype2loc(itype(i+3))
3736 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3737         call transpose2(EUg(1,1,i+1),e1t(1,1))
3738         call transpose2(Eug(1,1,i+2),e2t(1,1))
3739         call transpose2(Eug(1,1,i+3),e3t(1,1))
3740 C Ematrix derivative in theta
3741         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3742         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3743         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3744         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3745 c       eta1 in derivative theta
3746         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3747         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3748 c       auxgvec is derivative of Ub2 so i+3 theta
3749         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3750 c       auxalary matrix of E i+1
3751         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3752 c        s1=0.0
3753 c        gs1=0.0
3754         s1=scalar2(b1(1,i+2),auxvec(1))
3755 c derivative of theta i+2 with constant i+3
3756         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3757 c derivative of theta i+2 with constant i+2
3758         gs32=scalar2(b1(1,i+2),auxgvec(1))
3759 c derivative of E matix in theta of i+1
3760         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3761
3762         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3763 c       ea31 in derivative theta
3764         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3765         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3766 c auxilary matrix auxgvec of Ub2 with constant E matirx
3767         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3768 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3769         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3770
3771 c        s2=0.0
3772 c        gs2=0.0
3773         s2=scalar2(b1(1,i+1),auxvec(1))
3774 c derivative of theta i+1 with constant i+3
3775         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3776 c derivative of theta i+2 with constant i+1
3777         gs21=scalar2(b1(1,i+1),auxgvec(1))
3778 c derivative of theta i+3 with constant i+1
3779         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3780 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3781 c     &  gtb1(1,i+1)
3782         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3783 c two derivatives over diffetent matrices
3784 c gtae3e2 is derivative over i+3
3785         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3786 c ae3gte2 is derivative over i+2
3787         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3788         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3789 c three possible derivative over theta E matices
3790 c i+1
3791         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3792 c i+2
3793         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3794 c i+3
3795         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3796         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3797
3798         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3799         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3800         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3801         if (shield_mode.eq.0) then
3802         fac_shield(i)=1.0
3803         fac_shield(j)=1.0
3804 C        else
3805 C        fac_shield(i)=0.6
3806 C        fac_shield(j)=0.4
3807         endif
3808         eello_turn4=eello_turn4-(s1+s2+s3)
3809      &  *fac_shield(i)*fac_shield(j)
3810         eello_t4=-(s1+s2+s3)
3811      &  *fac_shield(i)*fac_shield(j)
3812 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3813         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3814      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3815 C Now derivative over shield:
3816           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3817      &  (shield_mode.gt.0)) then
3818 C          print *,i,j
3819
3820           do ilist=1,ishield_list(i)
3821            iresshield=shield_list(ilist,i)
3822            do k=1,3
3823            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3824 C     &      *2.0
3825            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3826      &              rlocshield
3827      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3828             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3829      &      +rlocshield
3830            enddo
3831           enddo
3832           do ilist=1,ishield_list(j)
3833            iresshield=shield_list(ilist,j)
3834            do k=1,3
3835            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3836 C     &     *2.0
3837            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3838      &              rlocshield
3839      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3840            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3841      &             +rlocshield
3842
3843            enddo
3844           enddo
3845
3846           do k=1,3
3847             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3848      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3849             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3850      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3851             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3852      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3853             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3854      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3855            enddo
3856            endif
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 #ifdef NEWCORR
3860         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3861      &                  -(gs13+gsE13+gsEE1)*wturn4
3862      &  *fac_shield(i)*fac_shield(j)
3863         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3864      &                    -(gs23+gs21+gsEE2)*wturn4
3865      &  *fac_shield(i)*fac_shield(j)
3866
3867         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3868      &                    -(gs32+gsE31+gsEE3)*wturn4
3869      &  *fac_shield(i)*fac_shield(j)
3870
3871 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3872 c     &   gs2
3873 #endif
3874         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3875      &      'eturn4',i,j,-(s1+s2+s3)
3876 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3877 c     &    ' eello_turn4_num',8*eello_turn4_num
3878 C Derivatives in gamma(i)
3879         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3880         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3881         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3882         s1=scalar2(b1(1,i+2),auxvec(1))
3883         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3886      &  *fac_shield(i)*fac_shield(j)
3887 C Derivatives in gamma(i+1)
3888         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3889         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3890         s2=scalar2(b1(1,i+1),auxvec(1))
3891         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3892         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3893         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3894         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3895      &  *fac_shield(i)*fac_shield(j)
3896 C Derivatives in gamma(i+2)
3897         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3898         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3899         s1=scalar2(b1(1,i+2),auxvec(1))
3900         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3901         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3902         s2=scalar2(b1(1,i+1),auxvec(1))
3903         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3904         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3905         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3906         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3907      &  *fac_shield(i)*fac_shield(j)
3908         if (calc_grad) then
3909 C Cartesian derivatives
3910 C Derivatives of this turn contributions in DC(i+2)
3911         if (j.lt.nres-1) then
3912           do l=1,3
3913             a_temp(1,1)=agg(l,1)
3914             a_temp(1,2)=agg(l,2)
3915             a_temp(2,1)=agg(l,3)
3916             a_temp(2,2)=agg(l,4)
3917             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919             s1=scalar2(b1(1,i+2),auxvec(1))
3920             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922             s2=scalar2(b1(1,i+1),auxvec(1))
3923             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926             ggg(l)=-(s1+s2+s3)
3927             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3928      &  *fac_shield(i)*fac_shield(j)
3929           enddo
3930         endif
3931 C Remaining derivatives of this turn contribution
3932         do l=1,3
3933           a_temp(1,1)=aggi(l,1)
3934           a_temp(1,2)=aggi(l,2)
3935           a_temp(2,1)=aggi(l,3)
3936           a_temp(2,2)=aggi(l,4)
3937           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3938           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3939           s1=scalar2(b1(1,i+2),auxvec(1))
3940           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3941           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3942           s2=scalar2(b1(1,i+1),auxvec(1))
3943           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3944           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3945           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3946           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3947      &  *fac_shield(i)*fac_shield(j)
3948           a_temp(1,1)=aggi1(l,1)
3949           a_temp(1,2)=aggi1(l,2)
3950           a_temp(2,1)=aggi1(l,3)
3951           a_temp(2,2)=aggi1(l,4)
3952           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3953           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3954           s1=scalar2(b1(1,i+2),auxvec(1))
3955           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3956           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3957           s2=scalar2(b1(1,i+1),auxvec(1))
3958           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3959           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3960           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3961           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3962      &  *fac_shield(i)*fac_shield(j)
3963           a_temp(1,1)=aggj(l,1)
3964           a_temp(1,2)=aggj(l,2)
3965           a_temp(2,1)=aggj(l,3)
3966           a_temp(2,2)=aggj(l,4)
3967           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3968           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3969           s1=scalar2(b1(1,i+2),auxvec(1))
3970           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3971           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3972           s2=scalar2(b1(1,i+1),auxvec(1))
3973           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3974           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3975           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3976           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3977      &  *fac_shield(i)*fac_shield(j)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,i+2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,i+1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993      &  *fac_shield(i)*fac_shield(j)
3994         enddo
3995
3996         endif ! calc_grad
3997
3998       return
3999       end
4000 C-----------------------------------------------------------------------------
4001       subroutine vecpr(u,v,w)
4002       implicit real*8(a-h,o-z)
4003       dimension u(3),v(3),w(3)
4004       w(1)=u(2)*v(3)-u(3)*v(2)
4005       w(2)=-u(1)*v(3)+u(3)*v(1)
4006       w(3)=u(1)*v(2)-u(2)*v(1)
4007       return
4008       end
4009 C-----------------------------------------------------------------------------
4010       subroutine unormderiv(u,ugrad,unorm,ungrad)
4011 C This subroutine computes the derivatives of a normalized vector u, given
4012 C the derivatives computed without normalization conditions, ugrad. Returns
4013 C ungrad.
4014       implicit none
4015       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4016       double precision vec(3)
4017       double precision scalar
4018       integer i,j
4019 c      write (2,*) 'ugrad',ugrad
4020 c      write (2,*) 'u',u
4021       do i=1,3
4022         vec(i)=scalar(ugrad(1,i),u(1))
4023       enddo
4024 c      write (2,*) 'vec',vec
4025       do i=1,3
4026         do j=1,3
4027           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4028         enddo
4029       enddo
4030 c      write (2,*) 'ungrad',ungrad
4031       return
4032       end
4033 C-----------------------------------------------------------------------------
4034       subroutine escp(evdw2,evdw2_14)
4035 C
4036 C This subroutine calculates the excluded-volume interaction energy between
4037 C peptide-group centers and side chains and its gradient in virtual-bond and
4038 C side-chain vectors.
4039 C
4040       implicit real*8 (a-h,o-z)
4041       include 'DIMENSIONS'
4042       include 'DIMENSIONS.ZSCOPT'
4043       include 'COMMON.CONTROL'
4044       include 'COMMON.GEO'
4045       include 'COMMON.VAR'
4046       include 'COMMON.LOCAL'
4047       include 'COMMON.CHAIN'
4048       include 'COMMON.DERIV'
4049       include 'COMMON.INTERACT'
4050       include 'COMMON.FFIELD'
4051       include 'COMMON.IOUNITS'
4052       dimension ggg(3)
4053       evdw2=0.0D0
4054       evdw2_14=0.0d0
4055 cd    print '(a)','Enter ESCP'
4056 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4057 c     &  ' scal14',scal14
4058       do i=iatscp_s,iatscp_e
4059         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4060         iteli=itel(i)
4061 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4062 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4063         if (iteli.eq.0) goto 1225
4064         xi=0.5D0*(c(1,i)+c(1,i+1))
4065         yi=0.5D0*(c(2,i)+c(2,i+1))
4066         zi=0.5D0*(c(3,i)+c(3,i+1))
4067 C Returning the ith atom to box
4068           xi=mod(xi,boxxsize)
4069           if (xi.lt.0) xi=xi+boxxsize
4070           yi=mod(yi,boxysize)
4071           if (yi.lt.0) yi=yi+boxysize
4072           zi=mod(zi,boxzsize)
4073           if (zi.lt.0) zi=zi+boxzsize
4074         do iint=1,nscp_gr(i)
4075
4076         do j=iscpstart(i,iint),iscpend(i,iint)
4077           itypj=iabs(itype(j))
4078           if (itypj.eq.ntyp1) cycle
4079 C Uncomment following three lines for SC-p interactions
4080 c         xj=c(1,nres+j)-xi
4081 c         yj=c(2,nres+j)-yi
4082 c         zj=c(3,nres+j)-zi
4083 C Uncomment following three lines for Ca-p interactions
4084           xj=c(1,j)
4085           yj=c(2,j)
4086           zj=c(3,j)
4087 C returning the jth atom to box
4088           xj=mod(xj,boxxsize)
4089           if (xj.lt.0) xj=xj+boxxsize
4090           yj=mod(yj,boxysize)
4091           if (yj.lt.0) yj=yj+boxysize
4092           zj=mod(zj,boxzsize)
4093           if (zj.lt.0) zj=zj+boxzsize
4094       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4095       xj_safe=xj
4096       yj_safe=yj
4097       zj_safe=zj
4098       subchap=0
4099 C Finding the closest jth atom
4100       do xshift=-1,1
4101       do yshift=-1,1
4102       do zshift=-1,1
4103           xj=xj_safe+xshift*boxxsize
4104           yj=yj_safe+yshift*boxysize
4105           zj=zj_safe+zshift*boxzsize
4106           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4107           if(dist_temp.lt.dist_init) then
4108             dist_init=dist_temp
4109             xj_temp=xj
4110             yj_temp=yj
4111             zj_temp=zj
4112             subchap=1
4113           endif
4114        enddo
4115        enddo
4116        enddo
4117        if (subchap.eq.1) then
4118           xj=xj_temp-xi
4119           yj=yj_temp-yi
4120           zj=zj_temp-zi
4121        else
4122           xj=xj_safe-xi
4123           yj=yj_safe-yi
4124           zj=zj_safe-zi
4125        endif
4126           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4127 C sss is scaling function for smoothing the cutoff gradient otherwise
4128 C the gradient would not be continuouse
4129           sss=sscale(1.0d0/(dsqrt(rrij)))
4130           if (sss.le.0.0d0) cycle
4131           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4132           fac=rrij**expon2
4133           e1=fac*fac*aad(itypj,iteli)
4134           e2=fac*bad(itypj,iteli)
4135           if (iabs(j-i) .le. 2) then
4136             e1=scal14*e1
4137             e2=scal14*e2
4138             evdw2_14=evdw2_14+(e1+e2)*sss
4139           endif
4140           evdwij=e1+e2
4141 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4142 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4143 c     &       bad(itypj,iteli)
4144           evdw2=evdw2+evdwij*sss
4145           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4146      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4147      &       bad(itypj,iteli)
4148
4149           if (calc_grad) then
4150 C
4151 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4152 C
4153           fac=-(evdwij+e1)*rrij*sss
4154           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4155           ggg(1)=xj*fac
4156           ggg(2)=yj*fac
4157           ggg(3)=zj*fac
4158           if (j.lt.i) then
4159 cd          write (iout,*) 'j<i'
4160 C Uncomment following three lines for SC-p interactions
4161 c           do k=1,3
4162 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4163 c           enddo
4164           else
4165 cd          write (iout,*) 'j>i'
4166             do k=1,3
4167               ggg(k)=-ggg(k)
4168 C Uncomment following line for SC-p interactions
4169 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4170             enddo
4171           endif
4172           do k=1,3
4173             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4174           enddo
4175           kstart=min0(i+1,j)
4176           kend=max0(i-1,j-1)
4177 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4178 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4179           do k=kstart,kend
4180             do l=1,3
4181               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4182             enddo
4183           enddo
4184           endif ! calc_grad
4185         enddo
4186         enddo ! iint
4187  1225   continue
4188       enddo ! i
4189       do i=1,nct
4190         do j=1,3
4191           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4192           gradx_scp(j,i)=expon*gradx_scp(j,i)
4193         enddo
4194       enddo
4195 C******************************************************************************
4196 C
4197 C                              N O T E !!!
4198 C
4199 C To save time the factor EXPON has been extracted from ALL components
4200 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4201 C use!
4202 C
4203 C******************************************************************************
4204       return
4205       end
4206 C--------------------------------------------------------------------------
4207       subroutine edis(ehpb)
4208 C
4209 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4210 C
4211       implicit real*8 (a-h,o-z)
4212       include 'DIMENSIONS'
4213       include 'DIMENSIONS.ZSCOPT'
4214       include 'COMMON.SBRIDGE'
4215       include 'COMMON.CHAIN'
4216       include 'COMMON.DERIV'
4217       include 'COMMON.VAR'
4218       include 'COMMON.INTERACT'
4219       include 'COMMON.CONTROL'
4220       include 'COMMON.IOUNITS'
4221       dimension ggg(3),ggg_peak(3,1000)
4222       ehpb=0.0D0
4223       do i=1,3
4224        ggg(i)=0.0d0
4225       enddo
4226 c 8/21/18 AL: added explicit restraints on reference coords
4227 c      write (iout,*) "restr_on_coord",restr_on_coord
4228       if (restr_on_coord) then
4229
4230       do i=nnt,nct
4231         ecoor=0.0d0
4232         if (itype(i).eq.ntyp1) cycle
4233         do j=1,3
4234           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4235           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4236         enddo
4237         if (itype(i).ne.10) then
4238           do j=1,3
4239             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4240             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4241           enddo
4242         endif
4243         if (energy_dec) write (iout,*)
4244      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4245         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4246       enddo
4247
4248       endif
4249
4250 C      write (iout,*) ,"link_end",link_end,constr_dist
4251 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4252 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4253 c     &  " constr_dist",constr_dist
4254       if (link_end.eq.0.and.link_end_peak.eq.0) return
4255       do i=link_start_peak,link_end_peak
4256         ehpb_peak=0.0d0
4257 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4258 c     &   ipeak(1,i),ipeak(2,i)
4259         do ip=ipeak(1,i),ipeak(2,i)
4260           ii=ihpb_peak(ip)
4261           jj=jhpb_peak(ip)
4262           dd=dist(ii,jj)
4263           iip=ip-ipeak(1,i)+1
4264 C iii and jjj point to the residues for which the distance is assigned.
4265 c          if (ii.gt.nres) then
4266 c            iii=ii-nres
4267 c            jjj=jj-nres
4268 c          else
4269 c            iii=ii
4270 c            jjj=jj
4271 c          endif
4272           if (ii.gt.nres) then
4273             iii=ii-nres
4274           else
4275             iii=ii
4276           endif
4277           if (jj.gt.nres) then
4278             jjj=jj-nres
4279           else
4280             jjj=jj
4281           endif
4282           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4283           aux=dexp(-scal_peak*aux)
4284           ehpb_peak=ehpb_peak+aux
4285           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4286      &      forcon_peak(ip))*aux/dd
4287           do j=1,3
4288             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4289           enddo
4290           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4291      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4292      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4293         enddo
4294 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4295         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4296         do ip=ipeak(1,i),ipeak(2,i)
4297           iip=ip-ipeak(1,i)+1
4298           do j=1,3
4299             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4300           enddo
4301           ii=ihpb_peak(ip)
4302           jj=jhpb_peak(ip)
4303 C iii and jjj point to the residues for which the distance is assigned.
4304           if (ii.gt.nres) then
4305             iii=ii-nres
4306             jjj=jj-nres
4307           else
4308             iii=ii
4309             jjj=jj
4310           endif
4311           if (iii.lt.ii) then
4312             do j=1,3
4313               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4314             enddo
4315           endif
4316           if (jjj.lt.jj) then
4317             do j=1,3
4318               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4319             enddo
4320           endif
4321           do k=1,3
4322             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4323             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4324           enddo
4325         enddo
4326       enddo
4327       do i=link_start,link_end
4328 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4329 C CA-CA distance used in regularization of structure.
4330         ii=ihpb(i)
4331         jj=jhpb(i)
4332 C iii and jjj point to the residues for which the distance is assigned.
4333         if (ii.gt.nres) then
4334           iii=ii-nres
4335         else
4336           iii=ii
4337         endif
4338         if (jj.gt.nres) then
4339           jjj=jj-nres
4340         else
4341           jjj=jj
4342         endif
4343 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4344 c     &    dhpb(i),dhpb1(i),forcon(i)
4345 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4346 C    distance and angle dependent SS bond potential.
4347 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4348 C     & iabs(itype(jjj)).eq.1) then
4349 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4350 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4351         if (.not.dyn_ss .and. i.le.nss) then
4352 C 15/02/13 CC dynamic SSbond - additional check
4353           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4354      &        iabs(itype(jjj)).eq.1) then
4355            call ssbond_ene(iii,jjj,eij)
4356            ehpb=ehpb+2*eij
4357          endif
4358 cd          write (iout,*) "eij",eij
4359 cd   &   ' waga=',waga,' fac=',fac
4360 !        else if (ii.gt.nres .and. jj.gt.nres) then
4361         else
4362 C Calculate the distance between the two points and its difference from the
4363 C target distance.
4364           dd=dist(ii,jj)
4365           if (irestr_type(i).eq.11) then
4366             ehpb=ehpb+fordepth(i)!**4.0d0
4367      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4368             fac=fordepth(i)!**4.0d0
4369      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4370             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4371      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4372      &        ehpb,irestr_type(i)
4373           else if (irestr_type(i).eq.10) then
4374 c AL 6//19/2018 cross-link restraints
4375             xdis = 0.5d0*(dd/forcon(i))**2
4376             expdis = dexp(-xdis)
4377 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4378             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4379 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4380 c     &          " wboltzd",wboltzd
4381             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4382 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4383             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4384      &           *expdis/(aux*forcon(i)**2)
4385             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4386      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4387      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4388           else if (irestr_type(i).eq.2) then
4389 c Quartic restraints
4390             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4391             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4392      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4393      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4394             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4395           else
4396 c Quadratic restraints
4397             rdis=dd-dhpb(i)
4398 C Get the force constant corresponding to this distance.
4399             waga=forcon(i)
4400 C Calculate the contribution to energy.
4401             ehpb=ehpb+0.5d0*waga*rdis*rdis
4402             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4403      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4404      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4405 C
4406 C Evaluate gradient.
4407 C
4408             fac=waga*rdis/dd
4409           endif
4410 c Calculate Cartesian gradient
4411           do j=1,3
4412             ggg(j)=fac*(c(j,jj)-c(j,ii))
4413           enddo
4414 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4415 C If this is a SC-SC distance, we need to calculate the contributions to the
4416 C Cartesian gradient in the SC vectors (ghpbx).
4417           if (iii.lt.ii) then
4418             do j=1,3
4419               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4420             enddo
4421           endif
4422           if (jjj.lt.jj) then
4423             do j=1,3
4424               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4425             enddo
4426           endif
4427           do k=1,3
4428             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4429             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4430           enddo
4431         endif
4432       enddo
4433       return
4434       end
4435 C--------------------------------------------------------------------------
4436       subroutine ssbond_ene(i,j,eij)
4437 C
4438 C Calculate the distance and angle dependent SS-bond potential energy
4439 C using a free-energy function derived based on RHF/6-31G** ab initio
4440 C calculations of diethyl disulfide.
4441 C
4442 C A. Liwo and U. Kozlowska, 11/24/03
4443 C
4444       implicit real*8 (a-h,o-z)
4445       include 'DIMENSIONS'
4446       include 'DIMENSIONS.ZSCOPT'
4447       include 'COMMON.SBRIDGE'
4448       include 'COMMON.CHAIN'
4449       include 'COMMON.DERIV'
4450       include 'COMMON.LOCAL'
4451       include 'COMMON.INTERACT'
4452       include 'COMMON.VAR'
4453       include 'COMMON.IOUNITS'
4454       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4455       itypi=iabs(itype(i))
4456       xi=c(1,nres+i)
4457       yi=c(2,nres+i)
4458       zi=c(3,nres+i)
4459       dxi=dc_norm(1,nres+i)
4460       dyi=dc_norm(2,nres+i)
4461       dzi=dc_norm(3,nres+i)
4462       dsci_inv=dsc_inv(itypi)
4463       itypj=iabs(itype(j))
4464       dscj_inv=dsc_inv(itypj)
4465       xj=c(1,nres+j)-xi
4466       yj=c(2,nres+j)-yi
4467       zj=c(3,nres+j)-zi
4468       dxj=dc_norm(1,nres+j)
4469       dyj=dc_norm(2,nres+j)
4470       dzj=dc_norm(3,nres+j)
4471       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4472       rij=dsqrt(rrij)
4473       erij(1)=xj*rij
4474       erij(2)=yj*rij
4475       erij(3)=zj*rij
4476       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4477       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4478       om12=dxi*dxj+dyi*dyj+dzi*dzj
4479       do k=1,3
4480         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4481         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4482       enddo
4483       rij=1.0d0/rij
4484       deltad=rij-d0cm
4485       deltat1=1.0d0-om1
4486       deltat2=1.0d0+om2
4487       deltat12=om2-om1+2.0d0
4488       cosphi=om12-om1*om2
4489       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4490      &  +akct*deltad*deltat12
4491      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4492 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4493 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4494 c     &  " deltat12",deltat12," eij",eij
4495       ed=2*akcm*deltad+akct*deltat12
4496       pom1=akct*deltad
4497       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4498       eom1=-2*akth*deltat1-pom1-om2*pom2
4499       eom2= 2*akth*deltat2+pom1-om1*pom2
4500       eom12=pom2
4501       do k=1,3
4502         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4503       enddo
4504       do k=1,3
4505         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4506      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4507         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4508      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4509       enddo
4510 C
4511 C Calculate the components of the gradient in DC and X
4512 C
4513       do k=i,j-1
4514         do l=1,3
4515           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4516         enddo
4517       enddo
4518       return
4519       end
4520 C--------------------------------------------------------------------------
4521 c MODELLER restraint function
4522       subroutine e_modeller(ehomology_constr)
4523       implicit real*8 (a-h,o-z)
4524       include 'DIMENSIONS'
4525       include 'DIMENSIONS.ZSCOPT'
4526       include 'DIMENSIONS.FREE'
4527       integer nnn, i, j, k, ki, irec, l
4528       integer katy, odleglosci, test7
4529       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4530       real*8 distance(max_template),distancek(max_template),
4531      &    min_odl,godl(max_template),dih_diff(max_template)
4532
4533 c
4534 c     FP - 30/10/2014 Temporary specifications for homology restraints
4535 c
4536       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4537      &                 sgtheta
4538       double precision, dimension (maxres) :: guscdiff,usc_diff
4539       double precision, dimension (max_template) ::
4540      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4541      &           theta_diff
4542
4543       include 'COMMON.SBRIDGE'
4544       include 'COMMON.CHAIN'
4545       include 'COMMON.GEO'
4546       include 'COMMON.DERIV'
4547       include 'COMMON.LOCAL'
4548       include 'COMMON.INTERACT'
4549       include 'COMMON.VAR'
4550       include 'COMMON.IOUNITS'
4551       include 'COMMON.CONTROL'
4552       include 'COMMON.HOMRESTR'
4553       include 'COMMON.HOMOLOGY'
4554       include 'COMMON.SETUP'
4555       include 'COMMON.NAMES'
4556
4557       do i=1,max_template
4558         distancek(i)=9999999.9
4559       enddo
4560
4561       odleg=0.0d0
4562
4563 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4564 c function)
4565 C AL 5/2/14 - Introduce list of restraints
4566 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4567 #ifdef DEBUG
4568       write(iout,*) "------- dist restrs start -------"
4569 #endif
4570       do ii = link_start_homo,link_end_homo
4571          i = ires_homo(ii)
4572          j = jres_homo(ii)
4573          dij=dist(i,j)
4574 c        write (iout,*) "dij(",i,j,") =",dij
4575          nexl=0
4576          do k=1,constr_homology
4577            if(.not.l_homo(k,ii)) then
4578               nexl=nexl+1
4579               cycle
4580            endif
4581            distance(k)=odl(k,ii)-dij
4582 c          write (iout,*) "distance(",k,") =",distance(k)
4583 c
4584 c          For Gaussian-type Urestr
4585 c
4586            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4587 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4588 c          write (iout,*) "distancek(",k,") =",distancek(k)
4589 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4590 c
4591 c          For Lorentzian-type Urestr
4592 c
4593            if (waga_dist.lt.0.0d0) then
4594               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4595               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4596      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4597            endif
4598          enddo
4599
4600 c         min_odl=minval(distancek)
4601          do kk=1,constr_homology
4602           if(l_homo(kk,ii)) then
4603             min_odl=distancek(kk)
4604             exit
4605           endif
4606          enddo
4607          do kk=1,constr_homology
4608           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4609      &              min_odl=distancek(kk)
4610          enddo
4611 c        write (iout,* )"min_odl",min_odl
4612 #ifdef DEBUG
4613          write (iout,*) "ij dij",i,j,dij
4614          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4615          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4616          write (iout,* )"min_odl",min_odl
4617 #endif
4618 #ifdef OLDRESTR
4619          odleg2=0.0d0
4620 #else
4621          if (waga_dist.ge.0.0d0) then
4622            odleg2=nexl
4623          else
4624            odleg2=0.0d0
4625          endif
4626 #endif
4627          do k=1,constr_homology
4628 c Nie wiem po co to liczycie jeszcze raz!
4629 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4630 c     &              (2*(sigma_odl(i,j,k))**2))
4631            if(.not.l_homo(k,ii)) cycle
4632            if (waga_dist.ge.0.0d0) then
4633 c
4634 c          For Gaussian-type Urestr
4635 c
4636             godl(k)=dexp(-distancek(k)+min_odl)
4637             odleg2=odleg2+godl(k)
4638 c
4639 c          For Lorentzian-type Urestr
4640 c
4641            else
4642             odleg2=odleg2+distancek(k)
4643            endif
4644
4645 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4646 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4647 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4648 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4649
4650          enddo
4651 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4652 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4653 #ifdef DEBUG
4654          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4655          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4656 #endif
4657            if (waga_dist.ge.0.0d0) then
4658 c
4659 c          For Gaussian-type Urestr
4660 c
4661               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4662 c
4663 c          For Lorentzian-type Urestr
4664 c
4665            else
4666               odleg=odleg+odleg2/constr_homology
4667            endif
4668 c
4669 #ifdef GRAD
4670 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4671 c Gradient
4672 c
4673 c          For Gaussian-type Urestr
4674 c
4675          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4676          sum_sgodl=0.0d0
4677          do k=1,constr_homology
4678 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4679 c     &           *waga_dist)+min_odl
4680 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4681 c
4682          if(.not.l_homo(k,ii)) cycle
4683          if (waga_dist.ge.0.0d0) then
4684 c          For Gaussian-type Urestr
4685 c
4686            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4687 c
4688 c          For Lorentzian-type Urestr
4689 c
4690          else
4691            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4692      &           sigma_odlir(k,ii)**2)**2)
4693          endif
4694            sum_sgodl=sum_sgodl+sgodl
4695
4696 c            sgodl2=sgodl2+sgodl
4697 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4698 c      write(iout,*) "constr_homology=",constr_homology
4699 c      write(iout,*) i, j, k, "TEST K"
4700          enddo
4701          if (waga_dist.ge.0.0d0) then
4702 c
4703 c          For Gaussian-type Urestr
4704 c
4705             grad_odl3=waga_homology(iset)*waga_dist
4706      &                *sum_sgodl/(sum_godl*dij)
4707 c
4708 c          For Lorentzian-type Urestr
4709 c
4710          else
4711 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4712 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4713             grad_odl3=-waga_homology(iset)*waga_dist*
4714      &                sum_sgodl/(constr_homology*dij)
4715          endif
4716 c
4717 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4718
4719
4720 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4721 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4722 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4723
4724 ccc      write(iout,*) godl, sgodl, grad_odl3
4725
4726 c          grad_odl=grad_odl+grad_odl3
4727
4728          do jik=1,3
4729             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4730 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4731 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4732 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4733             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4734             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4735 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4736 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4737 c         if (i.eq.25.and.j.eq.27) then
4738 c         write(iout,*) "jik",jik,"i",i,"j",j
4739 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4740 c         write(iout,*) "grad_odl3",grad_odl3
4741 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4742 c         write(iout,*) "ggodl",ggodl
4743 c         write(iout,*) "ghpbc(",jik,i,")",
4744 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4745 c     &                 ghpbc(jik,j)
4746 c         endif
4747          enddo
4748 #endif
4749 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4750 ccc     & dLOG(odleg2),"-odleg=", -odleg
4751
4752       enddo ! ii-loop for dist
4753 #ifdef DEBUG
4754       write(iout,*) "------- dist restrs end -------"
4755 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4756 c    &     waga_d.eq.1.0d0) call sum_gradient
4757 #endif
4758 c Pseudo-energy and gradient from dihedral-angle restraints from
4759 c homology templates
4760 c      write (iout,*) "End of distance loop"
4761 c      call flush(iout)
4762       kat=0.0d0
4763 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4764 #ifdef DEBUG
4765       write(iout,*) "------- dih restrs start -------"
4766       do i=idihconstr_start_homo,idihconstr_end_homo
4767         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4768       enddo
4769 #endif
4770       do i=idihconstr_start_homo,idihconstr_end_homo
4771         kat2=0.0d0
4772 c        betai=beta(i,i+1,i+2,i+3)
4773         betai = phi(i)
4774 c       write (iout,*) "betai =",betai
4775         do k=1,constr_homology
4776           dih_diff(k)=pinorm(dih(k,i)-betai)
4777 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4778 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4779 c     &                                   -(6.28318-dih_diff(i,k))
4780 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4781 c     &                                   6.28318+dih_diff(i,k)
4782 #ifdef OLD_DIHED
4783           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4784 #else
4785           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4786 #endif
4787 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4788           gdih(k)=dexp(kat3)
4789           kat2=kat2+gdih(k)
4790 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4791 c          write(*,*)""
4792         enddo
4793 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4794 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4795 #ifdef DEBUG
4796         write (iout,*) "i",i," betai",betai," kat2",kat2
4797         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4798 #endif
4799         if (kat2.le.1.0d-14) cycle
4800         kat=kat-dLOG(kat2/constr_homology)
4801 c       write (iout,*) "kat",kat ! sum of -ln-s
4802
4803 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4804 ccc     & dLOG(kat2), "-kat=", -kat
4805
4806 #ifdef GRAD
4807 c ----------------------------------------------------------------------
4808 c Gradient
4809 c ----------------------------------------------------------------------
4810
4811         sum_gdih=kat2
4812         sum_sgdih=0.0d0
4813         do k=1,constr_homology
4814 #ifdef OLD_DIHED
4815           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4816 #else
4817           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4818 #endif
4819 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4820           sum_sgdih=sum_sgdih+sgdih
4821         enddo
4822 c       grad_dih3=sum_sgdih/sum_gdih
4823         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4824
4825 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4826 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4827 ccc     & gloc(nphi+i-3,icg)
4828         gloc(i,icg)=gloc(i,icg)+grad_dih3
4829 c        if (i.eq.25) then
4830 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4831 c        endif
4832 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4833 ccc     & gloc(nphi+i-3,icg)
4834 #endif
4835       enddo ! i-loop for dih
4836 #ifdef DEBUG
4837       write(iout,*) "------- dih restrs end -------"
4838 #endif
4839
4840 c Pseudo-energy and gradient for theta angle restraints from
4841 c homology templates
4842 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4843 c adapted
4844
4845 c
4846 c     For constr_homology reference structures (FP)
4847 c
4848 c     Uconst_back_tot=0.0d0
4849       Eval=0.0d0
4850       Erot=0.0d0
4851 c     Econstr_back legacy
4852 #ifdef GRAD
4853       do i=1,nres
4854 c     do i=ithet_start,ithet_end
4855        dutheta(i)=0.0d0
4856 c     enddo
4857 c     do i=loc_start,loc_end
4858         do j=1,3
4859           duscdiff(j,i)=0.0d0
4860           duscdiffx(j,i)=0.0d0
4861         enddo
4862       enddo
4863 #endif
4864 c
4865 c     do iref=1,nref
4866 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4867 c     write (iout,*) "waga_theta",waga_theta
4868       if (waga_theta.gt.0.0d0) then
4869 #ifdef DEBUG
4870       write (iout,*) "usampl",usampl
4871       write(iout,*) "------- theta restrs start -------"
4872 c     do i=ithet_start,ithet_end
4873 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4874 c     enddo
4875 #endif
4876 c     write (iout,*) "maxres",maxres,"nres",nres
4877
4878       do i=ithet_start,ithet_end
4879 c
4880 c     do i=1,nfrag_back
4881 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4882 c
4883 c Deviation of theta angles wrt constr_homology ref structures
4884 c
4885         utheta_i=0.0d0 ! argument of Gaussian for single k
4886         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4887 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4888 c       over residues in a fragment
4889 c       write (iout,*) "theta(",i,")=",theta(i)
4890         do k=1,constr_homology
4891 c
4892 c         dtheta_i=theta(j)-thetaref(j,iref)
4893 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4894           theta_diff(k)=thetatpl(k,i)-theta(i)
4895 c
4896           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4897 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4898           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4899           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4900 c         Gradient for single Gaussian restraint in subr Econstr_back
4901 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4902 c
4903         enddo
4904 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4905 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4906
4907 c
4908 #ifdef GRAD
4909 c         Gradient for multiple Gaussian restraint
4910         sum_gtheta=gutheta_i
4911         sum_sgtheta=0.0d0
4912         do k=1,constr_homology
4913 c        New generalized expr for multiple Gaussian from Econstr_back
4914          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4915 c
4916 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4917           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4918         enddo
4919 c
4920 c       Final value of gradient using same var as in Econstr_back
4921         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4922      &               *waga_homology(iset)
4923 c       dutheta(i)=sum_sgtheta/sum_gtheta
4924 c
4925 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4926 #endif
4927         Eval=Eval-dLOG(gutheta_i/constr_homology)
4928 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4929 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4930 c       Uconst_back=Uconst_back+utheta(i)
4931       enddo ! (i-loop for theta)
4932 #ifdef DEBUG
4933       write(iout,*) "------- theta restrs end -------"
4934 #endif
4935       endif
4936 c
4937 c Deviation of local SC geometry
4938 c
4939 c Separation of two i-loops (instructed by AL - 11/3/2014)
4940 c
4941 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4942 c     write (iout,*) "waga_d",waga_d
4943
4944 #ifdef DEBUG
4945       write(iout,*) "------- SC restrs start -------"
4946       write (iout,*) "Initial duscdiff,duscdiffx"
4947       do i=loc_start,loc_end
4948         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4949      &                 (duscdiffx(jik,i),jik=1,3)
4950       enddo
4951 #endif
4952       do i=loc_start,loc_end
4953         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4954         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4955 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4956 c       write(iout,*) "xxtab, yytab, zztab"
4957 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4958         do k=1,constr_homology
4959 c
4960           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4961 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4962           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4963           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4964 c         write(iout,*) "dxx, dyy, dzz"
4965 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4966 c
4967           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4968 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4969 c         uscdiffk(k)=usc_diff(i)
4970           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4971           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4972 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4973 c     &      xxref(j),yyref(j),zzref(j)
4974         enddo
4975 c
4976 c       Gradient
4977 c
4978 c       Generalized expression for multiple Gaussian acc to that for a single
4979 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4980 c
4981 c       Original implementation
4982 c       sum_guscdiff=guscdiff(i)
4983 c
4984 c       sum_sguscdiff=0.0d0
4985 c       do k=1,constr_homology
4986 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4987 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4988 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4989 c       enddo
4990 c
4991 c       Implementation of new expressions for gradient (Jan. 2015)
4992 c
4993 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4994 #ifdef GRAD
4995         do k=1,constr_homology
4996 c
4997 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4998 c       before. Now the drivatives should be correct
4999 c
5000           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
5001 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
5002           dyy=-yytpl(k,i)+yytab(i) ! ibid y
5003           dzz=-zztpl(k,i)+zztab(i) ! ibid z
5004 c
5005 c         New implementation
5006 c
5007           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
5008      &                 sigma_d(k,i) ! for the grad wrt r'
5009 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
5010 c
5011 c
5012 c        New implementation
5013          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
5014          do jik=1,3
5015             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
5016      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
5017      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
5018             duscdiff(jik,i)=duscdiff(jik,i)+
5019      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
5020      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
5021             duscdiffx(jik,i)=duscdiffx(jik,i)+
5022      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
5023      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
5024 c
5025 #ifdef DEBUG
5026              write(iout,*) "jik",jik,"i",i
5027              write(iout,*) "dxx, dyy, dzz"
5028              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
5029              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
5030 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
5031 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
5032 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
5033 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
5034 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
5035 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
5036 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
5037 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
5038 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
5039 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
5040 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
5041 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
5042 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
5043 c            endif
5044 #endif
5045          enddo
5046         enddo
5047 #endif
5048 c
5049 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
5050 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
5051 c
5052 c        write (iout,*) i," uscdiff",uscdiff(i)
5053 c
5054 c Put together deviations from local geometry
5055
5056 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
5057 c      &            wfrag_back(3,i,iset)*uscdiff(i)
5058         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
5059 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
5060 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
5061 c       Uconst_back=Uconst_back+usc_diff(i)
5062 c
5063 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
5064 c
5065 c     New implment: multiplied by sum_sguscdiff
5066 c
5067
5068       enddo ! (i-loop for dscdiff)
5069
5070 c      endif
5071
5072 #ifdef DEBUG
5073       write(iout,*) "------- SC restrs end -------"
5074         write (iout,*) "------ After SC loop in e_modeller ------"
5075         do i=loc_start,loc_end
5076          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
5077          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
5078         enddo
5079       if (waga_theta.eq.1.0d0) then
5080       write (iout,*) "in e_modeller after SC restr end: dutheta"
5081       do i=ithet_start,ithet_end
5082         write (iout,*) i,dutheta(i)
5083       enddo
5084       endif
5085       if (waga_d.eq.1.0d0) then
5086       write (iout,*) "e_modeller after SC loop: duscdiff/x"
5087       do i=1,nres
5088         write (iout,*) i,(duscdiff(j,i),j=1,3)
5089         write (iout,*) i,(duscdiffx(j,i),j=1,3)
5090       enddo
5091       endif
5092 #endif
5093
5094 c Total energy from homology restraints
5095 #ifdef DEBUG
5096       write (iout,*) "odleg",odleg," kat",kat
5097       write (iout,*) "odleg",odleg," kat",kat
5098       write (iout,*) "Eval",Eval," Erot",Erot
5099       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5100       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5101       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5102 #endif
5103 c
5104 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5105 c
5106 c     ehomology_constr=odleg+kat
5107 c
5108 c     For Lorentzian-type Urestr
5109 c
5110
5111       if (waga_dist.ge.0.0d0) then
5112 c
5113 c          For Gaussian-type Urestr
5114 c
5115 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5116 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5117         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5118      &              waga_theta*Eval+waga_d*Erot
5119 c     write (iout,*) "ehomology_constr=",ehomology_constr
5120       else
5121 c
5122 c          For Lorentzian-type Urestr
5123 c
5124 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5125 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5126         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5127      &              waga_theta*Eval+waga_d*Erot
5128 c     write (iout,*) "ehomology_constr=",ehomology_constr
5129       endif
5130 #ifdef DEBUG
5131       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5132      & "Eval",waga_theta,eval,
5133      &   "Erot",waga_d,Erot
5134       write (iout,*) "ehomology_constr",ehomology_constr
5135 #endif
5136       return
5137
5138   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5139   747 format(a12,i4,i4,i4,f8.3,f8.3)
5140   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5141   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5142   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5143      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5144       end
5145 c-----------------------------------------------------------------------
5146       subroutine ebond(estr)
5147 c
5148 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5149 c
5150       implicit real*8 (a-h,o-z)
5151       include 'DIMENSIONS'
5152       include 'DIMENSIONS.ZSCOPT'
5153       include 'COMMON.LOCAL'
5154       include 'COMMON.GEO'
5155       include 'COMMON.INTERACT'
5156       include 'COMMON.DERIV'
5157       include 'COMMON.VAR'
5158       include 'COMMON.CHAIN'
5159       include 'COMMON.IOUNITS'
5160       include 'COMMON.NAMES'
5161       include 'COMMON.FFIELD'
5162       include 'COMMON.CONTROL'
5163       double precision u(3),ud(3)
5164       estr=0.0d0
5165       estr1=0.0d0
5166 c      write (iout,*) "distchainmax",distchainmax
5167       do i=nnt+1,nct
5168         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5169 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5170 C          do j=1,3
5171 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5172 C     &      *dc(j,i-1)/vbld(i)
5173 C          enddo
5174 C          if (energy_dec) write(iout,*)
5175 C     &       "estr1",i,vbld(i),distchainmax,
5176 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5177 C        else
5178          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5179         diff = vbld(i)-vbldpDUM
5180 C         write(iout,*) i,diff
5181          else
5182           diff = vbld(i)-vbldp0
5183 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5184          endif
5185           estr=estr+diff*diff
5186           do j=1,3
5187             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5188           enddo
5189 C        endif
5190 C        write (iout,'(a7,i5,4f7.3)')
5191 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5192       enddo
5193       estr=0.5d0*AKP*estr+estr1
5194 c
5195 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5196 c
5197       do i=nnt,nct
5198         iti=iabs(itype(i))
5199         if (iti.ne.10 .and. iti.ne.ntyp1) then
5200           nbi=nbondterm(iti)
5201           if (nbi.eq.1) then
5202             diff=vbld(i+nres)-vbldsc0(1,iti)
5203 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5204 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5205             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5206             do j=1,3
5207               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5208             enddo
5209           else
5210             do j=1,nbi
5211               diff=vbld(i+nres)-vbldsc0(j,iti)
5212               ud(j)=aksc(j,iti)*diff
5213               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5214             enddo
5215             uprod=u(1)
5216             do j=2,nbi
5217               uprod=uprod*u(j)
5218             enddo
5219             usum=0.0d0
5220             usumsqder=0.0d0
5221             do j=1,nbi
5222               uprod1=1.0d0
5223               uprod2=1.0d0
5224               do k=1,nbi
5225                 if (k.ne.j) then
5226                   uprod1=uprod1*u(k)
5227                   uprod2=uprod2*u(k)*u(k)
5228                 endif
5229               enddo
5230               usum=usum+uprod1
5231               usumsqder=usumsqder+ud(j)*uprod2
5232             enddo
5233 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5234 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5235             estr=estr+uprod/usum
5236             do j=1,3
5237              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5238             enddo
5239           endif
5240         endif
5241       enddo
5242       return
5243       end
5244 #ifdef CRYST_THETA
5245 C--------------------------------------------------------------------------
5246       subroutine ebend(etheta,ethetacnstr)
5247 C
5248 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5249 C angles gamma and its derivatives in consecutive thetas and gammas.
5250 C
5251       implicit real*8 (a-h,o-z)
5252       include 'DIMENSIONS'
5253       include 'DIMENSIONS.ZSCOPT'
5254       include 'COMMON.LOCAL'
5255       include 'COMMON.GEO'
5256       include 'COMMON.INTERACT'
5257       include 'COMMON.DERIV'
5258       include 'COMMON.VAR'
5259       include 'COMMON.CHAIN'
5260       include 'COMMON.IOUNITS'
5261       include 'COMMON.NAMES'
5262       include 'COMMON.FFIELD'
5263       include 'COMMON.TORCNSTR'
5264       common /calcthet/ term1,term2,termm,diffak,ratak,
5265      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5266      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5267       double precision y(2),z(2)
5268       delta=0.02d0*pi
5269 c      time11=dexp(-2*time)
5270 c      time12=1.0d0
5271       etheta=0.0D0
5272 c      write (iout,*) "nres",nres
5273 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5274 c      write (iout,*) ithet_start,ithet_end
5275       do i=ithet_start,ithet_end
5276 C        if (itype(i-1).eq.ntyp1) cycle
5277         if (i.le.2) cycle
5278         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5279      &  .or.itype(i).eq.ntyp1) cycle
5280 C Zero the energy function and its derivative at 0 or pi.
5281         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5282         it=itype(i-1)
5283         ichir1=isign(1,itype(i-2))
5284         ichir2=isign(1,itype(i))
5285          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5286          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5287          if (itype(i-1).eq.10) then
5288           itype1=isign(10,itype(i-2))
5289           ichir11=isign(1,itype(i-2))
5290           ichir12=isign(1,itype(i-2))
5291           itype2=isign(10,itype(i))
5292           ichir21=isign(1,itype(i))
5293           ichir22=isign(1,itype(i))
5294          endif
5295          if (i.eq.3) then
5296           y(1)=0.0D0
5297           y(2)=0.0D0
5298           else
5299
5300         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5301 #ifdef OSF
5302           phii=phi(i)
5303 c          icrc=0
5304 c          call proc_proc(phii,icrc)
5305           if (icrc.eq.1) phii=150.0
5306 #else
5307           phii=phi(i)
5308 #endif
5309           y(1)=dcos(phii)
5310           y(2)=dsin(phii)
5311         else
5312           y(1)=0.0D0
5313           y(2)=0.0D0
5314         endif
5315         endif
5316         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5317 #ifdef OSF
5318           phii1=phi(i+1)
5319 c          icrc=0
5320 c          call proc_proc(phii1,icrc)
5321           if (icrc.eq.1) phii1=150.0
5322           phii1=pinorm(phii1)
5323           z(1)=cos(phii1)
5324 #else
5325           phii1=phi(i+1)
5326           z(1)=dcos(phii1)
5327 #endif
5328           z(2)=dsin(phii1)
5329         else
5330           z(1)=0.0D0
5331           z(2)=0.0D0
5332         endif
5333 C Calculate the "mean" value of theta from the part of the distribution
5334 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5335 C In following comments this theta will be referred to as t_c.
5336         thet_pred_mean=0.0d0
5337         do k=1,2
5338             athetk=athet(k,it,ichir1,ichir2)
5339             bthetk=bthet(k,it,ichir1,ichir2)
5340           if (it.eq.10) then
5341              athetk=athet(k,itype1,ichir11,ichir12)
5342              bthetk=bthet(k,itype2,ichir21,ichir22)
5343           endif
5344           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5345         enddo
5346 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5347         dthett=thet_pred_mean*ssd
5348         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5349 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5350 C Derivatives of the "mean" values in gamma1 and gamma2.
5351         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5352      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5353          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5354      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5355          if (it.eq.10) then
5356       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5357      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5358         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5359      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5360          endif
5361         if (theta(i).gt.pi-delta) then
5362           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5363      &         E_tc0)
5364           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5365           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5366           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5367      &        E_theta)
5368           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5369      &        E_tc)
5370         else if (theta(i).lt.delta) then
5371           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5372           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5373           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5374      &        E_theta)
5375           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5376           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5377      &        E_tc)
5378         else
5379           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5380      &        E_theta,E_tc)
5381         endif
5382         etheta=etheta+ethetai
5383 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5384 c     &      'ebend',i,ethetai,theta(i),itype(i)
5385 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5386 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5387         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5388         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5389         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5390 c 1215   continue
5391       enddo
5392       ethetacnstr=0.0d0
5393 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5394       do i=1,ntheta_constr
5395         itheta=itheta_constr(i)
5396         thetiii=theta(itheta)
5397         difi=pinorm(thetiii-theta_constr0(i))
5398         if (difi.gt.theta_drange(i)) then
5399           difi=difi-theta_drange(i)
5400           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5401           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5402      &    +for_thet_constr(i)*difi**3
5403         else if (difi.lt.-drange(i)) then
5404           difi=difi+drange(i)
5405           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5406           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5407      &    +for_thet_constr(i)*difi**3
5408         else
5409           difi=0.0
5410         endif
5411 C       if (energy_dec) then
5412 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5413 C     &    i,itheta,rad2deg*thetiii,
5414 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5415 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5416 C     &    gloc(itheta+nphi-2,icg)
5417 C        endif
5418       enddo
5419 C Ufff.... We've done all this!!!
5420       return
5421       end
5422 C---------------------------------------------------------------------------
5423       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5424      &     E_tc)
5425       implicit real*8 (a-h,o-z)
5426       include 'DIMENSIONS'
5427       include 'COMMON.LOCAL'
5428       include 'COMMON.IOUNITS'
5429       common /calcthet/ term1,term2,termm,diffak,ratak,
5430      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5431      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5432 C Calculate the contributions to both Gaussian lobes.
5433 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5434 C The "polynomial part" of the "standard deviation" of this part of
5435 C the distribution.
5436         sig=polthet(3,it)
5437         do j=2,0,-1
5438           sig=sig*thet_pred_mean+polthet(j,it)
5439         enddo
5440 C Derivative of the "interior part" of the "standard deviation of the"
5441 C gamma-dependent Gaussian lobe in t_c.
5442         sigtc=3*polthet(3,it)
5443         do j=2,1,-1
5444           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5445         enddo
5446         sigtc=sig*sigtc
5447 C Set the parameters of both Gaussian lobes of the distribution.
5448 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5449         fac=sig*sig+sigc0(it)
5450         sigcsq=fac+fac
5451         sigc=1.0D0/sigcsq
5452 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5453         sigsqtc=-4.0D0*sigcsq*sigtc
5454 c       print *,i,sig,sigtc,sigsqtc
5455 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5456         sigtc=-sigtc/(fac*fac)
5457 C Following variable is sigma(t_c)**(-2)
5458         sigcsq=sigcsq*sigcsq
5459         sig0i=sig0(it)
5460         sig0inv=1.0D0/sig0i**2
5461         delthec=thetai-thet_pred_mean
5462         delthe0=thetai-theta0i
5463         term1=-0.5D0*sigcsq*delthec*delthec
5464         term2=-0.5D0*sig0inv*delthe0*delthe0
5465 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5466 C NaNs in taking the logarithm. We extract the largest exponent which is added
5467 C to the energy (this being the log of the distribution) at the end of energy
5468 C term evaluation for this virtual-bond angle.
5469         if (term1.gt.term2) then
5470           termm=term1
5471           term2=dexp(term2-termm)
5472           term1=1.0d0
5473         else
5474           termm=term2
5475           term1=dexp(term1-termm)
5476           term2=1.0d0
5477         endif
5478 C The ratio between the gamma-independent and gamma-dependent lobes of
5479 C the distribution is a Gaussian function of thet_pred_mean too.
5480         diffak=gthet(2,it)-thet_pred_mean
5481         ratak=diffak/gthet(3,it)**2
5482         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5483 C Let's differentiate it in thet_pred_mean NOW.
5484         aktc=ak*ratak
5485 C Now put together the distribution terms to make complete distribution.
5486         termexp=term1+ak*term2
5487         termpre=sigc+ak*sig0i
5488 C Contribution of the bending energy from this theta is just the -log of
5489 C the sum of the contributions from the two lobes and the pre-exponential
5490 C factor. Simple enough, isn't it?
5491         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5492 C NOW the derivatives!!!
5493 C 6/6/97 Take into account the deformation.
5494         E_theta=(delthec*sigcsq*term1
5495      &       +ak*delthe0*sig0inv*term2)/termexp
5496         E_tc=((sigtc+aktc*sig0i)/termpre
5497      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5498      &       aktc*term2)/termexp)
5499       return
5500       end
5501 c-----------------------------------------------------------------------------
5502       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5503       implicit real*8 (a-h,o-z)
5504       include 'DIMENSIONS'
5505       include 'COMMON.LOCAL'
5506       include 'COMMON.IOUNITS'
5507       common /calcthet/ term1,term2,termm,diffak,ratak,
5508      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5509      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5510       delthec=thetai-thet_pred_mean
5511       delthe0=thetai-theta0i
5512 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5513       t3 = thetai-thet_pred_mean
5514       t6 = t3**2
5515       t9 = term1
5516       t12 = t3*sigcsq
5517       t14 = t12+t6*sigsqtc
5518       t16 = 1.0d0
5519       t21 = thetai-theta0i
5520       t23 = t21**2
5521       t26 = term2
5522       t27 = t21*t26
5523       t32 = termexp
5524       t40 = t32**2
5525       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5526      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5527      & *(-t12*t9-ak*sig0inv*t27)
5528       return
5529       end
5530 #else
5531 C--------------------------------------------------------------------------
5532       subroutine ebend(etheta)
5533 C
5534 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5535 C angles gamma and its derivatives in consecutive thetas and gammas.
5536 C ab initio-derived potentials from
5537 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5538 C
5539       implicit real*8 (a-h,o-z)
5540       include 'DIMENSIONS'
5541       include 'DIMENSIONS.ZSCOPT'
5542       include 'COMMON.LOCAL'
5543       include 'COMMON.GEO'
5544       include 'COMMON.INTERACT'
5545       include 'COMMON.DERIV'
5546       include 'COMMON.VAR'
5547       include 'COMMON.CHAIN'
5548       include 'COMMON.IOUNITS'
5549       include 'COMMON.NAMES'
5550       include 'COMMON.FFIELD'
5551       include 'COMMON.CONTROL'
5552       include 'COMMON.TORCNSTR'
5553       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5554      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5555      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5556      & sinph1ph2(maxdouble,maxdouble)
5557       logical lprn /.false./, lprn1 /.false./
5558       etheta=0.0D0
5559 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5560       do i=ithet_start,ithet_end
5561 C         if (i.eq.2) cycle
5562 C        if (itype(i-1).eq.ntyp1) cycle
5563         if (i.le.2) cycle
5564         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5565      &  .or.itype(i).eq.ntyp1) cycle
5566         if (iabs(itype(i+1)).eq.20) iblock=2
5567         if (iabs(itype(i+1)).ne.20) iblock=1
5568         dethetai=0.0d0
5569         dephii=0.0d0
5570         dephii1=0.0d0
5571         theti2=0.5d0*theta(i)
5572         ityp2=ithetyp((itype(i-1)))
5573         do k=1,nntheterm
5574           coskt(k)=dcos(k*theti2)
5575           sinkt(k)=dsin(k*theti2)
5576         enddo
5577         if (i.eq.3) then
5578           phii=0.0d0
5579           ityp1=nthetyp+1
5580           do k=1,nsingle
5581             cosph1(k)=0.0d0
5582             sinph1(k)=0.0d0
5583           enddo
5584         else
5585         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5586 #ifdef OSF
5587           phii=phi(i)
5588           if (phii.ne.phii) phii=150.0
5589 #else
5590           phii=phi(i)
5591 #endif
5592           ityp1=ithetyp((itype(i-2)))
5593           do k=1,nsingle
5594             cosph1(k)=dcos(k*phii)
5595             sinph1(k)=dsin(k*phii)
5596           enddo
5597         else
5598           phii=0.0d0
5599 c          ityp1=nthetyp+1
5600           do k=1,nsingle
5601             ityp1=ithetyp((itype(i-2)))
5602             cosph1(k)=0.0d0
5603             sinph1(k)=0.0d0
5604           enddo
5605         endif
5606         endif
5607         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5608 #ifdef OSF
5609           phii1=phi(i+1)
5610           if (phii1.ne.phii1) phii1=150.0
5611           phii1=pinorm(phii1)
5612 #else
5613           phii1=phi(i+1)
5614 #endif
5615           ityp3=ithetyp((itype(i)))
5616           do k=1,nsingle
5617             cosph2(k)=dcos(k*phii1)
5618             sinph2(k)=dsin(k*phii1)
5619           enddo
5620         else
5621           phii1=0.0d0
5622 c          ityp3=nthetyp+1
5623           ityp3=ithetyp((itype(i)))
5624           do k=1,nsingle
5625             cosph2(k)=0.0d0
5626             sinph2(k)=0.0d0
5627           enddo
5628         endif
5629 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5630 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5631 c        call flush(iout)
5632         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5633         do k=1,ndouble
5634           do l=1,k-1
5635             ccl=cosph1(l)*cosph2(k-l)
5636             ssl=sinph1(l)*sinph2(k-l)
5637             scl=sinph1(l)*cosph2(k-l)
5638             csl=cosph1(l)*sinph2(k-l)
5639             cosph1ph2(l,k)=ccl-ssl
5640             cosph1ph2(k,l)=ccl+ssl
5641             sinph1ph2(l,k)=scl+csl
5642             sinph1ph2(k,l)=scl-csl
5643           enddo
5644         enddo
5645         if (lprn) then
5646         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5647      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5648         write (iout,*) "coskt and sinkt"
5649         do k=1,nntheterm
5650           write (iout,*) k,coskt(k),sinkt(k)
5651         enddo
5652         endif
5653         do k=1,ntheterm
5654           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5655           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5656      &      *coskt(k)
5657           if (lprn)
5658      &    write (iout,*) "k",k,"
5659      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5660      &     " ethetai",ethetai
5661         enddo
5662         if (lprn) then
5663         write (iout,*) "cosph and sinph"
5664         do k=1,nsingle
5665           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5666         enddo
5667         write (iout,*) "cosph1ph2 and sinph2ph2"
5668         do k=2,ndouble
5669           do l=1,k-1
5670             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5671      &         sinph1ph2(l,k),sinph1ph2(k,l)
5672           enddo
5673         enddo
5674         write(iout,*) "ethetai",ethetai
5675         endif
5676         do m=1,ntheterm2
5677           do k=1,nsingle
5678             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5679      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5680      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5681      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5682             ethetai=ethetai+sinkt(m)*aux
5683             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5684             dephii=dephii+k*sinkt(m)*(
5685      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5686      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5687             dephii1=dephii1+k*sinkt(m)*(
5688      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5689      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5690             if (lprn)
5691      &      write (iout,*) "m",m," k",k," bbthet",
5692      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5693      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5694      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5695      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5696           enddo
5697         enddo
5698         if (lprn)
5699      &  write(iout,*) "ethetai",ethetai
5700         do m=1,ntheterm3
5701           do k=2,ndouble
5702             do l=1,k-1
5703               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5704      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5705      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5706      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5707               ethetai=ethetai+sinkt(m)*aux
5708               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5709               dephii=dephii+l*sinkt(m)*(
5710      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5711      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5712      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5713      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5714               dephii1=dephii1+(k-l)*sinkt(m)*(
5715      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5716      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5717      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5718      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5719               if (lprn) then
5720               write (iout,*) "m",m," k",k," l",l," ffthet",
5721      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5722      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5723      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5724      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5725      &            " ethetai",ethetai
5726               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5727      &            cosph1ph2(k,l)*sinkt(m),
5728      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5729               endif
5730             enddo
5731           enddo
5732         enddo
5733 10      continue
5734         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5735      &   i,theta(i)*rad2deg,phii*rad2deg,
5736      &   phii1*rad2deg,ethetai
5737         etheta=etheta+ethetai
5738         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5739         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5740 c        gloc(nphi+i-2,icg)=wang*dethetai
5741         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5742       enddo
5743       return
5744       end
5745 #endif
5746 #ifdef CRYST_SC
5747 c-----------------------------------------------------------------------------
5748       subroutine esc(escloc)
5749 C Calculate the local energy of a side chain and its derivatives in the
5750 C corresponding virtual-bond valence angles THETA and the spherical angles
5751 C ALPHA and OMEGA.
5752       implicit real*8 (a-h,o-z)
5753       include 'DIMENSIONS'
5754       include 'DIMENSIONS.ZSCOPT'
5755       include 'COMMON.GEO'
5756       include 'COMMON.LOCAL'
5757       include 'COMMON.VAR'
5758       include 'COMMON.INTERACT'
5759       include 'COMMON.DERIV'
5760       include 'COMMON.CHAIN'
5761       include 'COMMON.IOUNITS'
5762       include 'COMMON.NAMES'
5763       include 'COMMON.FFIELD'
5764       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5765      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5766       common /sccalc/ time11,time12,time112,theti,it,nlobit
5767       delta=0.02d0*pi
5768       escloc=0.0D0
5769 C      write (iout,*) 'ESC'
5770       do i=loc_start,loc_end
5771         it=itype(i)
5772         if (it.eq.ntyp1) cycle
5773         if (it.eq.10) goto 1
5774         nlobit=nlob(iabs(it))
5775 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5776 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5777         theti=theta(i+1)-pipol
5778         x(1)=dtan(theti)
5779         x(2)=alph(i)
5780         x(3)=omeg(i)
5781 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5782
5783         if (x(2).gt.pi-delta) then
5784           xtemp(1)=x(1)
5785           xtemp(2)=pi-delta
5786           xtemp(3)=x(3)
5787           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5788           xtemp(2)=pi
5789           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5790           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5791      &        escloci,dersc(2))
5792           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5793      &        ddersc0(1),dersc(1))
5794           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5795      &        ddersc0(3),dersc(3))
5796           xtemp(2)=pi-delta
5797           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5798           xtemp(2)=pi
5799           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5800           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5801      &            dersc0(2),esclocbi,dersc02)
5802           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5803      &            dersc12,dersc01)
5804           call splinthet(x(2),0.5d0*delta,ss,ssd)
5805           dersc0(1)=dersc01
5806           dersc0(2)=dersc02
5807           dersc0(3)=0.0d0
5808           do k=1,3
5809             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5810           enddo
5811           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5812           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5813      &             esclocbi,ss,ssd
5814           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5815 c         escloci=esclocbi
5816 c         write (iout,*) escloci
5817         else if (x(2).lt.delta) then
5818           xtemp(1)=x(1)
5819           xtemp(2)=delta
5820           xtemp(3)=x(3)
5821           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5822           xtemp(2)=0.0d0
5823           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5824           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5825      &        escloci,dersc(2))
5826           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5827      &        ddersc0(1),dersc(1))
5828           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5829      &        ddersc0(3),dersc(3))
5830           xtemp(2)=delta
5831           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5832           xtemp(2)=0.0d0
5833           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5834           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5835      &            dersc0(2),esclocbi,dersc02)
5836           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5837      &            dersc12,dersc01)
5838           dersc0(1)=dersc01
5839           dersc0(2)=dersc02
5840           dersc0(3)=0.0d0
5841           call splinthet(x(2),0.5d0*delta,ss,ssd)
5842           do k=1,3
5843             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5844           enddo
5845           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5846 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5847 c     &             esclocbi,ss,ssd
5848           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5849 C         write (iout,*) 'i=',i, escloci
5850         else
5851           call enesc(x,escloci,dersc,ddummy,.false.)
5852         endif
5853
5854         escloc=escloc+escloci
5855 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5856             write (iout,'(a6,i5,0pf7.3)')
5857      &     'escloc',i,escloci
5858
5859         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5860      &   wscloc*dersc(1)
5861         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5862         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5863     1   continue
5864       enddo
5865       return
5866       end
5867 C---------------------------------------------------------------------------
5868       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       include 'COMMON.GEO'
5872       include 'COMMON.LOCAL'
5873       include 'COMMON.IOUNITS'
5874       common /sccalc/ time11,time12,time112,theti,it,nlobit
5875       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5876       double precision contr(maxlob,-1:1)
5877       logical mixed
5878 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5879         escloc_i=0.0D0
5880         do j=1,3
5881           dersc(j)=0.0D0
5882           if (mixed) ddersc(j)=0.0d0
5883         enddo
5884         x3=x(3)
5885
5886 C Because of periodicity of the dependence of the SC energy in omega we have
5887 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5888 C To avoid underflows, first compute & store the exponents.
5889
5890         do iii=-1,1
5891
5892           x(3)=x3+iii*dwapi
5893
5894           do j=1,nlobit
5895             do k=1,3
5896               z(k)=x(k)-censc(k,j,it)
5897             enddo
5898             do k=1,3
5899               Axk=0.0D0
5900               do l=1,3
5901                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5902               enddo
5903               Ax(k,j,iii)=Axk
5904             enddo
5905             expfac=0.0D0
5906             do k=1,3
5907               expfac=expfac+Ax(k,j,iii)*z(k)
5908             enddo
5909             contr(j,iii)=expfac
5910           enddo ! j
5911
5912         enddo ! iii
5913
5914         x(3)=x3
5915 C As in the case of ebend, we want to avoid underflows in exponentiation and
5916 C subsequent NaNs and INFs in energy calculation.
5917 C Find the largest exponent
5918         emin=contr(1,-1)
5919         do iii=-1,1
5920           do j=1,nlobit
5921             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5922           enddo
5923         enddo
5924         emin=0.5D0*emin
5925 cd      print *,'it=',it,' emin=',emin
5926
5927 C Compute the contribution to SC energy and derivatives
5928         do iii=-1,1
5929
5930           do j=1,nlobit
5931             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5932 cd          print *,'j=',j,' expfac=',expfac
5933             escloc_i=escloc_i+expfac
5934             do k=1,3
5935               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5936             enddo
5937             if (mixed) then
5938               do k=1,3,2
5939                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5940      &            +gaussc(k,2,j,it))*expfac
5941               enddo
5942             endif
5943           enddo
5944
5945         enddo ! iii
5946
5947         dersc(1)=dersc(1)/cos(theti)**2
5948         ddersc(1)=ddersc(1)/cos(theti)**2
5949         ddersc(3)=ddersc(3)
5950
5951         escloci=-(dlog(escloc_i)-emin)
5952         do j=1,3
5953           dersc(j)=dersc(j)/escloc_i
5954         enddo
5955         if (mixed) then
5956           do j=1,3,2
5957             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5958           enddo
5959         endif
5960       return
5961       end
5962 C------------------------------------------------------------------------------
5963       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5964       implicit real*8 (a-h,o-z)
5965       include 'DIMENSIONS'
5966       include 'COMMON.GEO'
5967       include 'COMMON.LOCAL'
5968       include 'COMMON.IOUNITS'
5969       common /sccalc/ time11,time12,time112,theti,it,nlobit
5970       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5971       double precision contr(maxlob)
5972       logical mixed
5973
5974       escloc_i=0.0D0
5975
5976       do j=1,3
5977         dersc(j)=0.0D0
5978       enddo
5979
5980       do j=1,nlobit
5981         do k=1,2
5982           z(k)=x(k)-censc(k,j,it)
5983         enddo
5984         z(3)=dwapi
5985         do k=1,3
5986           Axk=0.0D0
5987           do l=1,3
5988             Axk=Axk+gaussc(l,k,j,it)*z(l)
5989           enddo
5990           Ax(k,j)=Axk
5991         enddo
5992         expfac=0.0D0
5993         do k=1,3
5994           expfac=expfac+Ax(k,j)*z(k)
5995         enddo
5996         contr(j)=expfac
5997       enddo ! j
5998
5999 C As in the case of ebend, we want to avoid underflows in exponentiation and
6000 C subsequent NaNs and INFs in energy calculation.
6001 C Find the largest exponent
6002       emin=contr(1)
6003       do j=1,nlobit
6004         if (emin.gt.contr(j)) emin=contr(j)
6005       enddo
6006       emin=0.5D0*emin
6007
6008 C Compute the contribution to SC energy and derivatives
6009
6010       dersc12=0.0d0
6011       do j=1,nlobit
6012         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6013         escloc_i=escloc_i+expfac
6014         do k=1,2
6015           dersc(k)=dersc(k)+Ax(k,j)*expfac
6016         enddo
6017         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6018      &            +gaussc(1,2,j,it))*expfac
6019         dersc(3)=0.0d0
6020       enddo
6021
6022       dersc(1)=dersc(1)/cos(theti)**2
6023       dersc12=dersc12/cos(theti)**2
6024       escloci=-(dlog(escloc_i)-emin)
6025       do j=1,2
6026         dersc(j)=dersc(j)/escloc_i
6027       enddo
6028       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6029       return
6030       end
6031 #else
6032 c----------------------------------------------------------------------------------
6033       subroutine esc(escloc)
6034 C Calculate the local energy of a side chain and its derivatives in the
6035 C corresponding virtual-bond valence angles THETA and the spherical angles
6036 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6037 C added by Urszula Kozlowska. 07/11/2007
6038 C
6039       implicit real*8 (a-h,o-z)
6040       include 'DIMENSIONS'
6041       include 'DIMENSIONS.ZSCOPT'
6042       include 'COMMON.GEO'
6043       include 'COMMON.LOCAL'
6044       include 'COMMON.VAR'
6045       include 'COMMON.SCROT'
6046       include 'COMMON.INTERACT'
6047       include 'COMMON.DERIV'
6048       include 'COMMON.CHAIN'
6049       include 'COMMON.IOUNITS'
6050       include 'COMMON.NAMES'
6051       include 'COMMON.FFIELD'
6052       include 'COMMON.CONTROL'
6053       include 'COMMON.VECTORS'
6054       double precision x_prime(3),y_prime(3),z_prime(3)
6055      &    , sumene,dsc_i,dp2_i,x(65),
6056      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6057      &    de_dxx,de_dyy,de_dzz,de_dt
6058       double precision s1_t,s1_6_t,s2_t,s2_6_t
6059       double precision
6060      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6061      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6062      & dt_dCi(3),dt_dCi1(3)
6063       common /sccalc/ time11,time12,time112,theti,it,nlobit
6064       delta=0.02d0*pi
6065       escloc=0.0D0
6066       do i=loc_start,loc_end
6067         if (itype(i).eq.ntyp1) cycle
6068         costtab(i+1) =dcos(theta(i+1))
6069         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6070         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6071         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6072         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6073         cosfac=dsqrt(cosfac2)
6074         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6075         sinfac=dsqrt(sinfac2)
6076         it=iabs(itype(i))
6077         if (it.eq.10) goto 1
6078 c
6079 C  Compute the axes of tghe local cartesian coordinates system; store in
6080 c   x_prime, y_prime and z_prime
6081 c
6082         do j=1,3
6083           x_prime(j) = 0.00
6084           y_prime(j) = 0.00
6085           z_prime(j) = 0.00
6086         enddo
6087 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6088 C     &   dc_norm(3,i+nres)
6089         do j = 1,3
6090           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6091           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6092         enddo
6093         do j = 1,3
6094           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6095         enddo
6096 c       write (2,*) "i",i
6097 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6098 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6099 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6100 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6101 c      & " xy",scalar(x_prime(1),y_prime(1)),
6102 c      & " xz",scalar(x_prime(1),z_prime(1)),
6103 c      & " yy",scalar(y_prime(1),y_prime(1)),
6104 c      & " yz",scalar(y_prime(1),z_prime(1)),
6105 c      & " zz",scalar(z_prime(1),z_prime(1))
6106 c
6107 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6108 C to local coordinate system. Store in xx, yy, zz.
6109 c
6110         xx=0.0d0
6111         yy=0.0d0
6112         zz=0.0d0
6113         do j = 1,3
6114           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6115           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6116           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6117         enddo
6118
6119         xxtab(i)=xx
6120         yytab(i)=yy
6121         zztab(i)=zz
6122 C
6123 C Compute the energy of the ith side cbain
6124 C
6125 c        write (2,*) "xx",xx," yy",yy," zz",zz
6126         it=iabs(itype(i))
6127         do j = 1,65
6128           x(j) = sc_parmin(j,it)
6129         enddo
6130 #ifdef CHECK_COORD
6131 Cc diagnostics - remove later
6132         xx1 = dcos(alph(2))
6133         yy1 = dsin(alph(2))*dcos(omeg(2))
6134         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6135         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6136      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6137      &    xx1,yy1,zz1
6138 C,"  --- ", xx_w,yy_w,zz_w
6139 c end diagnostics
6140 #endif
6141         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6142      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6143      &   + x(10)*yy*zz
6144         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6145      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6146      & + x(20)*yy*zz
6147         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6148      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6149      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6150      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6151      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6152      &  +x(40)*xx*yy*zz
6153         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6154      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6155      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6156      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6157      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6158      &  +x(60)*xx*yy*zz
6159         dsc_i   = 0.743d0+x(61)
6160         dp2_i   = 1.9d0+x(62)
6161         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6162      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6163         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6164      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6165         s1=(1+x(63))/(0.1d0 + dscp1)
6166         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6167         s2=(1+x(65))/(0.1d0 + dscp2)
6168         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6169         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6170      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6171 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6172 c     &   sumene4,
6173 c     &   dscp1,dscp2,sumene
6174 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6175         escloc = escloc + sumene
6176 c        write (2,*) "escloc",escloc
6177 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6178 c     &  zz,xx,yy
6179         if (.not. calc_grad) goto 1
6180 #ifdef DEBUG
6181 C
6182 C This section to check the numerical derivatives of the energy of ith side
6183 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6184 C #define DEBUG in the code to turn it on.
6185 C
6186         write (2,*) "sumene               =",sumene
6187         aincr=1.0d-7
6188         xxsave=xx
6189         xx=xx+aincr
6190         write (2,*) xx,yy,zz
6191         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6192         de_dxx_num=(sumenep-sumene)/aincr
6193         xx=xxsave
6194         write (2,*) "xx+ sumene from enesc=",sumenep
6195         yysave=yy
6196         yy=yy+aincr
6197         write (2,*) xx,yy,zz
6198         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6199         de_dyy_num=(sumenep-sumene)/aincr
6200         yy=yysave
6201         write (2,*) "yy+ sumene from enesc=",sumenep
6202         zzsave=zz
6203         zz=zz+aincr
6204         write (2,*) xx,yy,zz
6205         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6206         de_dzz_num=(sumenep-sumene)/aincr
6207         zz=zzsave
6208         write (2,*) "zz+ sumene from enesc=",sumenep
6209         costsave=cost2tab(i+1)
6210         sintsave=sint2tab(i+1)
6211         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6212         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6213         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6214         de_dt_num=(sumenep-sumene)/aincr
6215         write (2,*) " t+ sumene from enesc=",sumenep
6216         cost2tab(i+1)=costsave
6217         sint2tab(i+1)=sintsave
6218 C End of diagnostics section.
6219 #endif
6220 C
6221 C Compute the gradient of esc
6222 C
6223         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6224         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6225         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6226         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6227         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6228         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6229         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6230         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6231         pom1=(sumene3*sint2tab(i+1)+sumene1)
6232      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6233         pom2=(sumene4*cost2tab(i+1)+sumene2)
6234      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6235         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6236         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6237      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6238      &  +x(40)*yy*zz
6239         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6240         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6241      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6242      &  +x(60)*yy*zz
6243         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6244      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6245      &        +(pom1+pom2)*pom_dx
6246 #ifdef DEBUG
6247         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6248 #endif
6249 C
6250         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6251         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6252      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6253      &  +x(40)*xx*zz
6254         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6255         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6256      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6257      &  +x(59)*zz**2 +x(60)*xx*zz
6258         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6259      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6260      &        +(pom1-pom2)*pom_dy
6261 #ifdef DEBUG
6262         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6263 #endif
6264 C
6265         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6266      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6267      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6268      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6269      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6270      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6271      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6272      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6273 #ifdef DEBUG
6274         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6275 #endif
6276 C
6277         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6278      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6279      &  +pom1*pom_dt1+pom2*pom_dt2
6280 #ifdef DEBUG
6281         write(2,*), "de_dt = ", de_dt,de_dt_num
6282 #endif
6283 c
6284 C
6285        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6286        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6287        cosfac2xx=cosfac2*xx
6288        sinfac2yy=sinfac2*yy
6289        do k = 1,3
6290          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6291      &      vbld_inv(i+1)
6292          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6293      &      vbld_inv(i)
6294          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6295          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6296 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6297 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6298 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6299 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6300          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6301          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6302          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6303          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6304          dZZ_Ci1(k)=0.0d0
6305          dZZ_Ci(k)=0.0d0
6306          do j=1,3
6307            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6308      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6309            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6310      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6311          enddo
6312
6313          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6314          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6315          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6316 c
6317          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6318          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6319        enddo
6320
6321        do k=1,3
6322          dXX_Ctab(k,i)=dXX_Ci(k)
6323          dXX_C1tab(k,i)=dXX_Ci1(k)
6324          dYY_Ctab(k,i)=dYY_Ci(k)
6325          dYY_C1tab(k,i)=dYY_Ci1(k)
6326          dZZ_Ctab(k,i)=dZZ_Ci(k)
6327          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6328          dXX_XYZtab(k,i)=dXX_XYZ(k)
6329          dYY_XYZtab(k,i)=dYY_XYZ(k)
6330          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6331        enddo
6332
6333        do k = 1,3
6334 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6335 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6336 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6337 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6338 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6339 c     &    dt_dci(k)
6340 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6341 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6342          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6343      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6344          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6345      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6346          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6347      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6348        enddo
6349 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6350 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6351
6352 C to check gradient call subroutine check_grad
6353
6354     1 continue
6355       enddo
6356       return
6357       end
6358 #endif
6359 c------------------------------------------------------------------------------
6360       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6361 C
6362 C This procedure calculates two-body contact function g(rij) and its derivative:
6363 C
6364 C           eps0ij                                     !       x < -1
6365 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6366 C            0                                         !       x > 1
6367 C
6368 C where x=(rij-r0ij)/delta
6369 C
6370 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6371 C
6372       implicit none
6373       double precision rij,r0ij,eps0ij,fcont,fprimcont
6374       double precision x,x2,x4,delta
6375 c     delta=0.02D0*r0ij
6376 c      delta=0.2D0*r0ij
6377       x=(rij-r0ij)/delta
6378       if (x.lt.-1.0D0) then
6379         fcont=eps0ij
6380         fprimcont=0.0D0
6381       else if (x.le.1.0D0) then
6382         x2=x*x
6383         x4=x2*x2
6384         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6385         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6386       else
6387         fcont=0.0D0
6388         fprimcont=0.0D0
6389       endif
6390       return
6391       end
6392 c------------------------------------------------------------------------------
6393       subroutine splinthet(theti,delta,ss,ssder)
6394       implicit real*8 (a-h,o-z)
6395       include 'DIMENSIONS'
6396       include 'DIMENSIONS.ZSCOPT'
6397       include 'COMMON.VAR'
6398       include 'COMMON.GEO'
6399       thetup=pi-delta
6400       thetlow=delta
6401       if (theti.gt.pipol) then
6402         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6403       else
6404         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6405         ssder=-ssder
6406       endif
6407       return
6408       end
6409 c------------------------------------------------------------------------------
6410       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6411       implicit none
6412       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6413       double precision ksi,ksi2,ksi3,a1,a2,a3
6414       a1=fprim0*delta/(f1-f0)
6415       a2=3.0d0-2.0d0*a1
6416       a3=a1-2.0d0
6417       ksi=(x-x0)/delta
6418       ksi2=ksi*ksi
6419       ksi3=ksi2*ksi
6420       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6421       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6422       return
6423       end
6424 c------------------------------------------------------------------------------
6425       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6426       implicit none
6427       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6428       double precision ksi,ksi2,ksi3,a1,a2,a3
6429       ksi=(x-x0)/delta
6430       ksi2=ksi*ksi
6431       ksi3=ksi2*ksi
6432       a1=fprim0x*delta
6433       a2=3*(f1x-f0x)-2*fprim0x*delta
6434       a3=fprim0x*delta-2*(f1x-f0x)
6435       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6436       return
6437       end
6438 C-----------------------------------------------------------------------------
6439 #ifdef CRYST_TOR
6440 C-----------------------------------------------------------------------------
6441       subroutine etor(etors,fact)
6442       implicit real*8 (a-h,o-z)
6443       include 'DIMENSIONS'
6444       include 'DIMENSIONS.ZSCOPT'
6445       include 'COMMON.VAR'
6446       include 'COMMON.GEO'
6447       include 'COMMON.LOCAL'
6448       include 'COMMON.TORSION'
6449       include 'COMMON.INTERACT'
6450       include 'COMMON.DERIV'
6451       include 'COMMON.CHAIN'
6452       include 'COMMON.NAMES'
6453       include 'COMMON.IOUNITS'
6454       include 'COMMON.FFIELD'
6455       include 'COMMON.TORCNSTR'
6456       logical lprn
6457 C Set lprn=.true. for debugging
6458       lprn=.false.
6459 c      lprn=.true.
6460       etors=0.0D0
6461       do i=iphi_start,iphi_end
6462         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6463      &      .or. itype(i).eq.ntyp1) cycle
6464         itori=itortyp(itype(i-2))
6465         itori1=itortyp(itype(i-1))
6466         phii=phi(i)
6467         gloci=0.0D0
6468 C Proline-Proline pair is a special case...
6469         if (itori.eq.3 .and. itori1.eq.3) then
6470           if (phii.gt.-dwapi3) then
6471             cosphi=dcos(3*phii)
6472             fac=1.0D0/(1.0D0-cosphi)
6473             etorsi=v1(1,3,3)*fac
6474             etorsi=etorsi+etorsi
6475             etors=etors+etorsi-v1(1,3,3)
6476             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6477           endif
6478           do j=1,3
6479             v1ij=v1(j+1,itori,itori1)
6480             v2ij=v2(j+1,itori,itori1)
6481             cosphi=dcos(j*phii)
6482             sinphi=dsin(j*phii)
6483             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6484             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6485           enddo
6486         else
6487           do j=1,nterm_old
6488             v1ij=v1(j,itori,itori1)
6489             v2ij=v2(j,itori,itori1)
6490             cosphi=dcos(j*phii)
6491             sinphi=dsin(j*phii)
6492             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6493             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6494           enddo
6495         endif
6496         if (lprn)
6497      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6498      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6499      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6500         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6501 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6502       enddo
6503       return
6504       end
6505 c------------------------------------------------------------------------------
6506 #else
6507       subroutine etor(etors,fact)
6508       implicit real*8 (a-h,o-z)
6509       include 'DIMENSIONS'
6510       include 'DIMENSIONS.ZSCOPT'
6511       include 'COMMON.VAR'
6512       include 'COMMON.GEO'
6513       include 'COMMON.LOCAL'
6514       include 'COMMON.TORSION'
6515       include 'COMMON.INTERACT'
6516       include 'COMMON.DERIV'
6517       include 'COMMON.CHAIN'
6518       include 'COMMON.NAMES'
6519       include 'COMMON.IOUNITS'
6520       include 'COMMON.FFIELD'
6521       include 'COMMON.TORCNSTR'
6522       logical lprn
6523 C Set lprn=.true. for debugging
6524       lprn=.false.
6525 c      lprn=.true.
6526       etors=0.0D0
6527       do i=iphi_start,iphi_end
6528         if (i.le.2) cycle
6529         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6530      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6531 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6532 C     &       .or. itype(i).eq.ntyp1) cycle
6533         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6534          if (iabs(itype(i)).eq.20) then
6535          iblock=2
6536          else
6537          iblock=1
6538          endif
6539         itori=itortyp(itype(i-2))
6540         itori1=itortyp(itype(i-1))
6541         phii=phi(i)
6542         gloci=0.0D0
6543 C Regular cosine and sine terms
6544         do j=1,nterm(itori,itori1,iblock)
6545           v1ij=v1(j,itori,itori1,iblock)
6546           v2ij=v2(j,itori,itori1,iblock)
6547           cosphi=dcos(j*phii)
6548           sinphi=dsin(j*phii)
6549           etors=etors+v1ij*cosphi+v2ij*sinphi
6550           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6551         enddo
6552 C Lorentz terms
6553 C                         v1
6554 C  E = SUM ----------------------------------- - v1
6555 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6556 C
6557         cosphi=dcos(0.5d0*phii)
6558         sinphi=dsin(0.5d0*phii)
6559         do j=1,nlor(itori,itori1,iblock)
6560           vl1ij=vlor1(j,itori,itori1)
6561           vl2ij=vlor2(j,itori,itori1)
6562           vl3ij=vlor3(j,itori,itori1)
6563           pom=vl2ij*cosphi+vl3ij*sinphi
6564           pom1=1.0d0/(pom*pom+1.0d0)
6565           etors=etors+vl1ij*pom1
6566 c          if (energy_dec) etors_ii=etors_ii+
6567 c     &                vl1ij*pom1
6568           pom=-pom*pom1*pom1
6569           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6570         enddo
6571 C Subtract the constant term
6572         etors=etors-v0(itori,itori1,iblock)
6573         if (lprn)
6574      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6575      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6576      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6577         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6578 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6579  1215   continue
6580       enddo
6581       return
6582       end
6583 c----------------------------------------------------------------------------
6584       subroutine etor_d(etors_d,fact2)
6585 C 6/23/01 Compute double torsional energy
6586       implicit real*8 (a-h,o-z)
6587       include 'DIMENSIONS'
6588       include 'DIMENSIONS.ZSCOPT'
6589       include 'COMMON.VAR'
6590       include 'COMMON.GEO'
6591       include 'COMMON.LOCAL'
6592       include 'COMMON.TORSION'
6593       include 'COMMON.INTERACT'
6594       include 'COMMON.DERIV'
6595       include 'COMMON.CHAIN'
6596       include 'COMMON.NAMES'
6597       include 'COMMON.IOUNITS'
6598       include 'COMMON.FFIELD'
6599       include 'COMMON.TORCNSTR'
6600       logical lprn
6601 C Set lprn=.true. for debugging
6602       lprn=.false.
6603 c     lprn=.true.
6604       etors_d=0.0D0
6605       do i=iphi_start,iphi_end-1
6606         if (i.le.3) cycle
6607 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6608 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6609          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6610      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6611      &  (itype(i+1).eq.ntyp1)) cycle
6612         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6613      &     goto 1215
6614         itori=itortyp(itype(i-2))
6615         itori1=itortyp(itype(i-1))
6616         itori2=itortyp(itype(i))
6617         phii=phi(i)
6618         phii1=phi(i+1)
6619         gloci1=0.0D0
6620         gloci2=0.0D0
6621         iblock=1
6622         if (iabs(itype(i+1)).eq.20) iblock=2
6623 C Regular cosine and sine terms
6624         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6625           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6626           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6627           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6628           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6629           cosphi1=dcos(j*phii)
6630           sinphi1=dsin(j*phii)
6631           cosphi2=dcos(j*phii1)
6632           sinphi2=dsin(j*phii1)
6633           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6634      &     v2cij*cosphi2+v2sij*sinphi2
6635           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6636           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6637         enddo
6638         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6639           do l=1,k-1
6640             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6641             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6642             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6643             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6644             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6645             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6646             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6647             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6648             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6649      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6650             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6651      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6652             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6653      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6654           enddo
6655         enddo
6656         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6657         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6658  1215   continue
6659       enddo
6660       return
6661       end
6662 #endif
6663 c---------------------------------------------------------------------------
6664 C The rigorous attempt to derive energy function
6665       subroutine etor_kcc(etors,fact)
6666       implicit real*8 (a-h,o-z)
6667       include 'DIMENSIONS'
6668       include 'DIMENSIONS.ZSCOPT'
6669       include 'COMMON.VAR'
6670       include 'COMMON.GEO'
6671       include 'COMMON.LOCAL'
6672       include 'COMMON.TORSION'
6673       include 'COMMON.INTERACT'
6674       include 'COMMON.DERIV'
6675       include 'COMMON.CHAIN'
6676       include 'COMMON.NAMES'
6677       include 'COMMON.IOUNITS'
6678       include 'COMMON.FFIELD'
6679       include 'COMMON.TORCNSTR'
6680       include 'COMMON.CONTROL'
6681       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6682       logical lprn
6683 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6684 C Set lprn=.true. for debugging
6685       lprn=energy_dec
6686 c     lprn=.true.
6687 C      print *,"wchodze kcc"
6688       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6689       etors=0.0D0
6690       do i=iphi_start,iphi_end
6691 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6692 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6693 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6694 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6695         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6696      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6697         itori=itortyp(itype(i-2))
6698         itori1=itortyp(itype(i-1))
6699         phii=phi(i)
6700         glocig=0.0D0
6701         glocit1=0.0d0
6702         glocit2=0.0d0
6703 C to avoid multiple devision by 2
6704 c        theti22=0.5d0*theta(i)
6705 C theta 12 is the theta_1 /2
6706 C theta 22 is theta_2 /2
6707 c        theti12=0.5d0*theta(i-1)
6708 C and appropriate sinus function
6709         sinthet1=dsin(theta(i-1))
6710         sinthet2=dsin(theta(i))
6711         costhet1=dcos(theta(i-1))
6712         costhet2=dcos(theta(i))
6713 C to speed up lets store its mutliplication
6714         sint1t2=sinthet2*sinthet1
6715         sint1t2n=1.0d0
6716 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6717 C +d_n*sin(n*gamma)) *
6718 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6719 C we have two sum 1) Non-Chebyshev which is with n and gamma
6720         nval=nterm_kcc_Tb(itori,itori1)
6721         c1(0)=0.0d0
6722         c2(0)=0.0d0
6723         c1(1)=1.0d0
6724         c2(1)=1.0d0
6725         do j=2,nval
6726           c1(j)=c1(j-1)*costhet1
6727           c2(j)=c2(j-1)*costhet2
6728         enddo
6729         etori=0.0d0
6730         do j=1,nterm_kcc(itori,itori1)
6731           cosphi=dcos(j*phii)
6732           sinphi=dsin(j*phii)
6733           sint1t2n1=sint1t2n
6734           sint1t2n=sint1t2n*sint1t2
6735           sumvalc=0.0d0
6736           gradvalct1=0.0d0
6737           gradvalct2=0.0d0
6738           do k=1,nval
6739             do l=1,nval
6740               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6741               gradvalct1=gradvalct1+
6742      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6743               gradvalct2=gradvalct2+
6744      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6745             enddo
6746           enddo
6747           gradvalct1=-gradvalct1*sinthet1
6748           gradvalct2=-gradvalct2*sinthet2
6749           sumvals=0.0d0
6750           gradvalst1=0.0d0
6751           gradvalst2=0.0d0
6752           do k=1,nval
6753             do l=1,nval
6754               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6755               gradvalst1=gradvalst1+
6756      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6757               gradvalst2=gradvalst2+
6758      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6759             enddo
6760           enddo
6761           gradvalst1=-gradvalst1*sinthet1
6762           gradvalst2=-gradvalst2*sinthet2
6763           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6764 C glocig is the gradient local i site in gamma
6765           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6766 C now gradient over theta_1
6767           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6768      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6769           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6770      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6771         enddo ! j
6772         etors=etors+etori
6773 C derivative over gamma
6774         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6775 C derivative over theta1
6776         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6777 C now derivative over theta2
6778         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6779         if (lprn) then
6780           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6781      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6782           write (iout,*) "c1",(c1(k),k=0,nval),
6783      &    " c2",(c2(k),k=0,nval)
6784           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6785         endif
6786       enddo
6787       return
6788       end
6789 c---------------------------------------------------------------------------------------------
6790       subroutine etor_constr(edihcnstr)
6791       implicit real*8 (a-h,o-z)
6792       include 'DIMENSIONS'
6793       include 'DIMENSIONS.ZSCOPT'
6794       include 'COMMON.VAR'
6795       include 'COMMON.GEO'
6796       include 'COMMON.LOCAL'
6797       include 'COMMON.TORSION'
6798       include 'COMMON.INTERACT'
6799       include 'COMMON.DERIV'
6800       include 'COMMON.CHAIN'
6801       include 'COMMON.NAMES'
6802       include 'COMMON.IOUNITS'
6803       include 'COMMON.FFIELD'
6804       include 'COMMON.TORCNSTR'
6805       include 'COMMON.CONTROL'
6806 ! 6/20/98 - dihedral angle constraints
6807       edihcnstr=0.0d0
6808 c      do i=1,ndih_constr
6809 c      write (iout,*) "idihconstr_start",idihconstr_start,
6810 c     &  " idihconstr_end",idihconstr_end
6811
6812       if (raw_psipred) then
6813         do i=idihconstr_start,idihconstr_end
6814           itori=idih_constr(i)
6815           phii=phi(itori)
6816           gaudih_i=vpsipred(1,i)
6817           gauder_i=0.0d0
6818           do j=1,2
6819             s = sdihed(j,i)
6820             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6821             dexpcos_i=dexp(-cos_i*cos_i)
6822             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6823             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6824      &            *cos_i*dexpcos_i/s**2
6825           enddo
6826           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6827           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6828           if (energy_dec)
6829      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6830      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6831      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6832      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6833      &     -wdihc*dlog(gaudih_i)
6834         enddo
6835       else
6836
6837       do i=idihconstr_start,idihconstr_end
6838         itori=idih_constr(i)
6839         phii=phi(itori)
6840         difi=pinorm(phii-phi0(i))
6841         if (difi.gt.drange(i)) then
6842           difi=difi-drange(i)
6843           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6844           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6845         else if (difi.lt.-drange(i)) then
6846           difi=difi+drange(i)
6847           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6848           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6849         else
6850           difi=0.0
6851         endif
6852       enddo
6853
6854       endif
6855
6856 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6857       return
6858       end
6859 c----------------------------------------------------------------------------
6860 C The rigorous attempt to derive energy function
6861       subroutine ebend_kcc(etheta)
6862
6863       implicit real*8 (a-h,o-z)
6864       include 'DIMENSIONS'
6865       include 'DIMENSIONS.ZSCOPT'
6866       include 'COMMON.VAR'
6867       include 'COMMON.GEO'
6868       include 'COMMON.LOCAL'
6869       include 'COMMON.TORSION'
6870       include 'COMMON.INTERACT'
6871       include 'COMMON.DERIV'
6872       include 'COMMON.CHAIN'
6873       include 'COMMON.NAMES'
6874       include 'COMMON.IOUNITS'
6875       include 'COMMON.FFIELD'
6876       include 'COMMON.TORCNSTR'
6877       include 'COMMON.CONTROL'
6878       logical lprn
6879       double precision thybt1(maxang_kcc)
6880 C Set lprn=.true. for debugging
6881       lprn=energy_dec
6882 c     lprn=.true.
6883 C      print *,"wchodze kcc"
6884       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6885       etheta=0.0D0
6886       do i=ithet_start,ithet_end
6887 c        print *,i,itype(i-1),itype(i),itype(i-2)
6888         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6889      &  .or.itype(i).eq.ntyp1) cycle
6890         iti=iabs(itortyp(itype(i-1)))
6891         sinthet=dsin(theta(i))
6892         costhet=dcos(theta(i))
6893         do j=1,nbend_kcc_Tb(iti)
6894           thybt1(j)=v1bend_chyb(j,iti)
6895         enddo
6896         sumth1thyb=v1bend_chyb(0,iti)+
6897      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6898         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6899      &    sumth1thyb
6900         ihelp=nbend_kcc_Tb(iti)-1
6901         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6902         etheta=etheta+sumth1thyb
6903 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6904         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6905       enddo
6906       return
6907       end
6908 c-------------------------------------------------------------------------------------
6909       subroutine etheta_constr(ethetacnstr)
6910
6911       implicit real*8 (a-h,o-z)
6912       include 'DIMENSIONS'
6913       include 'DIMENSIONS.ZSCOPT'
6914       include 'COMMON.VAR'
6915       include 'COMMON.GEO'
6916       include 'COMMON.LOCAL'
6917       include 'COMMON.TORSION'
6918       include 'COMMON.INTERACT'
6919       include 'COMMON.DERIV'
6920       include 'COMMON.CHAIN'
6921       include 'COMMON.NAMES'
6922       include 'COMMON.IOUNITS'
6923       include 'COMMON.FFIELD'
6924       include 'COMMON.TORCNSTR'
6925       include 'COMMON.CONTROL'
6926       ethetacnstr=0.0d0
6927 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6928       do i=ithetaconstr_start,ithetaconstr_end
6929         itheta=itheta_constr(i)
6930         thetiii=theta(itheta)
6931         difi=pinorm(thetiii-theta_constr0(i))
6932         if (difi.gt.theta_drange(i)) then
6933           difi=difi-theta_drange(i)
6934           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6935           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6936      &    +for_thet_constr(i)*difi**3
6937         else if (difi.lt.-drange(i)) then
6938           difi=difi+drange(i)
6939           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6940           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6941      &    +for_thet_constr(i)*difi**3
6942         else
6943           difi=0.0
6944         endif
6945        if (energy_dec) then
6946         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6947      &    i,itheta,rad2deg*thetiii,
6948      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6949      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6950      &    gloc(itheta+nphi-2,icg)
6951         endif
6952       enddo
6953       return
6954       end
6955 c------------------------------------------------------------------------------
6956 c------------------------------------------------------------------------------
6957       subroutine eback_sc_corr(esccor)
6958 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6959 c        conformational states; temporarily implemented as differences
6960 c        between UNRES torsional potentials (dependent on three types of
6961 c        residues) and the torsional potentials dependent on all 20 types
6962 c        of residues computed from AM1 energy surfaces of terminally-blocked
6963 c        amino-acid residues.
6964       implicit real*8 (a-h,o-z)
6965       include 'DIMENSIONS'
6966       include 'DIMENSIONS.ZSCOPT'
6967       include 'COMMON.VAR'
6968       include 'COMMON.GEO'
6969       include 'COMMON.LOCAL'
6970       include 'COMMON.TORSION'
6971       include 'COMMON.SCCOR'
6972       include 'COMMON.INTERACT'
6973       include 'COMMON.DERIV'
6974       include 'COMMON.CHAIN'
6975       include 'COMMON.NAMES'
6976       include 'COMMON.IOUNITS'
6977       include 'COMMON.FFIELD'
6978       include 'COMMON.CONTROL'
6979       logical lprn
6980 C Set lprn=.true. for debugging
6981       lprn=.false.
6982 c      lprn=.true.
6983 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6984       esccor=0.0D0
6985       do i=itau_start,itau_end
6986         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6987         esccor_ii=0.0D0
6988         isccori=isccortyp(itype(i-2))
6989         isccori1=isccortyp(itype(i-1))
6990         phii=phi(i)
6991         do intertyp=1,3 !intertyp
6992 cc Added 09 May 2012 (Adasko)
6993 cc  Intertyp means interaction type of backbone mainchain correlation:
6994 c   1 = SC...Ca...Ca...Ca
6995 c   2 = Ca...Ca...Ca...SC
6996 c   3 = SC...Ca...Ca...SCi
6997         gloci=0.0D0
6998         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6999      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7000      &      (itype(i-1).eq.ntyp1)))
7001      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7002      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7003      &     .or.(itype(i).eq.ntyp1)))
7004      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7005      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7006      &      (itype(i-3).eq.ntyp1)))) cycle
7007         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7008         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7009      & cycle
7010        do j=1,nterm_sccor(isccori,isccori1)
7011           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7012           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7013           cosphi=dcos(j*tauangle(intertyp,i))
7014           sinphi=dsin(j*tauangle(intertyp,i))
7015            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7016            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7017          enddo
7018 C      write (iout,*)"EBACK_SC_COR",esccor,i
7019 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7020 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7021 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7022         if (lprn)
7023      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7024      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7025      &  (v1sccor(j,1,itori,itori1),j=1,6)
7026      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7027 c        gsccor_loc(i-3)=gloci
7028        enddo !intertyp
7029       enddo
7030       return
7031       end
7032 #ifdef FOURBODY
7033 c------------------------------------------------------------------------------
7034       subroutine multibody(ecorr)
7035 C This subroutine calculates multi-body contributions to energy following
7036 C the idea of Skolnick et al. If side chains I and J make a contact and
7037 C at the same time side chains I+1 and J+1 make a contact, an extra
7038 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7039       implicit real*8 (a-h,o-z)
7040       include 'DIMENSIONS'
7041       include 'COMMON.IOUNITS'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       include 'COMMON.CONTMAT'
7046       include 'COMMON.CORRMAT'
7047       double precision gx(3),gx1(3)
7048       logical lprn
7049
7050 C Set lprn=.true. for debugging
7051       lprn=.false.
7052
7053       if (lprn) then
7054         write (iout,'(a)') 'Contact function values:'
7055         do i=nnt,nct-2
7056           write (iout,'(i2,20(1x,i2,f10.5))')
7057      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7058         enddo
7059       endif
7060       ecorr=0.0D0
7061       do i=nnt,nct
7062         do j=1,3
7063           gradcorr(j,i)=0.0D0
7064           gradxorr(j,i)=0.0D0
7065         enddo
7066       enddo
7067       do i=nnt,nct-2
7068
7069         DO ISHIFT = 3,4
7070
7071         i1=i+ishift
7072         num_conti=num_cont(i)
7073         num_conti1=num_cont(i1)
7074         do jj=1,num_conti
7075           j=jcont(jj,i)
7076           do kk=1,num_conti1
7077             j1=jcont(kk,i1)
7078             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7079 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7080 cd   &                   ' ishift=',ishift
7081 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7082 C The system gains extra energy.
7083               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7084             endif   ! j1==j+-ishift
7085           enddo     ! kk
7086         enddo       ! jj
7087
7088         ENDDO ! ISHIFT
7089
7090       enddo         ! i
7091       return
7092       end
7093 c------------------------------------------------------------------------------
7094       double precision function esccorr(i,j,k,l,jj,kk)
7095       implicit real*8 (a-h,o-z)
7096       include 'DIMENSIONS'
7097       include 'COMMON.IOUNITS'
7098       include 'COMMON.DERIV'
7099       include 'COMMON.INTERACT'
7100       include 'COMMON.CONTACTS'
7101       include 'COMMON.CONTMAT'
7102       include 'COMMON.CORRMAT'
7103       double precision gx(3),gx1(3)
7104       logical lprn
7105       lprn=.false.
7106       eij=facont(jj,i)
7107       ekl=facont(kk,k)
7108 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7109 C Calculate the multi-body contribution to energy.
7110 C Calculate multi-body contributions to the gradient.
7111 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7112 cd   & k,l,(gacont(m,kk,k),m=1,3)
7113       do m=1,3
7114         gx(m) =ekl*gacont(m,jj,i)
7115         gx1(m)=eij*gacont(m,kk,k)
7116         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7117         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7118         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7119         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7120       enddo
7121       do m=i,j-1
7122         do ll=1,3
7123           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7124         enddo
7125       enddo
7126       do m=k,l-1
7127         do ll=1,3
7128           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7129         enddo
7130       enddo
7131       esccorr=-eij*ekl
7132       return
7133       end
7134 c------------------------------------------------------------------------------
7135       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7136 C This subroutine calculates multi-body contributions to hydrogen-bonding
7137       implicit real*8 (a-h,o-z)
7138       include 'DIMENSIONS'
7139       include 'DIMENSIONS.ZSCOPT'
7140       include 'COMMON.IOUNITS'
7141       include 'COMMON.FFIELD'
7142       include 'COMMON.DERIV'
7143       include 'COMMON.INTERACT'
7144       include 'COMMON.CONTACTS'
7145       include 'COMMON.CONTMAT'
7146       include 'COMMON.CORRMAT'
7147       double precision gx(3),gx1(3)
7148       logical lprn,ldone
7149
7150 C Set lprn=.true. for debugging
7151       lprn=.false.
7152       if (lprn) then
7153         write (iout,'(a)') 'Contact function values:'
7154         do i=nnt,nct-2
7155           write (iout,'(2i3,50(1x,i2,f5.2))')
7156      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7157      &    j=1,num_cont_hb(i))
7158         enddo
7159       endif
7160       ecorr=0.0D0
7161 C Remove the loop below after debugging !!!
7162       do i=nnt,nct
7163         do j=1,3
7164           gradcorr(j,i)=0.0D0
7165           gradxorr(j,i)=0.0D0
7166         enddo
7167       enddo
7168 C Calculate the local-electrostatic correlation terms
7169       do i=iatel_s,iatel_e+1
7170         i1=i+1
7171         num_conti=num_cont_hb(i)
7172         num_conti1=num_cont_hb(i+1)
7173         do jj=1,num_conti
7174           j=jcont_hb(jj,i)
7175           do kk=1,num_conti1
7176             j1=jcont_hb(kk,i1)
7177 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7178 c     &         ' jj=',jj,' kk=',kk
7179             if (j1.eq.j+1 .or. j1.eq.j-1) then
7180 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7181 C The system gains extra energy.
7182               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7183               n_corr=n_corr+1
7184             else if (j1.eq.j) then
7185 C Contacts I-J and I-(J+1) occur simultaneously.
7186 C The system loses extra energy.
7187 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7188             endif
7189           enddo ! kk
7190           do kk=1,num_conti
7191             j1=jcont_hb(kk,i)
7192 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7193 c    &         ' jj=',jj,' kk=',kk
7194             if (j1.eq.j+1) then
7195 C Contacts I-J and (I+1)-J occur simultaneously.
7196 C The system loses extra energy.
7197 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7198             endif ! j1==j+1
7199           enddo ! kk
7200         enddo ! jj
7201       enddo ! i
7202       return
7203       end
7204 c------------------------------------------------------------------------------
7205       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7206      &  n_corr1)
7207 C This subroutine calculates multi-body contributions to hydrogen-bonding
7208       implicit real*8 (a-h,o-z)
7209       include 'DIMENSIONS'
7210       include 'DIMENSIONS.ZSCOPT'
7211       include 'COMMON.IOUNITS'
7212 #ifdef MPI
7213       include "mpif.h"
7214 #endif
7215       include 'COMMON.FFIELD'
7216       include 'COMMON.DERIV'
7217       include 'COMMON.LOCAL'
7218       include 'COMMON.INTERACT'
7219       include 'COMMON.CONTACTS'
7220       include 'COMMON.CONTMAT'
7221       include 'COMMON.CORRMAT'
7222       include 'COMMON.CHAIN'
7223       include 'COMMON.CONTROL'
7224       include 'COMMON.SHIELD'
7225       double precision gx(3),gx1(3)
7226       integer num_cont_hb_old(maxres)
7227       logical lprn,ldone
7228       double precision eello4,eello5,eelo6,eello_turn6
7229       external eello4,eello5,eello6,eello_turn6
7230 C Set lprn=.true. for debugging
7231       lprn=.false.
7232       eturn6=0.0d0
7233       if (lprn) then
7234         write (iout,'(a)') 'Contact function values:'
7235         do i=nnt,nct-2
7236           write (iout,'(2i3,50(1x,i2,5f6.3))')
7237      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7238      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7239         enddo
7240       endif
7241       ecorr=0.0D0
7242       ecorr5=0.0d0
7243       ecorr6=0.0d0
7244 C Remove the loop below after debugging !!!
7245       do i=nnt,nct
7246         do j=1,3
7247           gradcorr(j,i)=0.0D0
7248           gradxorr(j,i)=0.0D0
7249         enddo
7250       enddo
7251 C Calculate the dipole-dipole interaction energies
7252       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7253       do i=iatel_s,iatel_e+1
7254         num_conti=num_cont_hb(i)
7255         do jj=1,num_conti
7256           j=jcont_hb(jj,i)
7257 #ifdef MOMENT
7258           call dipole(i,j,jj)
7259 #endif
7260         enddo
7261       enddo
7262       endif
7263 C Calculate the local-electrostatic correlation terms
7264 c                write (iout,*) "gradcorr5 in eello5 before loop"
7265 c                do iii=1,nres
7266 c                  write (iout,'(i5,3f10.5)')
7267 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7268 c                enddo
7269       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7270 c        write (iout,*) "corr loop i",i
7271         i1=i+1
7272         num_conti=num_cont_hb(i)
7273         num_conti1=num_cont_hb(i+1)
7274         do jj=1,num_conti
7275           j=jcont_hb(jj,i)
7276           jp=iabs(j)
7277           do kk=1,num_conti1
7278             j1=jcont_hb(kk,i1)
7279             jp1=iabs(j1)
7280 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7281 c     &         ' jj=',jj,' kk=',kk
7282 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7283             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7284      &          .or. j.lt.0 .and. j1.gt.0) .and.
7285      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7286 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7287 C The system gains extra energy.
7288               n_corr=n_corr+1
7289               sqd1=dsqrt(d_cont(jj,i))
7290               sqd2=dsqrt(d_cont(kk,i1))
7291               sred_geom = sqd1*sqd2
7292               IF (sred_geom.lt.cutoff_corr) THEN
7293                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7294      &            ekont,fprimcont)
7295 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7296 cd     &         ' jj=',jj,' kk=',kk
7297                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7298                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7299                 do l=1,3
7300                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7301                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7302                 enddo
7303                 n_corr1=n_corr1+1
7304 cd               write (iout,*) 'sred_geom=',sred_geom,
7305 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7306 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7307 cd               write (iout,*) "g_contij",g_contij
7308 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7309 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7310                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7311                 if (wcorr4.gt.0.0d0)
7312      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7313 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7314                   if (energy_dec.and.wcorr4.gt.0.0d0)
7315      1                 write (iout,'(a6,4i5,0pf7.3)')
7316      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7317 c                write (iout,*) "gradcorr5 before eello5"
7318 c                do iii=1,nres
7319 c                  write (iout,'(i5,3f10.5)')
7320 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7321 c                enddo
7322                 if (wcorr5.gt.0.0d0)
7323      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7324 c                write (iout,*) "gradcorr5 after eello5"
7325 c                do iii=1,nres
7326 c                  write (iout,'(i5,3f10.5)')
7327 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7328 c                enddo
7329                   if (energy_dec.and.wcorr5.gt.0.0d0)
7330      1                 write (iout,'(a6,4i5,0pf7.3)')
7331      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7332 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7333 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7334                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7335      &               .or. wturn6.eq.0.0d0))then
7336 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7337                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7338                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7339      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7340 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7341 cd     &            'ecorr6=',ecorr6
7342 cd                write (iout,'(4e15.5)') sred_geom,
7343 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7344 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7345 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7346                 else if (wturn6.gt.0.0d0
7347      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7348 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7349                   eturn6=eturn6+eello_turn6(i,jj,kk)
7350                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7351      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7352 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7353                 endif
7354               ENDIF
7355 1111          continue
7356             endif
7357           enddo ! kk
7358         enddo ! jj
7359       enddo ! i
7360       do i=1,nres
7361         num_cont_hb(i)=num_cont_hb_old(i)
7362       enddo
7363 c                write (iout,*) "gradcorr5 in eello5"
7364 c                do iii=1,nres
7365 c                  write (iout,'(i5,3f10.5)')
7366 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7367 c                enddo
7368       return
7369       end
7370 c------------------------------------------------------------------------------
7371       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7372       implicit real*8 (a-h,o-z)
7373       include 'DIMENSIONS'
7374       include 'DIMENSIONS.ZSCOPT'
7375       include 'COMMON.IOUNITS'
7376       include 'COMMON.DERIV'
7377       include 'COMMON.INTERACT'
7378       include 'COMMON.CONTACTS'
7379       include 'COMMON.CONTMAT'
7380       include 'COMMON.CORRMAT'
7381       include 'COMMON.SHIELD'
7382       include 'COMMON.CONTROL'
7383       double precision gx(3),gx1(3)
7384       logical lprn
7385       lprn=.false.
7386 C      print *,"wchodze",fac_shield(i),shield_mode
7387       eij=facont_hb(jj,i)
7388       ekl=facont_hb(kk,k)
7389       ees0pij=ees0p(jj,i)
7390       ees0pkl=ees0p(kk,k)
7391       ees0mij=ees0m(jj,i)
7392       ees0mkl=ees0m(kk,k)
7393       ekont=eij*ekl
7394       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7395 C*
7396 C     & fac_shield(i)**2*fac_shield(j)**2
7397 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7398 C Following 4 lines for diagnostics.
7399 cd    ees0pkl=0.0D0
7400 cd    ees0pij=1.0D0
7401 cd    ees0mkl=0.0D0
7402 cd    ees0mij=1.0D0
7403 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7404 c     & 'Contacts ',i,j,
7405 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7406 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7407 c     & 'gradcorr_long'
7408 C Calculate the multi-body contribution to energy.
7409 C      ecorr=ecorr+ekont*ees
7410 C Calculate multi-body contributions to the gradient.
7411       coeffpees0pij=coeffp*ees0pij
7412       coeffmees0mij=coeffm*ees0mij
7413       coeffpees0pkl=coeffp*ees0pkl
7414       coeffmees0mkl=coeffm*ees0mkl
7415       do ll=1,3
7416 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7417         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7418      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7419      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7420         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7421      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7422      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7423 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7424         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7425      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7426      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7427         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7428      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7429      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7430         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7431      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7432      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7433         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7434         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7435         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7436      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7437      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7438         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7439         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7440 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7441       enddo
7442 c      write (iout,*)
7443 cgrad      do m=i+1,j-1
7444 cgrad        do ll=1,3
7445 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7446 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7447 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7448 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7449 cgrad        enddo
7450 cgrad      enddo
7451 cgrad      do m=k+1,l-1
7452 cgrad        do ll=1,3
7453 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7454 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7455 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7456 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7457 cgrad        enddo
7458 cgrad      enddo
7459 c      write (iout,*) "ehbcorr",ekont*ees
7460 C      print *,ekont,ees,i,k
7461       ehbcorr=ekont*ees
7462 C now gradient over shielding
7463 C      return
7464       if (shield_mode.gt.0) then
7465        j=ees0plist(jj,i)
7466        l=ees0plist(kk,k)
7467 C        print *,i,j,fac_shield(i),fac_shield(j),
7468 C     &fac_shield(k),fac_shield(l)
7469         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7470      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7471           do ilist=1,ishield_list(i)
7472            iresshield=shield_list(ilist,i)
7473            do m=1,3
7474            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7475 C     &      *2.0
7476            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7477      &              rlocshield
7478      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7479             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7480      &+rlocshield
7481            enddo
7482           enddo
7483           do ilist=1,ishield_list(j)
7484            iresshield=shield_list(ilist,j)
7485            do m=1,3
7486            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7487 C     &     *2.0
7488            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7489      &              rlocshield
7490      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7491            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7492      &     +rlocshield
7493            enddo
7494           enddo
7495
7496           do ilist=1,ishield_list(k)
7497            iresshield=shield_list(ilist,k)
7498            do m=1,3
7499            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7500 C     &     *2.0
7501            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7502      &              rlocshield
7503      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7504            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7505      &     +rlocshield
7506            enddo
7507           enddo
7508           do ilist=1,ishield_list(l)
7509            iresshield=shield_list(ilist,l)
7510            do m=1,3
7511            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7512 C     &     *2.0
7513            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7514      &              rlocshield
7515      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7516            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7517      &     +rlocshield
7518            enddo
7519           enddo
7520 C          print *,gshieldx(m,iresshield)
7521           do m=1,3
7522             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7523      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7524             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7525      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7526             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7527      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7528             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7529      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7530
7531             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7532      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7533             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7534      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7535             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7536      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7537             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7538      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7539
7540            enddo
7541       endif
7542       endif
7543       return
7544       end
7545 #ifdef MOMENT
7546 C---------------------------------------------------------------------------
7547       subroutine dipole(i,j,jj)
7548       implicit real*8 (a-h,o-z)
7549       include 'DIMENSIONS'
7550       include 'DIMENSIONS.ZSCOPT'
7551       include 'COMMON.IOUNITS'
7552       include 'COMMON.CHAIN'
7553       include 'COMMON.FFIELD'
7554       include 'COMMON.DERIV'
7555       include 'COMMON.INTERACT'
7556       include 'COMMON.CONTACTS'
7557       include 'COMMON.CONTMAT'
7558       include 'COMMON.CORRMAT'
7559       include 'COMMON.TORSION'
7560       include 'COMMON.VAR'
7561       include 'COMMON.GEO'
7562       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7563      &  auxmat(2,2)
7564       iti1 = itortyp(itype(i+1))
7565       if (j.lt.nres-1) then
7566         itj1 = itype2loc(itype(j+1))
7567       else
7568         itj1=nloctyp
7569       endif
7570       do iii=1,2
7571         dipi(iii,1)=Ub2(iii,i)
7572         dipderi(iii)=Ub2der(iii,i)
7573         dipi(iii,2)=b1(iii,i+1)
7574         dipj(iii,1)=Ub2(iii,j)
7575         dipderj(iii)=Ub2der(iii,j)
7576         dipj(iii,2)=b1(iii,j+1)
7577       enddo
7578       kkk=0
7579       do iii=1,2
7580         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7581         do jjj=1,2
7582           kkk=kkk+1
7583           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7584         enddo
7585       enddo
7586       do kkk=1,5
7587         do lll=1,3
7588           mmm=0
7589           do iii=1,2
7590             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7591      &        auxvec(1))
7592             do jjj=1,2
7593               mmm=mmm+1
7594               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7595             enddo
7596           enddo
7597         enddo
7598       enddo
7599       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7600       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7601       do iii=1,2
7602         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7603       enddo
7604       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7605       do iii=1,2
7606         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7607       enddo
7608       return
7609       end
7610 #endif
7611 C---------------------------------------------------------------------------
7612       subroutine calc_eello(i,j,k,l,jj,kk)
7613 C
7614 C This subroutine computes matrices and vectors needed to calculate
7615 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7616 C
7617       implicit real*8 (a-h,o-z)
7618       include 'DIMENSIONS'
7619       include 'DIMENSIONS.ZSCOPT'
7620       include 'COMMON.IOUNITS'
7621       include 'COMMON.CHAIN'
7622       include 'COMMON.DERIV'
7623       include 'COMMON.INTERACT'
7624       include 'COMMON.CONTACTS'
7625       include 'COMMON.CONTMAT'
7626       include 'COMMON.CORRMAT'
7627       include 'COMMON.TORSION'
7628       include 'COMMON.VAR'
7629       include 'COMMON.GEO'
7630       include 'COMMON.FFIELD'
7631       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7632      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7633       logical lprn
7634       common /kutas/ lprn
7635 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7636 cd     & ' jj=',jj,' kk=',kk
7637 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7638 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7639 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7640       do iii=1,2
7641         do jjj=1,2
7642           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7643           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7644         enddo
7645       enddo
7646       call transpose2(aa1(1,1),aa1t(1,1))
7647       call transpose2(aa2(1,1),aa2t(1,1))
7648       do kkk=1,5
7649         do lll=1,3
7650           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7651      &      aa1tder(1,1,lll,kkk))
7652           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7653      &      aa2tder(1,1,lll,kkk))
7654         enddo
7655       enddo
7656       if (l.eq.j+1) then
7657 C parallel orientation of the two CA-CA-CA frames.
7658         if (i.gt.1) then
7659           iti=itype2loc(itype(i))
7660         else
7661           iti=nloctyp
7662         endif
7663         itk1=itype2loc(itype(k+1))
7664         itj=itype2loc(itype(j))
7665         if (l.lt.nres-1) then
7666           itl1=itype2loc(itype(l+1))
7667         else
7668           itl1=nloctyp
7669         endif
7670 C A1 kernel(j+1) A2T
7671 cd        do iii=1,2
7672 cd          write (iout,'(3f10.5,5x,3f10.5)')
7673 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7674 cd        enddo
7675         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7676      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7677      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7678 C Following matrices are needed only for 6-th order cumulants
7679         IF (wcorr6.gt.0.0d0) THEN
7680         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7681      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7682      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7683         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7684      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7685      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7686      &   ADtEAderx(1,1,1,1,1,1))
7687         lprn=.false.
7688         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7689      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7690      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7691      &   ADtEA1derx(1,1,1,1,1,1))
7692         ENDIF
7693 C End 6-th order cumulants
7694 cd        lprn=.false.
7695 cd        if (lprn) then
7696 cd        write (2,*) 'In calc_eello6'
7697 cd        do iii=1,2
7698 cd          write (2,*) 'iii=',iii
7699 cd          do kkk=1,5
7700 cd            write (2,*) 'kkk=',kkk
7701 cd            do jjj=1,2
7702 cd              write (2,'(3(2f10.5),5x)')
7703 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7704 cd            enddo
7705 cd          enddo
7706 cd        enddo
7707 cd        endif
7708         call transpose2(EUgder(1,1,k),auxmat(1,1))
7709         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7710         call transpose2(EUg(1,1,k),auxmat(1,1))
7711         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7712         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7713         do iii=1,2
7714           do kkk=1,5
7715             do lll=1,3
7716               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7717      &          EAEAderx(1,1,lll,kkk,iii,1))
7718             enddo
7719           enddo
7720         enddo
7721 C A1T kernel(i+1) A2
7722         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7723      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7724      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7725 C Following matrices are needed only for 6-th order cumulants
7726         IF (wcorr6.gt.0.0d0) THEN
7727         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7728      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7729      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7730         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7731      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7732      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7733      &   ADtEAderx(1,1,1,1,1,2))
7734         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7735      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7736      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7737      &   ADtEA1derx(1,1,1,1,1,2))
7738         ENDIF
7739 C End 6-th order cumulants
7740         call transpose2(EUgder(1,1,l),auxmat(1,1))
7741         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7742         call transpose2(EUg(1,1,l),auxmat(1,1))
7743         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7744         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7745         do iii=1,2
7746           do kkk=1,5
7747             do lll=1,3
7748               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7749      &          EAEAderx(1,1,lll,kkk,iii,2))
7750             enddo
7751           enddo
7752         enddo
7753 C AEAb1 and AEAb2
7754 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7755 C They are needed only when the fifth- or the sixth-order cumulants are
7756 C indluded.
7757         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7758         call transpose2(AEA(1,1,1),auxmat(1,1))
7759         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7760         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7761         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7762         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7763         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7764         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7765         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7766         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7767         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7768         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7769         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7770         call transpose2(AEA(1,1,2),auxmat(1,1))
7771         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7772         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7773         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7774         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7775         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7776         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7777         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7778         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7779         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7780         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7781         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7782 C Calculate the Cartesian derivatives of the vectors.
7783         do iii=1,2
7784           do kkk=1,5
7785             do lll=1,3
7786               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7787               call matvec2(auxmat(1,1),b1(1,i),
7788      &          AEAb1derx(1,lll,kkk,iii,1,1))
7789               call matvec2(auxmat(1,1),Ub2(1,i),
7790      &          AEAb2derx(1,lll,kkk,iii,1,1))
7791               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7792      &          AEAb1derx(1,lll,kkk,iii,2,1))
7793               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7794      &          AEAb2derx(1,lll,kkk,iii,2,1))
7795               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7796               call matvec2(auxmat(1,1),b1(1,j),
7797      &          AEAb1derx(1,lll,kkk,iii,1,2))
7798               call matvec2(auxmat(1,1),Ub2(1,j),
7799      &          AEAb2derx(1,lll,kkk,iii,1,2))
7800               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7801      &          AEAb1derx(1,lll,kkk,iii,2,2))
7802               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7803      &          AEAb2derx(1,lll,kkk,iii,2,2))
7804             enddo
7805           enddo
7806         enddo
7807         ENDIF
7808 C End vectors
7809       else
7810 C Antiparallel orientation of the two CA-CA-CA frames.
7811         if (i.gt.1) then
7812           iti=itype2loc(itype(i))
7813         else
7814           iti=nloctyp
7815         endif
7816         itk1=itype2loc(itype(k+1))
7817         itl=itype2loc(itype(l))
7818         itj=itype2loc(itype(j))
7819         if (j.lt.nres-1) then
7820           itj1=itype2loc(itype(j+1))
7821         else
7822           itj1=nloctyp
7823         endif
7824 C A2 kernel(j-1)T A1T
7825         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7826      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7827      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7828 C Following matrices are needed only for 6-th order cumulants
7829         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7830      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7831         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7832      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7833      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7834         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7835      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7836      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7837      &   ADtEAderx(1,1,1,1,1,1))
7838         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7839      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7840      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7841      &   ADtEA1derx(1,1,1,1,1,1))
7842         ENDIF
7843 C End 6-th order cumulants
7844         call transpose2(EUgder(1,1,k),auxmat(1,1))
7845         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7846         call transpose2(EUg(1,1,k),auxmat(1,1))
7847         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7848         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7849         do iii=1,2
7850           do kkk=1,5
7851             do lll=1,3
7852               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7853      &          EAEAderx(1,1,lll,kkk,iii,1))
7854             enddo
7855           enddo
7856         enddo
7857 C A2T kernel(i+1)T A1
7858         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7859      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7860      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7861 C Following matrices are needed only for 6-th order cumulants
7862         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7863      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7864         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7865      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7866      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7867         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7868      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7869      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7870      &   ADtEAderx(1,1,1,1,1,2))
7871         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7872      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7873      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7874      &   ADtEA1derx(1,1,1,1,1,2))
7875         ENDIF
7876 C End 6-th order cumulants
7877         call transpose2(EUgder(1,1,j),auxmat(1,1))
7878         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7879         call transpose2(EUg(1,1,j),auxmat(1,1))
7880         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7881         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7882         do iii=1,2
7883           do kkk=1,5
7884             do lll=1,3
7885               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7886      &          EAEAderx(1,1,lll,kkk,iii,2))
7887             enddo
7888           enddo
7889         enddo
7890 C AEAb1 and AEAb2
7891 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7892 C They are needed only when the fifth- or the sixth-order cumulants are
7893 C indluded.
7894         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7895      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7896         call transpose2(AEA(1,1,1),auxmat(1,1))
7897         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7898         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7899         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7900         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7901         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7902         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7903         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7904         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7905         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7906         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7907         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7908         call transpose2(AEA(1,1,2),auxmat(1,1))
7909         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7910         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7911         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7912         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7913         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7914         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7915         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7916         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7917         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7918         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7919         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7920 C Calculate the Cartesian derivatives of the vectors.
7921         do iii=1,2
7922           do kkk=1,5
7923             do lll=1,3
7924               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7925               call matvec2(auxmat(1,1),b1(1,i),
7926      &          AEAb1derx(1,lll,kkk,iii,1,1))
7927               call matvec2(auxmat(1,1),Ub2(1,i),
7928      &          AEAb2derx(1,lll,kkk,iii,1,1))
7929               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7930      &          AEAb1derx(1,lll,kkk,iii,2,1))
7931               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7932      &          AEAb2derx(1,lll,kkk,iii,2,1))
7933               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7934               call matvec2(auxmat(1,1),b1(1,l),
7935      &          AEAb1derx(1,lll,kkk,iii,1,2))
7936               call matvec2(auxmat(1,1),Ub2(1,l),
7937      &          AEAb2derx(1,lll,kkk,iii,1,2))
7938               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7939      &          AEAb1derx(1,lll,kkk,iii,2,2))
7940               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7941      &          AEAb2derx(1,lll,kkk,iii,2,2))
7942             enddo
7943           enddo
7944         enddo
7945         ENDIF
7946 C End vectors
7947       endif
7948       return
7949       end
7950 C---------------------------------------------------------------------------
7951       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7952      &  KK,KKderg,AKA,AKAderg,AKAderx)
7953       implicit none
7954       integer nderg
7955       logical transp
7956       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7957      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7958      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7959       integer iii,kkk,lll
7960       integer jjj,mmm
7961       logical lprn
7962       common /kutas/ lprn
7963       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7964       do iii=1,nderg
7965         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7966      &    AKAderg(1,1,iii))
7967       enddo
7968 cd      if (lprn) write (2,*) 'In kernel'
7969       do kkk=1,5
7970 cd        if (lprn) write (2,*) 'kkk=',kkk
7971         do lll=1,3
7972           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7973      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7974 cd          if (lprn) then
7975 cd            write (2,*) 'lll=',lll
7976 cd            write (2,*) 'iii=1'
7977 cd            do jjj=1,2
7978 cd              write (2,'(3(2f10.5),5x)')
7979 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7980 cd            enddo
7981 cd          endif
7982           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7983      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7984 cd          if (lprn) then
7985 cd            write (2,*) 'lll=',lll
7986 cd            write (2,*) 'iii=2'
7987 cd            do jjj=1,2
7988 cd              write (2,'(3(2f10.5),5x)')
7989 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7990 cd            enddo
7991 cd          endif
7992         enddo
7993       enddo
7994       return
7995       end
7996 C---------------------------------------------------------------------------
7997       double precision function eello4(i,j,k,l,jj,kk)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       include 'DIMENSIONS.ZSCOPT'
8001       include 'COMMON.IOUNITS'
8002       include 'COMMON.CHAIN'
8003       include 'COMMON.DERIV'
8004       include 'COMMON.INTERACT'
8005       include 'COMMON.CONTACTS'
8006       include 'COMMON.CONTMAT'
8007       include 'COMMON.CORRMAT'
8008       include 'COMMON.TORSION'
8009       include 'COMMON.VAR'
8010       include 'COMMON.GEO'
8011       double precision pizda(2,2),ggg1(3),ggg2(3)
8012 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8013 cd        eello4=0.0d0
8014 cd        return
8015 cd      endif
8016 cd      print *,'eello4:',i,j,k,l,jj,kk
8017 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8018 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8019 cold      eij=facont_hb(jj,i)
8020 cold      ekl=facont_hb(kk,k)
8021 cold      ekont=eij*ekl
8022       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8023       if (calc_grad) then
8024 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8025       gcorr_loc(k-1)=gcorr_loc(k-1)
8026      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8027       if (l.eq.j+1) then
8028         gcorr_loc(l-1)=gcorr_loc(l-1)
8029      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8030       else
8031         gcorr_loc(j-1)=gcorr_loc(j-1)
8032      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8033       endif
8034       do iii=1,2
8035         do kkk=1,5
8036           do lll=1,3
8037             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8038      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8039 cd            derx(lll,kkk,iii)=0.0d0
8040           enddo
8041         enddo
8042       enddo
8043 cd      gcorr_loc(l-1)=0.0d0
8044 cd      gcorr_loc(j-1)=0.0d0
8045 cd      gcorr_loc(k-1)=0.0d0
8046 cd      eel4=1.0d0
8047 cd      write (iout,*)'Contacts have occurred for peptide groups',
8048 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8049 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8050       if (j.lt.nres-1) then
8051         j1=j+1
8052         j2=j-1
8053       else
8054         j1=j-1
8055         j2=j-2
8056       endif
8057       if (l.lt.nres-1) then
8058         l1=l+1
8059         l2=l-1
8060       else
8061         l1=l-1
8062         l2=l-2
8063       endif
8064       do ll=1,3
8065 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8066 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8067         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8068         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8069 cgrad        ghalf=0.5d0*ggg1(ll)
8070         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8071         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8072         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8073         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8074         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8075         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8076 cgrad        ghalf=0.5d0*ggg2(ll)
8077         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8078         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8079         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8080         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8081         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8082         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8083       enddo
8084 cgrad      do m=i+1,j-1
8085 cgrad        do ll=1,3
8086 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8087 cgrad        enddo
8088 cgrad      enddo
8089 cgrad      do m=k+1,l-1
8090 cgrad        do ll=1,3
8091 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8092 cgrad        enddo
8093 cgrad      enddo
8094 cgrad      do m=i+2,j2
8095 cgrad        do ll=1,3
8096 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8097 cgrad        enddo
8098 cgrad      enddo
8099 cgrad      do m=k+2,l2
8100 cgrad        do ll=1,3
8101 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8102 cgrad        enddo
8103 cgrad      enddo
8104 cd      do iii=1,nres-3
8105 cd        write (2,*) iii,gcorr_loc(iii)
8106 cd      enddo
8107       endif ! calc_grad
8108       eello4=ekont*eel4
8109 cd      write (2,*) 'ekont',ekont
8110 cd      write (iout,*) 'eello4',ekont*eel4
8111       return
8112       end
8113 C---------------------------------------------------------------------------
8114       double precision function eello5(i,j,k,l,jj,kk)
8115       implicit real*8 (a-h,o-z)
8116       include 'DIMENSIONS'
8117       include 'DIMENSIONS.ZSCOPT'
8118       include 'COMMON.IOUNITS'
8119       include 'COMMON.CHAIN'
8120       include 'COMMON.DERIV'
8121       include 'COMMON.INTERACT'
8122       include 'COMMON.CONTACTS'
8123       include 'COMMON.CONTMAT'
8124       include 'COMMON.CORRMAT'
8125       include 'COMMON.TORSION'
8126       include 'COMMON.VAR'
8127       include 'COMMON.GEO'
8128       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8129       double precision ggg1(3),ggg2(3)
8130 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8131 C                                                                              C
8132 C                            Parallel chains                                   C
8133 C                                                                              C
8134 C          o             o                   o             o                   C
8135 C         /l\           / \             \   / \           / \   /              C
8136 C        /   \         /   \             \ /   \         /   \ /               C
8137 C       j| o |l1       | o |              o| o |         | o |o                C
8138 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8139 C      \i/   \         /   \ /             /   \         /   \                 C
8140 C       o    k1             o                                                  C
8141 C         (I)          (II)                (III)          (IV)                 C
8142 C                                                                              C
8143 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8144 C                                                                              C
8145 C                            Antiparallel chains                               C
8146 C                                                                              C
8147 C          o             o                   o             o                   C
8148 C         /j\           / \             \   / \           / \   /              C
8149 C        /   \         /   \             \ /   \         /   \ /               C
8150 C      j1| o |l        | o |              o| o |         | o |o                C
8151 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8152 C      \i/   \         /   \ /             /   \         /   \                 C
8153 C       o     k1            o                                                  C
8154 C         (I)          (II)                (III)          (IV)                 C
8155 C                                                                              C
8156 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8157 C                                                                              C
8158 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8159 C                                                                              C
8160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8161 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8162 cd        eello5=0.0d0
8163 cd        return
8164 cd      endif
8165 cd      write (iout,*)
8166 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8167 cd     &   ' and',k,l
8168       itk=itype2loc(itype(k))
8169       itl=itype2loc(itype(l))
8170       itj=itype2loc(itype(j))
8171       eello5_1=0.0d0
8172       eello5_2=0.0d0
8173       eello5_3=0.0d0
8174       eello5_4=0.0d0
8175 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8176 cd     &   eel5_3_num,eel5_4_num)
8177       do iii=1,2
8178         do kkk=1,5
8179           do lll=1,3
8180             derx(lll,kkk,iii)=0.0d0
8181           enddo
8182         enddo
8183       enddo
8184 cd      eij=facont_hb(jj,i)
8185 cd      ekl=facont_hb(kk,k)
8186 cd      ekont=eij*ekl
8187 cd      write (iout,*)'Contacts have occurred for peptide groups',
8188 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8189 cd      goto 1111
8190 C Contribution from the graph I.
8191 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8192 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8193       call transpose2(EUg(1,1,k),auxmat(1,1))
8194       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8195       vv(1)=pizda(1,1)-pizda(2,2)
8196       vv(2)=pizda(1,2)+pizda(2,1)
8197       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8198      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8199       if (calc_grad) then
8200 C Explicit gradient in virtual-dihedral angles.
8201       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8202      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8203      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8204       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8205       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8206       vv(1)=pizda(1,1)-pizda(2,2)
8207       vv(2)=pizda(1,2)+pizda(2,1)
8208       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8209      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8210      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8211       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8212       vv(1)=pizda(1,1)-pizda(2,2)
8213       vv(2)=pizda(1,2)+pizda(2,1)
8214       if (l.eq.j+1) then
8215         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8216      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8217      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8218       else
8219         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8220      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8221      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8222       endif
8223 C Cartesian gradient
8224       do iii=1,2
8225         do kkk=1,5
8226           do lll=1,3
8227             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8228      &        pizda(1,1))
8229             vv(1)=pizda(1,1)-pizda(2,2)
8230             vv(2)=pizda(1,2)+pizda(2,1)
8231             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8232      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8233      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8234           enddo
8235         enddo
8236       enddo
8237       endif ! calc_grad
8238 c      goto 1112
8239 c1111  continue
8240 C Contribution from graph II
8241       call transpose2(EE(1,1,k),auxmat(1,1))
8242       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8243       vv(1)=pizda(1,1)+pizda(2,2)
8244       vv(2)=pizda(2,1)-pizda(1,2)
8245       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8246      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8247       if (calc_grad) then
8248 C Explicit gradient in virtual-dihedral angles.
8249       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8250      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8251       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8252       vv(1)=pizda(1,1)+pizda(2,2)
8253       vv(2)=pizda(2,1)-pizda(1,2)
8254       if (l.eq.j+1) then
8255         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8256      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8257      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8258       else
8259         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8260      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8261      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8262       endif
8263 C Cartesian gradient
8264       do iii=1,2
8265         do kkk=1,5
8266           do lll=1,3
8267             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8268      &        pizda(1,1))
8269             vv(1)=pizda(1,1)+pizda(2,2)
8270             vv(2)=pizda(2,1)-pizda(1,2)
8271             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8272      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8273      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8274           enddo
8275         enddo
8276       enddo
8277       endif ! calc_grad
8278 cd      goto 1112
8279 cd1111  continue
8280       if (l.eq.j+1) then
8281 cd        goto 1110
8282 C Parallel orientation
8283 C Contribution from graph III
8284         call transpose2(EUg(1,1,l),auxmat(1,1))
8285         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8286         vv(1)=pizda(1,1)-pizda(2,2)
8287         vv(2)=pizda(1,2)+pizda(2,1)
8288         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8289      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8290         if (calc_grad) then
8291 C Explicit gradient in virtual-dihedral angles.
8292         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8293      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8294      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8295         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8296         vv(1)=pizda(1,1)-pizda(2,2)
8297         vv(2)=pizda(1,2)+pizda(2,1)
8298         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8299      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8300      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8301         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8302         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8303         vv(1)=pizda(1,1)-pizda(2,2)
8304         vv(2)=pizda(1,2)+pizda(2,1)
8305         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8306      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8307      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8308 C Cartesian gradient
8309         do iii=1,2
8310           do kkk=1,5
8311             do lll=1,3
8312               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8313      &          pizda(1,1))
8314               vv(1)=pizda(1,1)-pizda(2,2)
8315               vv(2)=pizda(1,2)+pizda(2,1)
8316               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8317      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8318      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8319             enddo
8320           enddo
8321         enddo
8322 cd        goto 1112
8323 C Contribution from graph IV
8324 cd1110    continue
8325         call transpose2(EE(1,1,l),auxmat(1,1))
8326         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8327         vv(1)=pizda(1,1)+pizda(2,2)
8328         vv(2)=pizda(2,1)-pizda(1,2)
8329         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8330      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8331 C Explicit gradient in virtual-dihedral angles.
8332         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8333      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8334         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8335         vv(1)=pizda(1,1)+pizda(2,2)
8336         vv(2)=pizda(2,1)-pizda(1,2)
8337         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8338      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8339      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8340 C Cartesian gradient
8341         do iii=1,2
8342           do kkk=1,5
8343             do lll=1,3
8344               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8345      &          pizda(1,1))
8346               vv(1)=pizda(1,1)+pizda(2,2)
8347               vv(2)=pizda(2,1)-pizda(1,2)
8348               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8349      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8350      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8351             enddo
8352           enddo
8353         enddo
8354         endif ! calc_grad
8355       else
8356 C Antiparallel orientation
8357 C Contribution from graph III
8358 c        goto 1110
8359         call transpose2(EUg(1,1,j),auxmat(1,1))
8360         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8361         vv(1)=pizda(1,1)-pizda(2,2)
8362         vv(2)=pizda(1,2)+pizda(2,1)
8363         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8364      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8365         if (calc_grad) then
8366 C Explicit gradient in virtual-dihedral angles.
8367         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8368      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8369      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8370         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8371         vv(1)=pizda(1,1)-pizda(2,2)
8372         vv(2)=pizda(1,2)+pizda(2,1)
8373         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8374      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8375      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8376         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8377         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8378         vv(1)=pizda(1,1)-pizda(2,2)
8379         vv(2)=pizda(1,2)+pizda(2,1)
8380         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8381      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8382      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8383 C Cartesian gradient
8384         do iii=1,2
8385           do kkk=1,5
8386             do lll=1,3
8387               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8388      &          pizda(1,1))
8389               vv(1)=pizda(1,1)-pizda(2,2)
8390               vv(2)=pizda(1,2)+pizda(2,1)
8391               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8392      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8393      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8394             enddo
8395           enddo
8396         enddo
8397         endif ! calc_grad
8398 cd        goto 1112
8399 C Contribution from graph IV
8400 1110    continue
8401         call transpose2(EE(1,1,j),auxmat(1,1))
8402         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8403         vv(1)=pizda(1,1)+pizda(2,2)
8404         vv(2)=pizda(2,1)-pizda(1,2)
8405         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8406      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8407         if (calc_grad) then
8408 C Explicit gradient in virtual-dihedral angles.
8409         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8410      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8411         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8412         vv(1)=pizda(1,1)+pizda(2,2)
8413         vv(2)=pizda(2,1)-pizda(1,2)
8414         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8415      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8416      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8417 C Cartesian gradient
8418         do iii=1,2
8419           do kkk=1,5
8420             do lll=1,3
8421               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8422      &          pizda(1,1))
8423               vv(1)=pizda(1,1)+pizda(2,2)
8424               vv(2)=pizda(2,1)-pizda(1,2)
8425               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8426      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8427      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8428             enddo
8429           enddo
8430         enddo
8431         endif ! calc_grad
8432       endif
8433 1112  continue
8434       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8435 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8436 cd        write (2,*) 'ijkl',i,j,k,l
8437 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8438 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8439 cd      endif
8440 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8441 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8442 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8443 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8444       if (calc_grad) then
8445       if (j.lt.nres-1) then
8446         j1=j+1
8447         j2=j-1
8448       else
8449         j1=j-1
8450         j2=j-2
8451       endif
8452       if (l.lt.nres-1) then
8453         l1=l+1
8454         l2=l-1
8455       else
8456         l1=l-1
8457         l2=l-2
8458       endif
8459 cd      eij=1.0d0
8460 cd      ekl=1.0d0
8461 cd      ekont=1.0d0
8462 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8463 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8464 C        summed up outside the subrouine as for the other subroutines
8465 C        handling long-range interactions. The old code is commented out
8466 C        with "cgrad" to keep track of changes.
8467       do ll=1,3
8468 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8469 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8470         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8471         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8472 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8473 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8474 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8475 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8476 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8477 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8478 c     &   gradcorr5ij,
8479 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8480 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8481 cgrad        ghalf=0.5d0*ggg1(ll)
8482 cd        ghalf=0.0d0
8483         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8484         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8485         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8486         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8487         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8488         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8489 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8490 cgrad        ghalf=0.5d0*ggg2(ll)
8491 cd        ghalf=0.0d0
8492         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8493         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8494         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8495         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8496         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8497         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8498       enddo
8499       endif ! calc_grad
8500 cd      goto 1112
8501 cgrad      do m=i+1,j-1
8502 cgrad        do ll=1,3
8503 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8504 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8505 cgrad        enddo
8506 cgrad      enddo
8507 cgrad      do m=k+1,l-1
8508 cgrad        do ll=1,3
8509 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8510 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8511 cgrad        enddo
8512 cgrad      enddo
8513 c1112  continue
8514 cgrad      do m=i+2,j2
8515 cgrad        do ll=1,3
8516 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8517 cgrad        enddo
8518 cgrad      enddo
8519 cgrad      do m=k+2,l2
8520 cgrad        do ll=1,3
8521 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8522 cgrad        enddo
8523 cgrad      enddo
8524 cd      do iii=1,nres-3
8525 cd        write (2,*) iii,g_corr5_loc(iii)
8526 cd      enddo
8527       eello5=ekont*eel5
8528 cd      write (2,*) 'ekont',ekont
8529 cd      write (iout,*) 'eello5',ekont*eel5
8530       return
8531       end
8532 c--------------------------------------------------------------------------
8533       double precision function eello6(i,j,k,l,jj,kk)
8534       implicit real*8 (a-h,o-z)
8535       include 'DIMENSIONS'
8536       include 'DIMENSIONS.ZSCOPT'
8537       include 'COMMON.IOUNITS'
8538       include 'COMMON.CHAIN'
8539       include 'COMMON.DERIV'
8540       include 'COMMON.INTERACT'
8541       include 'COMMON.CONTACTS'
8542       include 'COMMON.CONTMAT'
8543       include 'COMMON.CORRMAT'
8544       include 'COMMON.TORSION'
8545       include 'COMMON.VAR'
8546       include 'COMMON.GEO'
8547       include 'COMMON.FFIELD'
8548       double precision ggg1(3),ggg2(3)
8549 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8550 cd        eello6=0.0d0
8551 cd        return
8552 cd      endif
8553 cd      write (iout,*)
8554 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8555 cd     &   ' and',k,l
8556       eello6_1=0.0d0
8557       eello6_2=0.0d0
8558       eello6_3=0.0d0
8559       eello6_4=0.0d0
8560       eello6_5=0.0d0
8561       eello6_6=0.0d0
8562 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8563 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8564       do iii=1,2
8565         do kkk=1,5
8566           do lll=1,3
8567             derx(lll,kkk,iii)=0.0d0
8568           enddo
8569         enddo
8570       enddo
8571 cd      eij=facont_hb(jj,i)
8572 cd      ekl=facont_hb(kk,k)
8573 cd      ekont=eij*ekl
8574 cd      eij=1.0d0
8575 cd      ekl=1.0d0
8576 cd      ekont=1.0d0
8577       if (l.eq.j+1) then
8578         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8579         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8580         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8581         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8582         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8583         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8584       else
8585         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8586         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8587         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8588         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8589         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8590           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8591         else
8592           eello6_5=0.0d0
8593         endif
8594         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8595       endif
8596 C If turn contributions are considered, they will be handled separately.
8597       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8598 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8599 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8600 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8601 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8602 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8603 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8604 cd      goto 1112
8605       if (calc_grad) then
8606       if (j.lt.nres-1) then
8607         j1=j+1
8608         j2=j-1
8609       else
8610         j1=j-1
8611         j2=j-2
8612       endif
8613       if (l.lt.nres-1) then
8614         l1=l+1
8615         l2=l-1
8616       else
8617         l1=l-1
8618         l2=l-2
8619       endif
8620       do ll=1,3
8621 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8622 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8623 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8624 cgrad        ghalf=0.5d0*ggg1(ll)
8625 cd        ghalf=0.0d0
8626         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8627         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8628         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8629         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8630         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8631         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8632         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8633         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8634 cgrad        ghalf=0.5d0*ggg2(ll)
8635 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8636 cd        ghalf=0.0d0
8637         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8638         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8639         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8640         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8641         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8642         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8643       enddo
8644       endif ! calc_grad
8645 cd      goto 1112
8646 cgrad      do m=i+1,j-1
8647 cgrad        do ll=1,3
8648 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8649 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8650 cgrad        enddo
8651 cgrad      enddo
8652 cgrad      do m=k+1,l-1
8653 cgrad        do ll=1,3
8654 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8655 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8656 cgrad        enddo
8657 cgrad      enddo
8658 cgrad1112  continue
8659 cgrad      do m=i+2,j2
8660 cgrad        do ll=1,3
8661 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8662 cgrad        enddo
8663 cgrad      enddo
8664 cgrad      do m=k+2,l2
8665 cgrad        do ll=1,3
8666 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8667 cgrad        enddo
8668 cgrad      enddo
8669 cd      do iii=1,nres-3
8670 cd        write (2,*) iii,g_corr6_loc(iii)
8671 cd      enddo
8672       eello6=ekont*eel6
8673 cd      write (2,*) 'ekont',ekont
8674 cd      write (iout,*) 'eello6',ekont*eel6
8675       return
8676       end
8677 c--------------------------------------------------------------------------
8678       double precision function eello6_graph1(i,j,k,l,imat,swap)
8679       implicit real*8 (a-h,o-z)
8680       include 'DIMENSIONS'
8681       include 'DIMENSIONS.ZSCOPT'
8682       include 'COMMON.IOUNITS'
8683       include 'COMMON.CHAIN'
8684       include 'COMMON.DERIV'
8685       include 'COMMON.INTERACT'
8686       include 'COMMON.CONTACTS'
8687       include 'COMMON.CONTMAT'
8688       include 'COMMON.CORRMAT'
8689       include 'COMMON.TORSION'
8690       include 'COMMON.VAR'
8691       include 'COMMON.GEO'
8692       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8693       logical swap
8694       logical lprn
8695       common /kutas/ lprn
8696 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8697 C                                                                              C
8698 C      Parallel       Antiparallel                                             C
8699 C                                                                              C
8700 C          o             o                                                     C
8701 C         /l\           /j\                                                    C
8702 C        /   \         /   \                                                   C
8703 C       /| o |         | o |\                                                  C
8704 C     \ j|/k\|  /   \  |/k\|l /                                                C
8705 C      \ /   \ /     \ /   \ /                                                 C
8706 C       o     o       o     o                                                  C
8707 C       i             i                                                        C
8708 C                                                                              C
8709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8710       itk=itype2loc(itype(k))
8711       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8712       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8713       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8714       call transpose2(EUgC(1,1,k),auxmat(1,1))
8715       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8716       vv1(1)=pizda1(1,1)-pizda1(2,2)
8717       vv1(2)=pizda1(1,2)+pizda1(2,1)
8718       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8719       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8720       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8721       s5=scalar2(vv(1),Dtobr2(1,i))
8722 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8723       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8724       if (calc_grad) then
8725       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8726      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8727      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8728      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8729      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8730      & +scalar2(vv(1),Dtobr2der(1,i)))
8731       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8732       vv1(1)=pizda1(1,1)-pizda1(2,2)
8733       vv1(2)=pizda1(1,2)+pizda1(2,1)
8734       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8735       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8736       if (l.eq.j+1) then
8737         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8738      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8739      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8740      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8741      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8742       else
8743         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8744      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8745      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8746      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8747      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8748       endif
8749       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8750       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8751       vv1(1)=pizda1(1,1)-pizda1(2,2)
8752       vv1(2)=pizda1(1,2)+pizda1(2,1)
8753       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8754      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8755      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8756      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8757       do iii=1,2
8758         if (swap) then
8759           ind=3-iii
8760         else
8761           ind=iii
8762         endif
8763         do kkk=1,5
8764           do lll=1,3
8765             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8766             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8767             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8768             call transpose2(EUgC(1,1,k),auxmat(1,1))
8769             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8770      &        pizda1(1,1))
8771             vv1(1)=pizda1(1,1)-pizda1(2,2)
8772             vv1(2)=pizda1(1,2)+pizda1(2,1)
8773             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8774             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8775      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8776             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8777      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8778             s5=scalar2(vv(1),Dtobr2(1,i))
8779             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8780           enddo
8781         enddo
8782       enddo
8783       endif ! calc_grad
8784       return
8785       end
8786 c----------------------------------------------------------------------------
8787       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8788       implicit real*8 (a-h,o-z)
8789       include 'DIMENSIONS'
8790       include 'DIMENSIONS.ZSCOPT'
8791       include 'COMMON.IOUNITS'
8792       include 'COMMON.CHAIN'
8793       include 'COMMON.DERIV'
8794       include 'COMMON.INTERACT'
8795       include 'COMMON.CONTACTS'
8796       include 'COMMON.CONTMAT'
8797       include 'COMMON.CORRMAT'
8798       include 'COMMON.TORSION'
8799       include 'COMMON.VAR'
8800       include 'COMMON.GEO'
8801       logical swap
8802       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8803      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8804       logical lprn
8805       common /kutas/ lprn
8806 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8807 C                                                                              C
8808 C      Parallel       Antiparallel                                             C
8809 C                                                                              C
8810 C          o             o                                                     C
8811 C     \   /l\           /j\   /                                                C
8812 C      \ /   \         /   \ /                                                 C
8813 C       o| o |         | o |o                                                  C
8814 C     \ j|/k\|      \  |/k\|l                                                  C
8815 C      \ /   \       \ /   \                                                   C
8816 C       o             o                                                        C
8817 C       i             i                                                        C
8818 C                                                                              C
8819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8820 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8821 C AL 7/4/01 s1 would occur in the sixth-order moment,
8822 C           but not in a cluster cumulant
8823 #ifdef MOMENT
8824       s1=dip(1,jj,i)*dip(1,kk,k)
8825 #endif
8826       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8827       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8828       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8829       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8830       call transpose2(EUg(1,1,k),auxmat(1,1))
8831       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8832       vv(1)=pizda(1,1)-pizda(2,2)
8833       vv(2)=pizda(1,2)+pizda(2,1)
8834       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8835 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8836 #ifdef MOMENT
8837       eello6_graph2=-(s1+s2+s3+s4)
8838 #else
8839       eello6_graph2=-(s2+s3+s4)
8840 #endif
8841 c      eello6_graph2=-s3
8842 C Derivatives in gamma(i-1)
8843       if (calc_grad) then
8844       if (i.gt.1) then
8845 #ifdef MOMENT
8846         s1=dipderg(1,jj,i)*dip(1,kk,k)
8847 #endif
8848         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8849         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8850         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8851         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8852 #ifdef MOMENT
8853         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8854 #else
8855         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8856 #endif
8857 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8858       endif
8859 C Derivatives in gamma(k-1)
8860 #ifdef MOMENT
8861       s1=dip(1,jj,i)*dipderg(1,kk,k)
8862 #endif
8863       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8864       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8865       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8866       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8867       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8868       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8869       vv(1)=pizda(1,1)-pizda(2,2)
8870       vv(2)=pizda(1,2)+pizda(2,1)
8871       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8872 #ifdef MOMENT
8873       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8874 #else
8875       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8876 #endif
8877 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8878 C Derivatives in gamma(j-1) or gamma(l-1)
8879       if (j.gt.1) then
8880 #ifdef MOMENT
8881         s1=dipderg(3,jj,i)*dip(1,kk,k)
8882 #endif
8883         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8884         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8885         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8886         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8887         vv(1)=pizda(1,1)-pizda(2,2)
8888         vv(2)=pizda(1,2)+pizda(2,1)
8889         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8890 #ifdef MOMENT
8891         if (swap) then
8892           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8893         else
8894           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8895         endif
8896 #endif
8897         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8898 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8899       endif
8900 C Derivatives in gamma(l-1) or gamma(j-1)
8901       if (l.gt.1) then
8902 #ifdef MOMENT
8903         s1=dip(1,jj,i)*dipderg(3,kk,k)
8904 #endif
8905         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8906         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8907         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8908         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8909         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8910         vv(1)=pizda(1,1)-pizda(2,2)
8911         vv(2)=pizda(1,2)+pizda(2,1)
8912         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8913 #ifdef MOMENT
8914         if (swap) then
8915           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8916         else
8917           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8918         endif
8919 #endif
8920         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8921 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8922       endif
8923 C Cartesian derivatives.
8924       if (lprn) then
8925         write (2,*) 'In eello6_graph2'
8926         do iii=1,2
8927           write (2,*) 'iii=',iii
8928           do kkk=1,5
8929             write (2,*) 'kkk=',kkk
8930             do jjj=1,2
8931               write (2,'(3(2f10.5),5x)')
8932      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8933             enddo
8934           enddo
8935         enddo
8936       endif
8937       do iii=1,2
8938         do kkk=1,5
8939           do lll=1,3
8940 #ifdef MOMENT
8941             if (iii.eq.1) then
8942               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8943             else
8944               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8945             endif
8946 #endif
8947             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8948      &        auxvec(1))
8949             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8950             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8951      &        auxvec(1))
8952             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8953             call transpose2(EUg(1,1,k),auxmat(1,1))
8954             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8955      &        pizda(1,1))
8956             vv(1)=pizda(1,1)-pizda(2,2)
8957             vv(2)=pizda(1,2)+pizda(2,1)
8958             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8959 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8960 #ifdef MOMENT
8961             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8962 #else
8963             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8964 #endif
8965             if (swap) then
8966               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8967             else
8968               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8969             endif
8970           enddo
8971         enddo
8972       enddo
8973       endif ! calc_grad
8974       return
8975       end
8976 c----------------------------------------------------------------------------
8977       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8978       implicit real*8 (a-h,o-z)
8979       include 'DIMENSIONS'
8980       include 'DIMENSIONS.ZSCOPT'
8981       include 'COMMON.IOUNITS'
8982       include 'COMMON.CHAIN'
8983       include 'COMMON.DERIV'
8984       include 'COMMON.INTERACT'
8985       include 'COMMON.CONTACTS'
8986       include 'COMMON.CONTMAT'
8987       include 'COMMON.CORRMAT'
8988       include 'COMMON.TORSION'
8989       include 'COMMON.VAR'
8990       include 'COMMON.GEO'
8991       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8992       logical swap
8993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8994 C                                                                              C
8995 C      Parallel       Antiparallel                                             C
8996 C                                                                              C
8997 C          o             o                                                     C
8998 C         /l\   /   \   /j\                                                    C
8999 C        /   \ /     \ /   \                                                   C
9000 C       /| o |o       o| o |\                                                  C
9001 C       j|/k\|  /      |/k\|l /                                                C
9002 C        /   \ /       /   \ /                                                 C
9003 C       /     o       /     o                                                  C
9004 C       i             i                                                        C
9005 C                                                                              C
9006 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9007 C
9008 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9009 C           energy moment and not to the cluster cumulant.
9010       iti=itortyp(itype(i))
9011       if (j.lt.nres-1) then
9012         itj1=itype2loc(itype(j+1))
9013       else
9014         itj1=nloctyp
9015       endif
9016       itk=itype2loc(itype(k))
9017       itk1=itype2loc(itype(k+1))
9018       if (l.lt.nres-1) then
9019         itl1=itype2loc(itype(l+1))
9020       else
9021         itl1=nloctyp
9022       endif
9023 #ifdef MOMENT
9024       s1=dip(4,jj,i)*dip(4,kk,k)
9025 #endif
9026       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9027       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9028       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9029       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9030       call transpose2(EE(1,1,k),auxmat(1,1))
9031       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9032       vv(1)=pizda(1,1)+pizda(2,2)
9033       vv(2)=pizda(2,1)-pizda(1,2)
9034       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9035 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9036 cd     & "sum",-(s2+s3+s4)
9037 #ifdef MOMENT
9038       eello6_graph3=-(s1+s2+s3+s4)
9039 #else
9040       eello6_graph3=-(s2+s3+s4)
9041 #endif
9042 c      eello6_graph3=-s4
9043 C Derivatives in gamma(k-1)
9044       if (calc_grad) then
9045       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9046       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9047       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9048       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9049 C Derivatives in gamma(l-1)
9050       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9051       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9052       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9053       vv(1)=pizda(1,1)+pizda(2,2)
9054       vv(2)=pizda(2,1)-pizda(1,2)
9055       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9056       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9057 C Cartesian derivatives.
9058       do iii=1,2
9059         do kkk=1,5
9060           do lll=1,3
9061 #ifdef MOMENT
9062             if (iii.eq.1) then
9063               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9064             else
9065               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9066             endif
9067 #endif
9068             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9069      &        auxvec(1))
9070             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9071             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9072      &        auxvec(1))
9073             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9074             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9075      &        pizda(1,1))
9076             vv(1)=pizda(1,1)+pizda(2,2)
9077             vv(2)=pizda(2,1)-pizda(1,2)
9078             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9079 #ifdef MOMENT
9080             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9081 #else
9082             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9083 #endif
9084             if (swap) then
9085               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9086             else
9087               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9088             endif
9089 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9090           enddo
9091         enddo
9092       enddo
9093       endif ! calc_grad
9094       return
9095       end
9096 c----------------------------------------------------------------------------
9097       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9098       implicit real*8 (a-h,o-z)
9099       include 'DIMENSIONS'
9100       include 'DIMENSIONS.ZSCOPT'
9101       include 'COMMON.IOUNITS'
9102       include 'COMMON.CHAIN'
9103       include 'COMMON.DERIV'
9104       include 'COMMON.INTERACT'
9105       include 'COMMON.CONTACTS'
9106       include 'COMMON.CONTMAT'
9107       include 'COMMON.CORRMAT'
9108       include 'COMMON.TORSION'
9109       include 'COMMON.VAR'
9110       include 'COMMON.GEO'
9111       include 'COMMON.FFIELD'
9112       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9113      & auxvec1(2),auxmat1(2,2)
9114       logical swap
9115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9116 C                                                                              C
9117 C      Parallel       Antiparallel                                             C
9118 C                                                                              C
9119 C          o             o                                                     C
9120 C         /l\   /   \   /j\                                                    C
9121 C        /   \ /     \ /   \                                                   C
9122 C       /| o |o       o| o |\                                                  C
9123 C     \ j|/k\|      \  |/k\|l                                                  C
9124 C      \ /   \       \ /   \                                                   C
9125 C       o     \       o     \                                                  C
9126 C       i             i                                                        C
9127 C                                                                              C
9128 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9129 C
9130 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9131 C           energy moment and not to the cluster cumulant.
9132 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9133       iti=itype2loc(itype(i))
9134       itj=itype2loc(itype(j))
9135       if (j.lt.nres-1) then
9136         itj1=itype2loc(itype(j+1))
9137       else
9138         itj1=nloctyp
9139       endif
9140       itk=itype2loc(itype(k))
9141       if (k.lt.nres-1) then
9142         itk1=itype2loc(itype(k+1))
9143       else
9144         itk1=nloctyp
9145       endif
9146       itl=itype2loc(itype(l))
9147       if (l.lt.nres-1) then
9148         itl1=itype2loc(itype(l+1))
9149       else
9150         itl1=nloctyp
9151       endif
9152 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9153 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9154 cd     & ' itl',itl,' itl1',itl1
9155 #ifdef MOMENT
9156       if (imat.eq.1) then
9157         s1=dip(3,jj,i)*dip(3,kk,k)
9158       else
9159         s1=dip(2,jj,j)*dip(2,kk,l)
9160       endif
9161 #endif
9162       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9163       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9164       if (j.eq.l+1) then
9165         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9166         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9167       else
9168         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9169         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9170       endif
9171       call transpose2(EUg(1,1,k),auxmat(1,1))
9172       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9173       vv(1)=pizda(1,1)-pizda(2,2)
9174       vv(2)=pizda(2,1)+pizda(1,2)
9175       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9176 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9177 #ifdef MOMENT
9178       eello6_graph4=-(s1+s2+s3+s4)
9179 #else
9180       eello6_graph4=-(s2+s3+s4)
9181 #endif
9182 C Derivatives in gamma(i-1)
9183       if (calc_grad) then
9184       if (i.gt.1) then
9185 #ifdef MOMENT
9186         if (imat.eq.1) then
9187           s1=dipderg(2,jj,i)*dip(3,kk,k)
9188         else
9189           s1=dipderg(4,jj,j)*dip(2,kk,l)
9190         endif
9191 #endif
9192         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9193         if (j.eq.l+1) then
9194           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9195           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9196         else
9197           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9198           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9199         endif
9200         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9201         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9202 cd          write (2,*) 'turn6 derivatives'
9203 #ifdef MOMENT
9204           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9205 #else
9206           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9207 #endif
9208         else
9209 #ifdef MOMENT
9210           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9211 #else
9212           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9213 #endif
9214         endif
9215       endif
9216 C Derivatives in gamma(k-1)
9217 #ifdef MOMENT
9218       if (imat.eq.1) then
9219         s1=dip(3,jj,i)*dipderg(2,kk,k)
9220       else
9221         s1=dip(2,jj,j)*dipderg(4,kk,l)
9222       endif
9223 #endif
9224       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9225       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9226       if (j.eq.l+1) then
9227         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9228         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9229       else
9230         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9231         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9232       endif
9233       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9234       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9235       vv(1)=pizda(1,1)-pizda(2,2)
9236       vv(2)=pizda(2,1)+pizda(1,2)
9237       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9238       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9239 #ifdef MOMENT
9240         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9241 #else
9242         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9243 #endif
9244       else
9245 #ifdef MOMENT
9246         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9247 #else
9248         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9249 #endif
9250       endif
9251 C Derivatives in gamma(j-1) or gamma(l-1)
9252       if (l.eq.j+1 .and. l.gt.1) then
9253         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9254         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9255         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9256         vv(1)=pizda(1,1)-pizda(2,2)
9257         vv(2)=pizda(2,1)+pizda(1,2)
9258         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9259         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9260       else if (j.gt.1) then
9261         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9262         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9263         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9264         vv(1)=pizda(1,1)-pizda(2,2)
9265         vv(2)=pizda(2,1)+pizda(1,2)
9266         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9267         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9268           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9269         else
9270           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9271         endif
9272       endif
9273 C Cartesian derivatives.
9274       do iii=1,2
9275         do kkk=1,5
9276           do lll=1,3
9277 #ifdef MOMENT
9278             if (iii.eq.1) then
9279               if (imat.eq.1) then
9280                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9281               else
9282                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9283               endif
9284             else
9285               if (imat.eq.1) then
9286                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9287               else
9288                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9289               endif
9290             endif
9291 #endif
9292             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9293      &        auxvec(1))
9294             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9295             if (j.eq.l+1) then
9296               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9297      &          b1(1,j+1),auxvec(1))
9298               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9299             else
9300               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9301      &          b1(1,l+1),auxvec(1))
9302               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9303             endif
9304             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9305      &        pizda(1,1))
9306             vv(1)=pizda(1,1)-pizda(2,2)
9307             vv(2)=pizda(2,1)+pizda(1,2)
9308             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9309             if (swap) then
9310               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9311 #ifdef MOMENT
9312                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9313      &             -(s1+s2+s4)
9314 #else
9315                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9316      &             -(s2+s4)
9317 #endif
9318                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9319               else
9320 #ifdef MOMENT
9321                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9322 #else
9323                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9324 #endif
9325                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9326               endif
9327             else
9328 #ifdef MOMENT
9329               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9330 #else
9331               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9332 #endif
9333               if (l.eq.j+1) then
9334                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9335               else
9336                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9337               endif
9338             endif
9339           enddo
9340         enddo
9341       enddo
9342       endif ! calc_grad
9343       return
9344       end
9345 c----------------------------------------------------------------------------
9346       double precision function eello_turn6(i,jj,kk)
9347       implicit real*8 (a-h,o-z)
9348       include 'DIMENSIONS'
9349       include 'DIMENSIONS.ZSCOPT'
9350       include 'COMMON.IOUNITS'
9351       include 'COMMON.CHAIN'
9352       include 'COMMON.DERIV'
9353       include 'COMMON.INTERACT'
9354       include 'COMMON.CONTACTS'
9355       include 'COMMON.CONTMAT'
9356       include 'COMMON.CORRMAT'
9357       include 'COMMON.TORSION'
9358       include 'COMMON.VAR'
9359       include 'COMMON.GEO'
9360       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9361      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9362      &  ggg1(3),ggg2(3)
9363       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9364      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9365 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9366 C           the respective energy moment and not to the cluster cumulant.
9367       s1=0.0d0
9368       s8=0.0d0
9369       s13=0.0d0
9370 c
9371       eello_turn6=0.0d0
9372       j=i+4
9373       k=i+1
9374       l=i+3
9375       iti=itype2loc(itype(i))
9376       itk=itype2loc(itype(k))
9377       itk1=itype2loc(itype(k+1))
9378       itl=itype2loc(itype(l))
9379       itj=itype2loc(itype(j))
9380 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9381 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9382 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9383 cd        eello6=0.0d0
9384 cd        return
9385 cd      endif
9386 cd      write (iout,*)
9387 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9388 cd     &   ' and',k,l
9389 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9390       do iii=1,2
9391         do kkk=1,5
9392           do lll=1,3
9393             derx_turn(lll,kkk,iii)=0.0d0
9394           enddo
9395         enddo
9396       enddo
9397 cd      eij=1.0d0
9398 cd      ekl=1.0d0
9399 cd      ekont=1.0d0
9400       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9401 cd      eello6_5=0.0d0
9402 cd      write (2,*) 'eello6_5',eello6_5
9403 #ifdef MOMENT
9404       call transpose2(AEA(1,1,1),auxmat(1,1))
9405       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9406       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9407       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9408 #endif
9409       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9410       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9411       s2 = scalar2(b1(1,k),vtemp1(1))
9412 #ifdef MOMENT
9413       call transpose2(AEA(1,1,2),atemp(1,1))
9414       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9415       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9416       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9417 #endif
9418       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9419       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9420       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9421 #ifdef MOMENT
9422       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9423       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9424       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9425       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9426       ss13 = scalar2(b1(1,k),vtemp4(1))
9427       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9428 #endif
9429 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9430 c      s1=0.0d0
9431 c      s2=0.0d0
9432 c      s8=0.0d0
9433 c      s12=0.0d0
9434 c      s13=0.0d0
9435       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9436 C Derivatives in gamma(i+2)
9437       if (calc_grad) then
9438       s1d =0.0d0
9439       s8d =0.0d0
9440 #ifdef MOMENT
9441       call transpose2(AEA(1,1,1),auxmatd(1,1))
9442       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9443       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9444       call transpose2(AEAderg(1,1,2),atempd(1,1))
9445       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9446       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9447 #endif
9448       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9449       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9450       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9451 c      s1d=0.0d0
9452 c      s2d=0.0d0
9453 c      s8d=0.0d0
9454 c      s12d=0.0d0
9455 c      s13d=0.0d0
9456       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9457 C Derivatives in gamma(i+3)
9458 #ifdef MOMENT
9459       call transpose2(AEA(1,1,1),auxmatd(1,1))
9460       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9461       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9462       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9463 #endif
9464       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9465       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9466       s2d = scalar2(b1(1,k),vtemp1d(1))
9467 #ifdef MOMENT
9468       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9469       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9470 #endif
9471       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9472 #ifdef MOMENT
9473       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9474       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9475       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9476 #endif
9477 c      s1d=0.0d0
9478 c      s2d=0.0d0
9479 c      s8d=0.0d0
9480 c      s12d=0.0d0
9481 c      s13d=0.0d0
9482 #ifdef MOMENT
9483       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9484      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9485 #else
9486       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9487      &               -0.5d0*ekont*(s2d+s12d)
9488 #endif
9489 C Derivatives in gamma(i+4)
9490       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9491       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9492       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9493 #ifdef MOMENT
9494       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9495       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9496       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9497 #endif
9498 c      s1d=0.0d0
9499 c      s2d=0.0d0
9500 c      s8d=0.0d0
9501 C      s12d=0.0d0
9502 c      s13d=0.0d0
9503 #ifdef MOMENT
9504       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9505 #else
9506       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9507 #endif
9508 C Derivatives in gamma(i+5)
9509 #ifdef MOMENT
9510       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9511       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9512       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9513 #endif
9514       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9515       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9516       s2d = scalar2(b1(1,k),vtemp1d(1))
9517 #ifdef MOMENT
9518       call transpose2(AEA(1,1,2),atempd(1,1))
9519       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9520       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9521 #endif
9522       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9523       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9524 #ifdef MOMENT
9525       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9526       ss13d = scalar2(b1(1,k),vtemp4d(1))
9527       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9528 #endif
9529 c      s1d=0.0d0
9530 c      s2d=0.0d0
9531 c      s8d=0.0d0
9532 c      s12d=0.0d0
9533 c      s13d=0.0d0
9534 #ifdef MOMENT
9535       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9536      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9537 #else
9538       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9539      &               -0.5d0*ekont*(s2d+s12d)
9540 #endif
9541 C Cartesian derivatives
9542       do iii=1,2
9543         do kkk=1,5
9544           do lll=1,3
9545 #ifdef MOMENT
9546             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9547             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9548             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9549 #endif
9550             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9551             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9552      &          vtemp1d(1))
9553             s2d = scalar2(b1(1,k),vtemp1d(1))
9554 #ifdef MOMENT
9555             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9556             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9557             s8d = -(atempd(1,1)+atempd(2,2))*
9558      &           scalar2(cc(1,1,l),vtemp2(1))
9559 #endif
9560             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9561      &           auxmatd(1,1))
9562             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9563             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9564 c      s1d=0.0d0
9565 c      s2d=0.0d0
9566 c      s8d=0.0d0
9567 c      s12d=0.0d0
9568 c      s13d=0.0d0
9569 #ifdef MOMENT
9570             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9571      &        - 0.5d0*(s1d+s2d)
9572 #else
9573             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9574      &        - 0.5d0*s2d
9575 #endif
9576 #ifdef MOMENT
9577             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9578      &        - 0.5d0*(s8d+s12d)
9579 #else
9580             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9581      &        - 0.5d0*s12d
9582 #endif
9583           enddo
9584         enddo
9585       enddo
9586 #ifdef MOMENT
9587       do kkk=1,5
9588         do lll=1,3
9589           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9590      &      achuj_tempd(1,1))
9591           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9592           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9593           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9594           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9595           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9596      &      vtemp4d(1))
9597           ss13d = scalar2(b1(1,k),vtemp4d(1))
9598           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9599           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9600         enddo
9601       enddo
9602 #endif
9603 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9604 cd     &  16*eel_turn6_num
9605 cd      goto 1112
9606       if (j.lt.nres-1) then
9607         j1=j+1
9608         j2=j-1
9609       else
9610         j1=j-1
9611         j2=j-2
9612       endif
9613       if (l.lt.nres-1) then
9614         l1=l+1
9615         l2=l-1
9616       else
9617         l1=l-1
9618         l2=l-2
9619       endif
9620       do ll=1,3
9621 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9622 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9623 cgrad        ghalf=0.5d0*ggg1(ll)
9624 cd        ghalf=0.0d0
9625         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9626         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9627         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9628      &    +ekont*derx_turn(ll,2,1)
9629         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9630         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9631      &    +ekont*derx_turn(ll,4,1)
9632         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9633         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9634         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9635 cgrad        ghalf=0.5d0*ggg2(ll)
9636 cd        ghalf=0.0d0
9637         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9638      &    +ekont*derx_turn(ll,2,2)
9639         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9640         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9641      &    +ekont*derx_turn(ll,4,2)
9642         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9643         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9644         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9645       enddo
9646 cd      goto 1112
9647 cgrad      do m=i+1,j-1
9648 cgrad        do ll=1,3
9649 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9650 cgrad        enddo
9651 cgrad      enddo
9652 cgrad      do m=k+1,l-1
9653 cgrad        do ll=1,3
9654 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9655 cgrad        enddo
9656 cgrad      enddo
9657 cgrad1112  continue
9658 cgrad      do m=i+2,j2
9659 cgrad        do ll=1,3
9660 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9661 cgrad        enddo
9662 cgrad      enddo
9663 cgrad      do m=k+2,l2
9664 cgrad        do ll=1,3
9665 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9666 cgrad        enddo
9667 cgrad      enddo
9668 cd      do iii=1,nres-3
9669 cd        write (2,*) iii,g_corr6_loc(iii)
9670 cd      enddo
9671       endif ! calc_grad
9672       eello_turn6=ekont*eel_turn6
9673 cd      write (2,*) 'ekont',ekont
9674 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9675       return
9676       end
9677 #endif
9678 crc-------------------------------------------------
9679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9680       subroutine Eliptransfer(eliptran)
9681       implicit real*8 (a-h,o-z)
9682       include 'DIMENSIONS'
9683       include 'DIMENSIONS.ZSCOPT'
9684       include 'COMMON.GEO'
9685       include 'COMMON.VAR'
9686       include 'COMMON.LOCAL'
9687       include 'COMMON.CHAIN'
9688       include 'COMMON.DERIV'
9689       include 'COMMON.INTERACT'
9690       include 'COMMON.IOUNITS'
9691       include 'COMMON.CALC'
9692       include 'COMMON.CONTROL'
9693       include 'COMMON.SPLITELE'
9694       include 'COMMON.SBRIDGE'
9695 C this is done by Adasko
9696 C      print *,"wchodze"
9697 C structure of box:
9698 C      water
9699 C--bordliptop-- buffore starts
9700 C--bufliptop--- here true lipid starts
9701 C      lipid
9702 C--buflipbot--- lipid ends buffore starts
9703 C--bordlipbot--buffore ends
9704       eliptran=0.0
9705       do i=1,nres
9706 C       do i=1,1
9707         if (itype(i).eq.ntyp1) cycle
9708
9709         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9710         if (positi.le.0) positi=positi+boxzsize
9711 C        print *,i
9712 C first for peptide groups
9713 c for each residue check if it is in lipid or lipid water border area
9714        if ((positi.gt.bordlipbot)
9715      &.and.(positi.lt.bordliptop)) then
9716 C the energy transfer exist
9717         if (positi.lt.buflipbot) then
9718 C what fraction I am in
9719          fracinbuf=1.0d0-
9720      &        ((positi-bordlipbot)/lipbufthick)
9721 C lipbufthick is thickenes of lipid buffore
9722          sslip=sscalelip(fracinbuf)
9723          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9724          eliptran=eliptran+sslip*pepliptran
9725          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9726          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9727 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9728         elseif (positi.gt.bufliptop) then
9729          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9730          sslip=sscalelip(fracinbuf)
9731          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9732          eliptran=eliptran+sslip*pepliptran
9733          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9734          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9735 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9736 C          print *, "doing sscalefor top part"
9737 C         print *,i,sslip,fracinbuf,ssgradlip
9738         else
9739          eliptran=eliptran+pepliptran
9740 C         print *,"I am in true lipid"
9741         endif
9742 C       else
9743 C       eliptran=elpitran+0.0 ! I am in water
9744        endif
9745        enddo
9746 C       print *, "nic nie bylo w lipidzie?"
9747 C now multiply all by the peptide group transfer factor
9748 C       eliptran=eliptran*pepliptran
9749 C now the same for side chains
9750 CV       do i=1,1
9751        do i=1,nres
9752         if (itype(i).eq.ntyp1) cycle
9753         positi=(mod(c(3,i+nres),boxzsize))
9754         if (positi.le.0) positi=positi+boxzsize
9755 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9756 c for each residue check if it is in lipid or lipid water border area
9757 C       respos=mod(c(3,i+nres),boxzsize)
9758 C       print *,positi,bordlipbot,buflipbot
9759        if ((positi.gt.bordlipbot)
9760      & .and.(positi.lt.bordliptop)) then
9761 C the energy transfer exist
9762         if (positi.lt.buflipbot) then
9763          fracinbuf=1.0d0-
9764      &     ((positi-bordlipbot)/lipbufthick)
9765 C lipbufthick is thickenes of lipid buffore
9766          sslip=sscalelip(fracinbuf)
9767          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9768          eliptran=eliptran+sslip*liptranene(itype(i))
9769          gliptranx(3,i)=gliptranx(3,i)
9770      &+ssgradlip*liptranene(itype(i))
9771          gliptranc(3,i-1)= gliptranc(3,i-1)
9772      &+ssgradlip*liptranene(itype(i))
9773 C         print *,"doing sccale for lower part"
9774         elseif (positi.gt.bufliptop) then
9775          fracinbuf=1.0d0-
9776      &((bordliptop-positi)/lipbufthick)
9777          sslip=sscalelip(fracinbuf)
9778          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9779          eliptran=eliptran+sslip*liptranene(itype(i))
9780          gliptranx(3,i)=gliptranx(3,i)
9781      &+ssgradlip*liptranene(itype(i))
9782          gliptranc(3,i-1)= gliptranc(3,i-1)
9783      &+ssgradlip*liptranene(itype(i))
9784 C          print *, "doing sscalefor top part",sslip,fracinbuf
9785         else
9786          eliptran=eliptran+liptranene(itype(i))
9787 C         print *,"I am in true lipid"
9788         endif
9789         endif ! if in lipid or buffor
9790 C       else
9791 C       eliptran=elpitran+0.0 ! I am in water
9792        enddo
9793        return
9794        end
9795
9796
9797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9798
9799       SUBROUTINE MATVEC2(A1,V1,V2)
9800       implicit real*8 (a-h,o-z)
9801       include 'DIMENSIONS'
9802       DIMENSION A1(2,2),V1(2),V2(2)
9803 c      DO 1 I=1,2
9804 c        VI=0.0
9805 c        DO 3 K=1,2
9806 c    3     VI=VI+A1(I,K)*V1(K)
9807 c        Vaux(I)=VI
9808 c    1 CONTINUE
9809
9810       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9811       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9812
9813       v2(1)=vaux1
9814       v2(2)=vaux2
9815       END
9816 C---------------------------------------
9817       SUBROUTINE MATMAT2(A1,A2,A3)
9818       implicit real*8 (a-h,o-z)
9819       include 'DIMENSIONS'
9820       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9821 c      DIMENSION AI3(2,2)
9822 c        DO  J=1,2
9823 c          A3IJ=0.0
9824 c          DO K=1,2
9825 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9826 c          enddo
9827 c          A3(I,J)=A3IJ
9828 c       enddo
9829 c      enddo
9830
9831       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9832       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9833       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9834       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9835
9836       A3(1,1)=AI3_11
9837       A3(2,1)=AI3_21
9838       A3(1,2)=AI3_12
9839       A3(2,2)=AI3_22
9840       END
9841
9842 c-------------------------------------------------------------------------
9843       double precision function scalar2(u,v)
9844       implicit none
9845       double precision u(2),v(2)
9846       double precision sc
9847       integer i
9848       scalar2=u(1)*v(1)+u(2)*v(2)
9849       return
9850       end
9851
9852 C-----------------------------------------------------------------------------
9853
9854       subroutine transpose2(a,at)
9855       implicit none
9856       double precision a(2,2),at(2,2)
9857       at(1,1)=a(1,1)
9858       at(1,2)=a(2,1)
9859       at(2,1)=a(1,2)
9860       at(2,2)=a(2,2)
9861       return
9862       end
9863 c--------------------------------------------------------------------------
9864       subroutine transpose(n,a,at)
9865       implicit none
9866       integer n,i,j
9867       double precision a(n,n),at(n,n)
9868       do i=1,n
9869         do j=1,n
9870           at(j,i)=a(i,j)
9871         enddo
9872       enddo
9873       return
9874       end
9875 C---------------------------------------------------------------------------
9876       subroutine prodmat3(a1,a2,kk,transp,prod)
9877       implicit none
9878       integer i,j
9879       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9880       logical transp
9881 crc      double precision auxmat(2,2),prod_(2,2)
9882
9883       if (transp) then
9884 crc        call transpose2(kk(1,1),auxmat(1,1))
9885 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9886 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9887
9888            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9889      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9890            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9891      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9892            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9893      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9894            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9895      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9896
9897       else
9898 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9899 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9900
9901            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9902      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9903            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9904      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9905            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9906      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9907            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9908      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9909
9910       endif
9911 c      call transpose2(a2(1,1),a2t(1,1))
9912
9913 crc      print *,transp
9914 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9915 crc      print *,((prod(i,j),i=1,2),j=1,2)
9916
9917       return
9918       end
9919 C-----------------------------------------------------------------------------
9920       double precision function scalar(u,v)
9921       implicit none
9922       double precision u(3),v(3)
9923       double precision sc
9924       integer i
9925       sc=0.0d0
9926       do i=1,3
9927         sc=sc+u(i)*v(i)
9928       enddo
9929       scalar=sc
9930       return
9931       end
9932 C-----------------------------------------------------------------------
9933       double precision function sscale(r)
9934       double precision r,gamm
9935       include "COMMON.SPLITELE"
9936       if(r.lt.r_cut-rlamb) then
9937         sscale=1.0d0
9938       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9939         gamm=(r-(r_cut-rlamb))/rlamb
9940         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9941       else
9942         sscale=0d0
9943       endif
9944       return
9945       end
9946 C-----------------------------------------------------------------------
9947 C-----------------------------------------------------------------------
9948       double precision function sscagrad(r)
9949       double precision r,gamm
9950       include "COMMON.SPLITELE"
9951       if(r.lt.r_cut-rlamb) then
9952         sscagrad=0.0d0
9953       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9954         gamm=(r-(r_cut-rlamb))/rlamb
9955         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9956       else
9957         sscagrad=0.0d0
9958       endif
9959       return
9960       end
9961 C-----------------------------------------------------------------------
9962 C-----------------------------------------------------------------------
9963       double precision function sscalelip(r)
9964       double precision r,gamm
9965       include "COMMON.SPLITELE"
9966 C      if(r.lt.r_cut-rlamb) then
9967 C        sscale=1.0d0
9968 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9969 C        gamm=(r-(r_cut-rlamb))/rlamb
9970         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9971 C      else
9972 C        sscale=0d0
9973 C      endif
9974       return
9975       end
9976 C-----------------------------------------------------------------------
9977       double precision function sscagradlip(r)
9978       double precision r,gamm
9979       include "COMMON.SPLITELE"
9980 C     if(r.lt.r_cut-rlamb) then
9981 C        sscagrad=0.0d0
9982 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9983 C        gamm=(r-(r_cut-rlamb))/rlamb
9984         sscagradlip=r*(6*r-6.0d0)
9985 C      else
9986 C        sscagrad=0.0d0
9987 C      endif
9988       return
9989       end
9990
9991 C-----------------------------------------------------------------------
9992        subroutine set_shield_fac
9993       implicit real*8 (a-h,o-z)
9994       include 'DIMENSIONS'
9995       include 'DIMENSIONS.ZSCOPT'
9996       include 'COMMON.CHAIN'
9997       include 'COMMON.DERIV'
9998       include 'COMMON.IOUNITS'
9999       include 'COMMON.SHIELD'
10000       include 'COMMON.INTERACT'
10001 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10002       double precision div77_81/0.974996043d0/,
10003      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10004
10005 C the vector between center of side_chain and peptide group
10006        double precision pep_side(3),long,side_calf(3),
10007      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10008      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10009 C the line belowe needs to be changed for FGPROC>1
10010       do i=1,nres-1
10011       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10012       ishield_list(i)=0
10013 Cif there two consequtive dummy atoms there is no peptide group between them
10014 C the line below has to be changed for FGPROC>1
10015       VolumeTotal=0.0
10016       do k=1,nres
10017        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10018        dist_pep_side=0.0
10019        dist_side_calf=0.0
10020        do j=1,3
10021 C first lets set vector conecting the ithe side-chain with kth side-chain
10022       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10023 C      pep_side(j)=2.0d0
10024 C and vector conecting the side-chain with its proper calfa
10025       side_calf(j)=c(j,k+nres)-c(j,k)
10026 C      side_calf(j)=2.0d0
10027       pept_group(j)=c(j,i)-c(j,i+1)
10028 C lets have their lenght
10029       dist_pep_side=pep_side(j)**2+dist_pep_side
10030       dist_side_calf=dist_side_calf+side_calf(j)**2
10031       dist_pept_group=dist_pept_group+pept_group(j)**2
10032       enddo
10033        dist_pep_side=dsqrt(dist_pep_side)
10034        dist_pept_group=dsqrt(dist_pept_group)
10035        dist_side_calf=dsqrt(dist_side_calf)
10036       do j=1,3
10037         pep_side_norm(j)=pep_side(j)/dist_pep_side
10038         side_calf_norm(j)=dist_side_calf
10039       enddo
10040 C now sscale fraction
10041        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10042 C       print *,buff_shield,"buff"
10043 C now sscale
10044         if (sh_frac_dist.le.0.0) cycle
10045 C If we reach here it means that this side chain reaches the shielding sphere
10046 C Lets add him to the list for gradient
10047         ishield_list(i)=ishield_list(i)+1
10048 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10049 C this list is essential otherwise problem would be O3
10050         shield_list(ishield_list(i),i)=k
10051 C Lets have the sscale value
10052         if (sh_frac_dist.gt.1.0) then
10053          scale_fac_dist=1.0d0
10054          do j=1,3
10055          sh_frac_dist_grad(j)=0.0d0
10056          enddo
10057         else
10058          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10059      &                   *(2.0*sh_frac_dist-3.0d0)
10060          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10061      &                  /dist_pep_side/buff_shield*0.5
10062 C remember for the final gradient multiply sh_frac_dist_grad(j)
10063 C for side_chain by factor -2 !
10064          do j=1,3
10065          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10066 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10067 C     &                    sh_frac_dist_grad(j)
10068          enddo
10069         endif
10070 C        if ((i.eq.3).and.(k.eq.2)) then
10071 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10072 C     & ,"TU"
10073 C        endif
10074
10075 C this is what is now we have the distance scaling now volume...
10076       short=short_r_sidechain(itype(k))
10077       long=long_r_sidechain(itype(k))
10078       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10079 C now costhet_grad
10080 C       costhet=0.0d0
10081        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10082 C       costhet_fac=0.0d0
10083        do j=1,3
10084          costhet_grad(j)=costhet_fac*pep_side(j)
10085        enddo
10086 C remember for the final gradient multiply costhet_grad(j)
10087 C for side_chain by factor -2 !
10088 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10089 C pep_side0pept_group is vector multiplication
10090       pep_side0pept_group=0.0
10091       do j=1,3
10092       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10093       enddo
10094       cosalfa=(pep_side0pept_group/
10095      & (dist_pep_side*dist_side_calf))
10096       fac_alfa_sin=1.0-cosalfa**2
10097       fac_alfa_sin=dsqrt(fac_alfa_sin)
10098       rkprim=fac_alfa_sin*(long-short)+short
10099 C now costhet_grad
10100        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10101        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10102
10103        do j=1,3
10104          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10105      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10106      &*(long-short)/fac_alfa_sin*cosalfa/
10107      &((dist_pep_side*dist_side_calf))*
10108      &((side_calf(j))-cosalfa*
10109      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10110
10111         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10112      &*(long-short)/fac_alfa_sin*cosalfa
10113      &/((dist_pep_side*dist_side_calf))*
10114      &(pep_side(j)-
10115      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10116        enddo
10117
10118       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10119      &                    /VSolvSphere_div
10120      &                    *wshield
10121 C now the gradient...
10122 C grad_shield is gradient of Calfa for peptide groups
10123 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10124 C     &               costhet,cosphi
10125 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10126 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10127       do j=1,3
10128       grad_shield(j,i)=grad_shield(j,i)
10129 C gradient po skalowaniu
10130      &                +(sh_frac_dist_grad(j)
10131 C  gradient po costhet
10132      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10133      &-scale_fac_dist*(cosphi_grad_long(j))
10134      &/(1.0-cosphi) )*div77_81
10135      &*VofOverlap
10136 C grad_shield_side is Cbeta sidechain gradient
10137       grad_shield_side(j,ishield_list(i),i)=
10138      &        (sh_frac_dist_grad(j)*(-2.0d0)
10139      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10140      &       +scale_fac_dist*(cosphi_grad_long(j))
10141      &        *2.0d0/(1.0-cosphi))
10142      &        *div77_81*VofOverlap
10143
10144        grad_shield_loc(j,ishield_list(i),i)=
10145      &   scale_fac_dist*cosphi_grad_loc(j)
10146      &        *2.0d0/(1.0-cosphi)
10147      &        *div77_81*VofOverlap
10148       enddo
10149       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10150       enddo
10151       fac_shield(i)=VolumeTotal*div77_81+div4_81
10152 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10153       enddo
10154       return
10155       end
10156 C--------------------------------------------------------------------------
10157 C first for shielding is setting of function of side-chains
10158        subroutine set_shield_fac2
10159       implicit real*8 (a-h,o-z)
10160       include 'DIMENSIONS'
10161       include 'DIMENSIONS.ZSCOPT'
10162       include 'COMMON.CHAIN'
10163       include 'COMMON.DERIV'
10164       include 'COMMON.IOUNITS'
10165       include 'COMMON.SHIELD'
10166       include 'COMMON.INTERACT'
10167 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10168       double precision div77_81/0.974996043d0/,
10169      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10170
10171 C the vector between center of side_chain and peptide group
10172        double precision pep_side(3),long,side_calf(3),
10173      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10174      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10175 C the line belowe needs to be changed for FGPROC>1
10176       do i=1,nres-1
10177       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10178       ishield_list(i)=0
10179 Cif there two consequtive dummy atoms there is no peptide group between them
10180 C the line below has to be changed for FGPROC>1
10181       VolumeTotal=0.0
10182       do k=1,nres
10183        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10184        dist_pep_side=0.0
10185        dist_side_calf=0.0
10186        do j=1,3
10187 C first lets set vector conecting the ithe side-chain with kth side-chain
10188       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10189 C      pep_side(j)=2.0d0
10190 C and vector conecting the side-chain with its proper calfa
10191       side_calf(j)=c(j,k+nres)-c(j,k)
10192 C      side_calf(j)=2.0d0
10193       pept_group(j)=c(j,i)-c(j,i+1)
10194 C lets have their lenght
10195       dist_pep_side=pep_side(j)**2+dist_pep_side
10196       dist_side_calf=dist_side_calf+side_calf(j)**2
10197       dist_pept_group=dist_pept_group+pept_group(j)**2
10198       enddo
10199        dist_pep_side=dsqrt(dist_pep_side)
10200        dist_pept_group=dsqrt(dist_pept_group)
10201        dist_side_calf=dsqrt(dist_side_calf)
10202       do j=1,3
10203         pep_side_norm(j)=pep_side(j)/dist_pep_side
10204         side_calf_norm(j)=dist_side_calf
10205       enddo
10206 C now sscale fraction
10207        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10208 C       print *,buff_shield,"buff"
10209 C now sscale
10210         if (sh_frac_dist.le.0.0) cycle
10211 C If we reach here it means that this side chain reaches the shielding sphere
10212 C Lets add him to the list for gradient
10213         ishield_list(i)=ishield_list(i)+1
10214 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10215 C this list is essential otherwise problem would be O3
10216         shield_list(ishield_list(i),i)=k
10217 C Lets have the sscale value
10218         if (sh_frac_dist.gt.1.0) then
10219          scale_fac_dist=1.0d0
10220          do j=1,3
10221          sh_frac_dist_grad(j)=0.0d0
10222          enddo
10223         else
10224          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10225      &                   *(2.0d0*sh_frac_dist-3.0d0)
10226          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10227      &                  /dist_pep_side/buff_shield*0.5d0
10228 C remember for the final gradient multiply sh_frac_dist_grad(j)
10229 C for side_chain by factor -2 !
10230          do j=1,3
10231          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10232 C         sh_frac_dist_grad(j)=0.0d0
10233 C         scale_fac_dist=1.0d0
10234 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10235 C     &                    sh_frac_dist_grad(j)
10236          enddo
10237         endif
10238 C this is what is now we have the distance scaling now volume...
10239       short=short_r_sidechain(itype(k))
10240       long=long_r_sidechain(itype(k))
10241       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10242       sinthet=short/dist_pep_side*costhet
10243 C now costhet_grad
10244 C       costhet=0.6d0
10245 C       sinthet=0.8
10246        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10247 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10248 C     &             -short/dist_pep_side**2/costhet)
10249 C       costhet_fac=0.0d0
10250        do j=1,3
10251          costhet_grad(j)=costhet_fac*pep_side(j)
10252        enddo
10253 C remember for the final gradient multiply costhet_grad(j)
10254 C for side_chain by factor -2 !
10255 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10256 C pep_side0pept_group is vector multiplication
10257       pep_side0pept_group=0.0d0
10258       do j=1,3
10259       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10260       enddo
10261       cosalfa=(pep_side0pept_group/
10262      & (dist_pep_side*dist_side_calf))
10263       fac_alfa_sin=1.0d0-cosalfa**2
10264       fac_alfa_sin=dsqrt(fac_alfa_sin)
10265       rkprim=fac_alfa_sin*(long-short)+short
10266 C      rkprim=short
10267
10268 C now costhet_grad
10269        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10270 C       cosphi=0.6
10271        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10272        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10273      &      dist_pep_side**2)
10274 C       sinphi=0.8
10275        do j=1,3
10276          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10277      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10278      &*(long-short)/fac_alfa_sin*cosalfa/
10279      &((dist_pep_side*dist_side_calf))*
10280      &((side_calf(j))-cosalfa*
10281      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10282 C       cosphi_grad_long(j)=0.0d0
10283         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10284      &*(long-short)/fac_alfa_sin*cosalfa
10285      &/((dist_pep_side*dist_side_calf))*
10286      &(pep_side(j)-
10287      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10288 C       cosphi_grad_loc(j)=0.0d0
10289        enddo
10290 C      print *,sinphi,sinthet
10291       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10292      &                    /VSolvSphere_div
10293 C     &                    *wshield
10294 C now the gradient...
10295       do j=1,3
10296       grad_shield(j,i)=grad_shield(j,i)
10297 C gradient po skalowaniu
10298      &                +(sh_frac_dist_grad(j)*VofOverlap
10299 C  gradient po costhet
10300      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10301      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10302      &       sinphi/sinthet*costhet*costhet_grad(j)
10303      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10304      & )*wshield
10305 C grad_shield_side is Cbeta sidechain gradient
10306       grad_shield_side(j,ishield_list(i),i)=
10307      &        (sh_frac_dist_grad(j)*(-2.0d0)
10308      &        *VofOverlap
10309      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10310      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10311      &       sinphi/sinthet*costhet*costhet_grad(j)
10312      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10313      &       )*wshield
10314
10315        grad_shield_loc(j,ishield_list(i),i)=
10316      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10317      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10318      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10319      &        ))
10320      &        *wshield
10321       enddo
10322       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10323       enddo
10324       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10325 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10326 c     &  " wshield",wshield
10327 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10328       enddo
10329       return
10330       end
10331 C--------------------------------------------------------------------------
10332       double precision function tschebyshev(m,n,x,y)
10333       implicit none
10334       include "DIMENSIONS"
10335       integer i,m,n
10336       double precision x(n),y,yy(0:maxvar),aux
10337 c Tschebyshev polynomial. Note that the first term is omitted
10338 c m=0: the constant term is included
10339 c m=1: the constant term is not included
10340       yy(0)=1.0d0
10341       yy(1)=y
10342       do i=2,n
10343         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10344       enddo
10345       aux=0.0d0
10346       do i=m,n
10347         aux=aux+x(i)*yy(i)
10348       enddo
10349       tschebyshev=aux
10350       return
10351       end
10352 C--------------------------------------------------------------------------
10353       double precision function gradtschebyshev(m,n,x,y)
10354       implicit none
10355       include "DIMENSIONS"
10356       integer i,m,n
10357       double precision x(n+1),y,yy(0:maxvar),aux
10358 c Tschebyshev polynomial. Note that the first term is omitted
10359 c m=0: the constant term is included
10360 c m=1: the constant term is not included
10361       yy(0)=1.0d0
10362       yy(1)=2.0d0*y
10363       do i=2,n
10364         yy(i)=2*y*yy(i-1)-yy(i-2)
10365       enddo
10366       aux=0.0d0
10367       do i=m,n
10368         aux=aux+x(i+1)*yy(i)*(i+1)
10369 C        print *, x(i+1),yy(i),i
10370       enddo
10371       gradtschebyshev=aux
10372       return
10373       end
10374 c----------------------------------------------------------------------------
10375       double precision function sscale2(r,r_cut,r0,rlamb)
10376       implicit none
10377       double precision r,gamm,r_cut,r0,rlamb,rr
10378       rr = dabs(r-r0)
10379 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10380 c      write (2,*) "rr",rr
10381       if(rr.lt.r_cut-rlamb) then
10382         sscale2=1.0d0
10383       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10384         gamm=(rr-(r_cut-rlamb))/rlamb
10385         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10386       else
10387         sscale2=0d0
10388       endif
10389       return
10390       end
10391 C-----------------------------------------------------------------------
10392       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10393       implicit none
10394       double precision r,gamm,r_cut,r0,rlamb,rr
10395       rr = dabs(r-r0)
10396       if(rr.lt.r_cut-rlamb) then
10397         sscalgrad2=0.0d0
10398       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10399         gamm=(rr-(r_cut-rlamb))/rlamb
10400         if (r.ge.r0) then
10401           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10402         else
10403           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10404         endif
10405       else
10406         sscalgrad2=0.0d0
10407       endif
10408       return
10409       end
10410 c----------------------------------------------------------------------------
10411       subroutine e_saxs(Esaxs_constr)
10412       implicit none
10413       include 'DIMENSIONS'
10414       include 'DIMENSIONS.ZSCOPT'
10415       include 'DIMENSIONS.FREE'
10416 #ifdef MPI
10417       include "mpif.h"
10418       include "COMMON.SETUP"
10419       integer IERR
10420 #endif
10421       include 'COMMON.SBRIDGE'
10422       include 'COMMON.CHAIN'
10423       include 'COMMON.GEO'
10424       include 'COMMON.LOCAL'
10425       include 'COMMON.INTERACT'
10426       include 'COMMON.VAR'
10427       include 'COMMON.IOUNITS'
10428       include 'COMMON.DERIV'
10429       include 'COMMON.CONTROL'
10430       include 'COMMON.NAMES'
10431       include 'COMMON.FFIELD'
10432       include 'COMMON.LANGEVIN'
10433       include 'COMMON.SAXS'
10434 c
10435       double precision Esaxs_constr
10436       integer i,iint,j,k,l
10437       double precision PgradC(maxSAXS,3,maxres),
10438      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10439 #ifdef MPI
10440       double precision PgradC_(maxSAXS,3,maxres),
10441      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10442 #endif
10443       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10444      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10445      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10446      & auxX,auxX1,CACAgrad,Cnorm
10447       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10448       double precision dist
10449       external dist
10450 c  SAXS restraint penalty function
10451 #ifdef DEBUG
10452       write(iout,*) "------- SAXS penalty function start -------"
10453       write (iout,*) "nsaxs",nsaxs
10454       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10455       write (iout,*) "Psaxs"
10456       do i=1,nsaxs
10457         write (iout,'(i5,e15.5)') i, Psaxs(i)
10458       enddo
10459 #endif
10460       Esaxs_constr = 0.0d0
10461       do k=1,nsaxs
10462         Pcalc(k)=0.0d0
10463         do j=1,nres
10464           do l=1,3
10465             PgradC(k,l,j)=0.0d0
10466             PgradX(k,l,j)=0.0d0
10467           enddo
10468         enddo
10469       enddo
10470       do i=iatsc_s,iatsc_e
10471        if (itype(i).eq.ntyp1) cycle
10472        do iint=1,nint_gr(i)
10473          do j=istart(i,iint),iend(i,iint)
10474            if (itype(j).eq.ntyp1) cycle
10475 #ifdef ALLSAXS
10476            dijCACA=dist(i,j)
10477            dijCASC=dist(i,j+nres)
10478            dijSCCA=dist(i+nres,j)
10479            dijSCSC=dist(i+nres,j+nres)
10480            sigma2CACA=2.0d0/(pstok**2)
10481            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10482            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10483            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10484            do k=1,nsaxs
10485              dk = distsaxs(k)
10486              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10487              if (itype(j).ne.10) then
10488              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10489              else
10490              endif
10491              expCASC = 0.0d0
10492              if (itype(i).ne.10) then
10493              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10494              else
10495              expSCCA = 0.0d0
10496              endif
10497              if (itype(i).ne.10 .and. itype(j).ne.10) then
10498              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10499              else
10500              expSCSC = 0.0d0
10501              endif
10502              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10503 #ifdef DEBUG
10504              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10505 #endif
10506              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10507              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10508              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10509              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10510              do l=1,3
10511 c CA CA
10512                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10513                PgradC(k,l,i) = PgradC(k,l,i)-aux
10514                PgradC(k,l,j) = PgradC(k,l,j)+aux
10515 c CA SC
10516                if (itype(j).ne.10) then
10517                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10518                PgradC(k,l,i) = PgradC(k,l,i)-aux
10519                PgradC(k,l,j) = PgradC(k,l,j)+aux
10520                PgradX(k,l,j) = PgradX(k,l,j)+aux
10521                endif
10522 c SC CA
10523                if (itype(i).ne.10) then
10524                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10525                PgradX(k,l,i) = PgradX(k,l,i)-aux
10526                PgradC(k,l,i) = PgradC(k,l,i)-aux
10527                PgradC(k,l,j) = PgradC(k,l,j)+aux
10528                endif
10529 c SC SC
10530                if (itype(i).ne.10 .and. itype(j).ne.10) then
10531                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10532                PgradC(k,l,i) = PgradC(k,l,i)-aux
10533                PgradC(k,l,j) = PgradC(k,l,j)+aux
10534                PgradX(k,l,i) = PgradX(k,l,i)-aux
10535                PgradX(k,l,j) = PgradX(k,l,j)+aux
10536                endif
10537              enddo ! l
10538            enddo ! k
10539 #else
10540            dijCACA=dist(i,j)
10541            sigma2CACA=scal_rad**2*0.25d0/
10542      &        (restok(itype(j))**2+restok(itype(i))**2)
10543
10544            IF (saxs_cutoff.eq.0) THEN
10545            do k=1,nsaxs
10546              dk = distsaxs(k)
10547              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10548              Pcalc(k) = Pcalc(k)+expCACA
10549              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10550              do l=1,3
10551                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10552                PgradC(k,l,i) = PgradC(k,l,i)-aux
10553                PgradC(k,l,j) = PgradC(k,l,j)+aux
10554              enddo ! l
10555            enddo ! k
10556            ELSE
10557            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10558            do k=1,nsaxs
10559              dk = distsaxs(k)
10560 c             write (2,*) "ijk",i,j,k
10561              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10562              if (sss2.eq.0.0d0) cycle
10563              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10564              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10565              Pcalc(k) = Pcalc(k)+expCACA
10566 #ifdef DEBUG
10567              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10568 #endif
10569              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10570      &             ssgrad2*expCACA/sss2
10571              do l=1,3
10572 c CA CA
10573                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10574                PgradC(k,l,i) = PgradC(k,l,i)+aux
10575                PgradC(k,l,j) = PgradC(k,l,j)-aux
10576              enddo ! l
10577            enddo ! k
10578            ENDIF
10579 #endif
10580          enddo ! j
10581        enddo ! iint
10582       enddo ! i
10583 #ifdef MPI
10584       if (nfgtasks.gt.1) then
10585         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10586      &    MPI_SUM,king,FG_COMM,IERR)
10587         if (fg_rank.eq.king) then
10588           do k=1,nsaxs
10589             Pcalc(k) = Pcalc_(k)
10590           enddo
10591         endif
10592         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10593      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10594         if (fg_rank.eq.king) then
10595           do i=1,nres
10596             do l=1,3
10597               do k=1,nsaxs
10598                 PgradC(k,l,i) = PgradC_(k,l,i)
10599               enddo
10600             enddo
10601           enddo
10602         endif
10603 #ifdef ALLSAXS
10604         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10605      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10606         if (fg_rank.eq.king) then
10607           do i=1,nres
10608             do l=1,3
10609               do k=1,nsaxs
10610                 PgradX(k,l,i) = PgradX_(k,l,i)
10611               enddo
10612             enddo
10613           enddo
10614         endif
10615 #endif
10616       endif
10617 #endif
10618 #ifdef MPI
10619       if (fg_rank.eq.king) then
10620 #endif
10621       Cnorm = 0.0d0
10622       do k=1,nsaxs
10623         Cnorm = Cnorm + Pcalc(k)
10624       enddo
10625       Esaxs_constr = dlog(Cnorm)-wsaxs0
10626       do k=1,nsaxs
10627         if (Pcalc(k).gt.0.0d0)
10628      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10629 #ifdef DEBUG
10630         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10631 #endif
10632       enddo
10633 #ifdef DEBUG
10634       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10635 #endif
10636       do i=nnt,nct
10637         do l=1,3
10638           auxC=0.0d0
10639           auxC1=0.0d0
10640           auxX=0.0d0
10641           auxX1=0.d0
10642           do k=1,nsaxs
10643             if (Pcalc(k).gt.0)
10644      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10645             auxC1 = auxC1+PgradC(k,l,i)
10646 #ifdef ALLSAXS
10647             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10648             auxX1 = auxX1+PgradX(k,l,i)
10649 #endif
10650           enddo
10651           gsaxsC(l,i) = auxC - auxC1/Cnorm
10652 #ifdef ALLSAXS
10653           gsaxsX(l,i) = auxX - auxX1/Cnorm
10654 #endif
10655 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10656 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10657         enddo
10658       enddo
10659 #ifdef MPI
10660       endif
10661 #endif
10662       return
10663       end
10664 c----------------------------------------------------------------------------
10665       subroutine e_saxsC(Esaxs_constr)
10666       implicit none
10667       include 'DIMENSIONS'
10668       include 'DIMENSIONS.ZSCOPT'
10669       include 'DIMENSIONS.FREE'
10670 #ifdef MPI
10671       include "mpif.h"
10672       include "COMMON.SETUP"
10673       integer IERR
10674 #endif
10675       include 'COMMON.SBRIDGE'
10676       include 'COMMON.CHAIN'
10677       include 'COMMON.GEO'
10678       include 'COMMON.LOCAL'
10679       include 'COMMON.INTERACT'
10680       include 'COMMON.VAR'
10681       include 'COMMON.IOUNITS'
10682       include 'COMMON.DERIV'
10683       include 'COMMON.CONTROL'
10684       include 'COMMON.NAMES'
10685       include 'COMMON.FFIELD'
10686       include 'COMMON.LANGEVIN'
10687       include 'COMMON.SAXS'
10688 c
10689       double precision Esaxs_constr
10690       integer i,iint,j,k,l
10691       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10692 #ifdef MPI
10693       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10694 #endif
10695       double precision dk,dijCASPH,dijSCSPH,
10696      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10697      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10698      & auxX,auxX1,Cnorm
10699 c  SAXS restraint penalty function
10700 #ifdef DEBUG
10701       write(iout,*) "------- SAXS penalty function start -------"
10702       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10703      & " isaxs_end",isaxs_end
10704       write (iout,*) "nnt",nnt," ntc",nct
10705       do i=nnt,nct
10706         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10707      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10708       enddo
10709       do i=nnt,nct
10710         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10711       enddo
10712 #endif
10713       Esaxs_constr = 0.0d0
10714       logPtot=0.0d0
10715       do j=isaxs_start,isaxs_end
10716         Pcalc=0.0d0
10717         do i=1,nres
10718           do l=1,3
10719             PgradC(l,i)=0.0d0
10720             PgradX(l,i)=0.0d0
10721           enddo
10722         enddo
10723         do i=nnt,nct
10724           dijCASPH=0.0d0
10725           dijSCSPH=0.0d0
10726           do l=1,3
10727             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10728           enddo
10729           if (itype(i).ne.10) then
10730           do l=1,3
10731             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10732           enddo
10733           endif
10734           sigma2CA=2.0d0/pstok**2
10735           sigma2SC=4.0d0/restok(itype(i))**2
10736           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10737           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10738           Pcalc = Pcalc+expCASPH+expSCSPH
10739 #ifdef DEBUG
10740           write(*,*) "processor i j Pcalc",
10741      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10742 #endif
10743           CASPHgrad = sigma2CA*expCASPH
10744           SCSPHgrad = sigma2SC*expSCSPH
10745           do l=1,3
10746             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10747             PgradX(l,i) = PgradX(l,i) + aux
10748             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10749           enddo ! l
10750         enddo ! i
10751         do i=nnt,nct
10752           do l=1,3
10753             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10754             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10755           enddo
10756         enddo
10757         logPtot = logPtot - dlog(Pcalc)
10758 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10759 c     &    " logPtot",logPtot
10760       enddo ! j
10761 #ifdef MPI
10762       if (nfgtasks.gt.1) then
10763 c        write (iout,*) "logPtot before reduction",logPtot
10764         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10765      &    MPI_SUM,king,FG_COMM,IERR)
10766         logPtot = logPtot_
10767 c        write (iout,*) "logPtot after reduction",logPtot
10768         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10769      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10770         if (fg_rank.eq.king) then
10771           do i=1,nres
10772             do l=1,3
10773               gsaxsC(l,i) = gsaxsC_(l,i)
10774             enddo
10775           enddo
10776         endif
10777         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10778      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10779         if (fg_rank.eq.king) then
10780           do i=1,nres
10781             do l=1,3
10782               gsaxsX(l,i) = gsaxsX_(l,i)
10783             enddo
10784           enddo
10785         endif
10786       endif
10787 #endif
10788       Esaxs_constr = logPtot
10789       return
10790       end
10791