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 cu        if (i.eq.3) then
5578 cu          phii=0.0d0
5579 cu          ityp1=nthetyp+1
5580 cu          do k=1,nsingle
5581 cu            cosph1(k)=0.0d0
5582 cu            sinph1(k)=0.0d0
5583 cu          enddo
5584 cu        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         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5607 #ifdef OSF
5608           phii1=phi(i+1)
5609           if (phii1.ne.phii1) phii1=150.0
5610           phii1=pinorm(phii1)
5611 #else
5612           phii1=phi(i+1)
5613 #endif
5614           ityp3=ithetyp((itype(i)))
5615           do k=1,nsingle
5616             cosph2(k)=dcos(k*phii1)
5617             sinph2(k)=dsin(k*phii1)
5618           enddo
5619         else
5620           phii1=0.0d0
5621 c          ityp3=nthetyp+1
5622           ityp3=ithetyp((itype(i)))
5623           do k=1,nsingle
5624             cosph2(k)=0.0d0
5625             sinph2(k)=0.0d0
5626           enddo
5627         endif
5628 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5629 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5630 c        call flush(iout)
5631         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5632         do k=1,ndouble
5633           do l=1,k-1
5634             ccl=cosph1(l)*cosph2(k-l)
5635             ssl=sinph1(l)*sinph2(k-l)
5636             scl=sinph1(l)*cosph2(k-l)
5637             csl=cosph1(l)*sinph2(k-l)
5638             cosph1ph2(l,k)=ccl-ssl
5639             cosph1ph2(k,l)=ccl+ssl
5640             sinph1ph2(l,k)=scl+csl
5641             sinph1ph2(k,l)=scl-csl
5642           enddo
5643         enddo
5644         if (lprn) then
5645         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5646      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5647         write (iout,*) "coskt and sinkt"
5648         do k=1,nntheterm
5649           write (iout,*) k,coskt(k),sinkt(k)
5650         enddo
5651         endif
5652         do k=1,ntheterm
5653           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5654           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5655      &      *coskt(k)
5656           if (lprn)
5657      &    write (iout,*) "k",k,"
5658      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5659      &     " ethetai",ethetai
5660         enddo
5661         if (lprn) then
5662         write (iout,*) "cosph and sinph"
5663         do k=1,nsingle
5664           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5665         enddo
5666         write (iout,*) "cosph1ph2 and sinph2ph2"
5667         do k=2,ndouble
5668           do l=1,k-1
5669             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5670      &         sinph1ph2(l,k),sinph1ph2(k,l)
5671           enddo
5672         enddo
5673         write(iout,*) "ethetai",ethetai
5674         endif
5675         do m=1,ntheterm2
5676           do k=1,nsingle
5677             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5678      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5679      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5680      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5681             ethetai=ethetai+sinkt(m)*aux
5682             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5683             dephii=dephii+k*sinkt(m)*(
5684      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5685      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5686             dephii1=dephii1+k*sinkt(m)*(
5687      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5688      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5689             if (lprn)
5690      &      write (iout,*) "m",m," k",k," bbthet",
5691      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5692      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5693      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5694      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5695           enddo
5696         enddo
5697         if (lprn)
5698      &  write(iout,*) "ethetai",ethetai
5699         do m=1,ntheterm3
5700           do k=2,ndouble
5701             do l=1,k-1
5702               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5703      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5704      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5705      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5706               ethetai=ethetai+sinkt(m)*aux
5707               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5708               dephii=dephii+l*sinkt(m)*(
5709      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5710      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5711      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5712      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5713               dephii1=dephii1+(k-l)*sinkt(m)*(
5714      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5715      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5716      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5717      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5718               if (lprn) then
5719               write (iout,*) "m",m," k",k," l",l," ffthet",
5720      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5721      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5722      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5723      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5724      &            " ethetai",ethetai
5725               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5726      &            cosph1ph2(k,l)*sinkt(m),
5727      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5728               endif
5729             enddo
5730           enddo
5731         enddo
5732 10      continue
5733         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5734      &   i,theta(i)*rad2deg,phii*rad2deg,
5735      &   phii1*rad2deg,ethetai
5736         etheta=etheta+ethetai
5737         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5738         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5739 c        gloc(nphi+i-2,icg)=wang*dethetai
5740         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5741       enddo
5742       return
5743       end
5744 #endif
5745 #ifdef CRYST_SC
5746 c-----------------------------------------------------------------------------
5747       subroutine esc(escloc)
5748 C Calculate the local energy of a side chain and its derivatives in the
5749 C corresponding virtual-bond valence angles THETA and the spherical angles
5750 C ALPHA and OMEGA.
5751       implicit real*8 (a-h,o-z)
5752       include 'DIMENSIONS'
5753       include 'DIMENSIONS.ZSCOPT'
5754       include 'COMMON.GEO'
5755       include 'COMMON.LOCAL'
5756       include 'COMMON.VAR'
5757       include 'COMMON.INTERACT'
5758       include 'COMMON.DERIV'
5759       include 'COMMON.CHAIN'
5760       include 'COMMON.IOUNITS'
5761       include 'COMMON.NAMES'
5762       include 'COMMON.FFIELD'
5763       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5764      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5765       common /sccalc/ time11,time12,time112,theti,it,nlobit
5766       delta=0.02d0*pi
5767       escloc=0.0D0
5768 C      write (iout,*) 'ESC'
5769       do i=loc_start,loc_end
5770         it=itype(i)
5771         if (it.eq.ntyp1) cycle
5772         if (it.eq.10) goto 1
5773         nlobit=nlob(iabs(it))
5774 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5775 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5776         theti=theta(i+1)-pipol
5777         x(1)=dtan(theti)
5778         x(2)=alph(i)
5779         x(3)=omeg(i)
5780 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5781
5782         if (x(2).gt.pi-delta) then
5783           xtemp(1)=x(1)
5784           xtemp(2)=pi-delta
5785           xtemp(3)=x(3)
5786           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5787           xtemp(2)=pi
5788           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5789           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5790      &        escloci,dersc(2))
5791           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5792      &        ddersc0(1),dersc(1))
5793           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5794      &        ddersc0(3),dersc(3))
5795           xtemp(2)=pi-delta
5796           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5797           xtemp(2)=pi
5798           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5799           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5800      &            dersc0(2),esclocbi,dersc02)
5801           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5802      &            dersc12,dersc01)
5803           call splinthet(x(2),0.5d0*delta,ss,ssd)
5804           dersc0(1)=dersc01
5805           dersc0(2)=dersc02
5806           dersc0(3)=0.0d0
5807           do k=1,3
5808             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5809           enddo
5810           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5811           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5812      &             esclocbi,ss,ssd
5813           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5814 c         escloci=esclocbi
5815 c         write (iout,*) escloci
5816         else if (x(2).lt.delta) then
5817           xtemp(1)=x(1)
5818           xtemp(2)=delta
5819           xtemp(3)=x(3)
5820           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5821           xtemp(2)=0.0d0
5822           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5823           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5824      &        escloci,dersc(2))
5825           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5826      &        ddersc0(1),dersc(1))
5827           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5828      &        ddersc0(3),dersc(3))
5829           xtemp(2)=delta
5830           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5831           xtemp(2)=0.0d0
5832           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5833           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5834      &            dersc0(2),esclocbi,dersc02)
5835           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5836      &            dersc12,dersc01)
5837           dersc0(1)=dersc01
5838           dersc0(2)=dersc02
5839           dersc0(3)=0.0d0
5840           call splinthet(x(2),0.5d0*delta,ss,ssd)
5841           do k=1,3
5842             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5843           enddo
5844           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5845 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5846 c     &             esclocbi,ss,ssd
5847           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5848 C         write (iout,*) 'i=',i, escloci
5849         else
5850           call enesc(x,escloci,dersc,ddummy,.false.)
5851         endif
5852
5853         escloc=escloc+escloci
5854 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5855             write (iout,'(a6,i5,0pf7.3)')
5856      &     'escloc',i,escloci
5857
5858         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5859      &   wscloc*dersc(1)
5860         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5861         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5862     1   continue
5863       enddo
5864       return
5865       end
5866 C---------------------------------------------------------------------------
5867       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5868       implicit real*8 (a-h,o-z)
5869       include 'DIMENSIONS'
5870       include 'COMMON.GEO'
5871       include 'COMMON.LOCAL'
5872       include 'COMMON.IOUNITS'
5873       common /sccalc/ time11,time12,time112,theti,it,nlobit
5874       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5875       double precision contr(maxlob,-1:1)
5876       logical mixed
5877 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5878         escloc_i=0.0D0
5879         do j=1,3
5880           dersc(j)=0.0D0
5881           if (mixed) ddersc(j)=0.0d0
5882         enddo
5883         x3=x(3)
5884
5885 C Because of periodicity of the dependence of the SC energy in omega we have
5886 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5887 C To avoid underflows, first compute & store the exponents.
5888
5889         do iii=-1,1
5890
5891           x(3)=x3+iii*dwapi
5892
5893           do j=1,nlobit
5894             do k=1,3
5895               z(k)=x(k)-censc(k,j,it)
5896             enddo
5897             do k=1,3
5898               Axk=0.0D0
5899               do l=1,3
5900                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5901               enddo
5902               Ax(k,j,iii)=Axk
5903             enddo
5904             expfac=0.0D0
5905             do k=1,3
5906               expfac=expfac+Ax(k,j,iii)*z(k)
5907             enddo
5908             contr(j,iii)=expfac
5909           enddo ! j
5910
5911         enddo ! iii
5912
5913         x(3)=x3
5914 C As in the case of ebend, we want to avoid underflows in exponentiation and
5915 C subsequent NaNs and INFs in energy calculation.
5916 C Find the largest exponent
5917         emin=contr(1,-1)
5918         do iii=-1,1
5919           do j=1,nlobit
5920             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5921           enddo
5922         enddo
5923         emin=0.5D0*emin
5924 cd      print *,'it=',it,' emin=',emin
5925
5926 C Compute the contribution to SC energy and derivatives
5927         do iii=-1,1
5928
5929           do j=1,nlobit
5930             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5931 cd          print *,'j=',j,' expfac=',expfac
5932             escloc_i=escloc_i+expfac
5933             do k=1,3
5934               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5935             enddo
5936             if (mixed) then
5937               do k=1,3,2
5938                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5939      &            +gaussc(k,2,j,it))*expfac
5940               enddo
5941             endif
5942           enddo
5943
5944         enddo ! iii
5945
5946         dersc(1)=dersc(1)/cos(theti)**2
5947         ddersc(1)=ddersc(1)/cos(theti)**2
5948         ddersc(3)=ddersc(3)
5949
5950         escloci=-(dlog(escloc_i)-emin)
5951         do j=1,3
5952           dersc(j)=dersc(j)/escloc_i
5953         enddo
5954         if (mixed) then
5955           do j=1,3,2
5956             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5957           enddo
5958         endif
5959       return
5960       end
5961 C------------------------------------------------------------------------------
5962       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5963       implicit real*8 (a-h,o-z)
5964       include 'DIMENSIONS'
5965       include 'COMMON.GEO'
5966       include 'COMMON.LOCAL'
5967       include 'COMMON.IOUNITS'
5968       common /sccalc/ time11,time12,time112,theti,it,nlobit
5969       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5970       double precision contr(maxlob)
5971       logical mixed
5972
5973       escloc_i=0.0D0
5974
5975       do j=1,3
5976         dersc(j)=0.0D0
5977       enddo
5978
5979       do j=1,nlobit
5980         do k=1,2
5981           z(k)=x(k)-censc(k,j,it)
5982         enddo
5983         z(3)=dwapi
5984         do k=1,3
5985           Axk=0.0D0
5986           do l=1,3
5987             Axk=Axk+gaussc(l,k,j,it)*z(l)
5988           enddo
5989           Ax(k,j)=Axk
5990         enddo
5991         expfac=0.0D0
5992         do k=1,3
5993           expfac=expfac+Ax(k,j)*z(k)
5994         enddo
5995         contr(j)=expfac
5996       enddo ! j
5997
5998 C As in the case of ebend, we want to avoid underflows in exponentiation and
5999 C subsequent NaNs and INFs in energy calculation.
6000 C Find the largest exponent
6001       emin=contr(1)
6002       do j=1,nlobit
6003         if (emin.gt.contr(j)) emin=contr(j)
6004       enddo
6005       emin=0.5D0*emin
6006
6007 C Compute the contribution to SC energy and derivatives
6008
6009       dersc12=0.0d0
6010       do j=1,nlobit
6011         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6012         escloc_i=escloc_i+expfac
6013         do k=1,2
6014           dersc(k)=dersc(k)+Ax(k,j)*expfac
6015         enddo
6016         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6017      &            +gaussc(1,2,j,it))*expfac
6018         dersc(3)=0.0d0
6019       enddo
6020
6021       dersc(1)=dersc(1)/cos(theti)**2
6022       dersc12=dersc12/cos(theti)**2
6023       escloci=-(dlog(escloc_i)-emin)
6024       do j=1,2
6025         dersc(j)=dersc(j)/escloc_i
6026       enddo
6027       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6028       return
6029       end
6030 #else
6031 c----------------------------------------------------------------------------------
6032       subroutine esc(escloc)
6033 C Calculate the local energy of a side chain and its derivatives in the
6034 C corresponding virtual-bond valence angles THETA and the spherical angles
6035 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6036 C added by Urszula Kozlowska. 07/11/2007
6037 C
6038       implicit real*8 (a-h,o-z)
6039       include 'DIMENSIONS'
6040       include 'DIMENSIONS.ZSCOPT'
6041       include 'COMMON.GEO'
6042       include 'COMMON.LOCAL'
6043       include 'COMMON.VAR'
6044       include 'COMMON.SCROT'
6045       include 'COMMON.INTERACT'
6046       include 'COMMON.DERIV'
6047       include 'COMMON.CHAIN'
6048       include 'COMMON.IOUNITS'
6049       include 'COMMON.NAMES'
6050       include 'COMMON.FFIELD'
6051       include 'COMMON.CONTROL'
6052       include 'COMMON.VECTORS'
6053       double precision x_prime(3),y_prime(3),z_prime(3)
6054      &    , sumene,dsc_i,dp2_i,x(65),
6055      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6056      &    de_dxx,de_dyy,de_dzz,de_dt
6057       double precision s1_t,s1_6_t,s2_t,s2_6_t
6058       double precision
6059      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6060      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6061      & dt_dCi(3),dt_dCi1(3)
6062       common /sccalc/ time11,time12,time112,theti,it,nlobit
6063       delta=0.02d0*pi
6064       escloc=0.0D0
6065       do i=loc_start,loc_end
6066         if (itype(i).eq.ntyp1) cycle
6067         costtab(i+1) =dcos(theta(i+1))
6068         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6069         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6070         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6071         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6072         cosfac=dsqrt(cosfac2)
6073         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6074         sinfac=dsqrt(sinfac2)
6075         it=iabs(itype(i))
6076         if (it.eq.10) goto 1
6077 c
6078 C  Compute the axes of tghe local cartesian coordinates system; store in
6079 c   x_prime, y_prime and z_prime
6080 c
6081         do j=1,3
6082           x_prime(j) = 0.00
6083           y_prime(j) = 0.00
6084           z_prime(j) = 0.00
6085         enddo
6086 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6087 C     &   dc_norm(3,i+nres)
6088         do j = 1,3
6089           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6090           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6091         enddo
6092         do j = 1,3
6093           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6094         enddo
6095 c       write (2,*) "i",i
6096 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6097 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6098 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6099 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6100 c      & " xy",scalar(x_prime(1),y_prime(1)),
6101 c      & " xz",scalar(x_prime(1),z_prime(1)),
6102 c      & " yy",scalar(y_prime(1),y_prime(1)),
6103 c      & " yz",scalar(y_prime(1),z_prime(1)),
6104 c      & " zz",scalar(z_prime(1),z_prime(1))
6105 c
6106 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6107 C to local coordinate system. Store in xx, yy, zz.
6108 c
6109         xx=0.0d0
6110         yy=0.0d0
6111         zz=0.0d0
6112         do j = 1,3
6113           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6114           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6115           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6116         enddo
6117
6118         xxtab(i)=xx
6119         yytab(i)=yy
6120         zztab(i)=zz
6121 C
6122 C Compute the energy of the ith side cbain
6123 C
6124 c        write (2,*) "xx",xx," yy",yy," zz",zz
6125         it=iabs(itype(i))
6126         do j = 1,65
6127           x(j) = sc_parmin(j,it)
6128         enddo
6129 #ifdef CHECK_COORD
6130 Cc diagnostics - remove later
6131         xx1 = dcos(alph(2))
6132         yy1 = dsin(alph(2))*dcos(omeg(2))
6133         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6134         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6135      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6136      &    xx1,yy1,zz1
6137 C,"  --- ", xx_w,yy_w,zz_w
6138 c end diagnostics
6139 #endif
6140         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6141      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6142      &   + x(10)*yy*zz
6143         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6144      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6145      & + x(20)*yy*zz
6146         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6147      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6148      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6149      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6150      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6151      &  +x(40)*xx*yy*zz
6152         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6153      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6154      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6155      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6156      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6157      &  +x(60)*xx*yy*zz
6158         dsc_i   = 0.743d0+x(61)
6159         dp2_i   = 1.9d0+x(62)
6160         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6161      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6162         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6163      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6164         s1=(1+x(63))/(0.1d0 + dscp1)
6165         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6166         s2=(1+x(65))/(0.1d0 + dscp2)
6167         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6168         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6169      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6170 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6171 c     &   sumene4,
6172 c     &   dscp1,dscp2,sumene
6173 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6174         escloc = escloc + sumene
6175 c        write (2,*) "escloc",escloc
6176 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6177 c     &  zz,xx,yy
6178         if (.not. calc_grad) goto 1
6179 #ifdef DEBUG
6180 C
6181 C This section to check the numerical derivatives of the energy of ith side
6182 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6183 C #define DEBUG in the code to turn it on.
6184 C
6185         write (2,*) "sumene               =",sumene
6186         aincr=1.0d-7
6187         xxsave=xx
6188         xx=xx+aincr
6189         write (2,*) xx,yy,zz
6190         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6191         de_dxx_num=(sumenep-sumene)/aincr
6192         xx=xxsave
6193         write (2,*) "xx+ sumene from enesc=",sumenep
6194         yysave=yy
6195         yy=yy+aincr
6196         write (2,*) xx,yy,zz
6197         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6198         de_dyy_num=(sumenep-sumene)/aincr
6199         yy=yysave
6200         write (2,*) "yy+ sumene from enesc=",sumenep
6201         zzsave=zz
6202         zz=zz+aincr
6203         write (2,*) xx,yy,zz
6204         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6205         de_dzz_num=(sumenep-sumene)/aincr
6206         zz=zzsave
6207         write (2,*) "zz+ sumene from enesc=",sumenep
6208         costsave=cost2tab(i+1)
6209         sintsave=sint2tab(i+1)
6210         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6211         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6212         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6213         de_dt_num=(sumenep-sumene)/aincr
6214         write (2,*) " t+ sumene from enesc=",sumenep
6215         cost2tab(i+1)=costsave
6216         sint2tab(i+1)=sintsave
6217 C End of diagnostics section.
6218 #endif
6219 C
6220 C Compute the gradient of esc
6221 C
6222         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6223         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6224         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6225         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6226         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6227         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6228         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6229         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6230         pom1=(sumene3*sint2tab(i+1)+sumene1)
6231      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6232         pom2=(sumene4*cost2tab(i+1)+sumene2)
6233      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6234         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6235         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6236      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6237      &  +x(40)*yy*zz
6238         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6239         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6240      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6241      &  +x(60)*yy*zz
6242         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6243      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6244      &        +(pom1+pom2)*pom_dx
6245 #ifdef DEBUG
6246         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6247 #endif
6248 C
6249         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6250         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6251      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6252      &  +x(40)*xx*zz
6253         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6254         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6255      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6256      &  +x(59)*zz**2 +x(60)*xx*zz
6257         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6258      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6259      &        +(pom1-pom2)*pom_dy
6260 #ifdef DEBUG
6261         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6262 #endif
6263 C
6264         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6265      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6266      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6267      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6268      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6269      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6270      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6271      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6272 #ifdef DEBUG
6273         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6274 #endif
6275 C
6276         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6277      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6278      &  +pom1*pom_dt1+pom2*pom_dt2
6279 #ifdef DEBUG
6280         write(2,*), "de_dt = ", de_dt,de_dt_num
6281 #endif
6282 c
6283 C
6284        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6285        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6286        cosfac2xx=cosfac2*xx
6287        sinfac2yy=sinfac2*yy
6288        do k = 1,3
6289          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6290      &      vbld_inv(i+1)
6291          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6292      &      vbld_inv(i)
6293          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6294          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6295 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6296 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6297 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6298 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6299          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6300          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6301          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6302          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6303          dZZ_Ci1(k)=0.0d0
6304          dZZ_Ci(k)=0.0d0
6305          do j=1,3
6306            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6307      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6308            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6309      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6310          enddo
6311
6312          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6313          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6314          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6315 c
6316          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6317          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6318        enddo
6319
6320        do k=1,3
6321          dXX_Ctab(k,i)=dXX_Ci(k)
6322          dXX_C1tab(k,i)=dXX_Ci1(k)
6323          dYY_Ctab(k,i)=dYY_Ci(k)
6324          dYY_C1tab(k,i)=dYY_Ci1(k)
6325          dZZ_Ctab(k,i)=dZZ_Ci(k)
6326          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6327          dXX_XYZtab(k,i)=dXX_XYZ(k)
6328          dYY_XYZtab(k,i)=dYY_XYZ(k)
6329          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6330        enddo
6331
6332        do k = 1,3
6333 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6334 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6335 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6336 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6337 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6338 c     &    dt_dci(k)
6339 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6340 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6341          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6342      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6343          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6344      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6345          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6346      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6347        enddo
6348 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6349 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6350
6351 C to check gradient call subroutine check_grad
6352
6353     1 continue
6354       enddo
6355       return
6356       end
6357 #endif
6358 c------------------------------------------------------------------------------
6359       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6360 C
6361 C This procedure calculates two-body contact function g(rij) and its derivative:
6362 C
6363 C           eps0ij                                     !       x < -1
6364 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6365 C            0                                         !       x > 1
6366 C
6367 C where x=(rij-r0ij)/delta
6368 C
6369 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6370 C
6371       implicit none
6372       double precision rij,r0ij,eps0ij,fcont,fprimcont
6373       double precision x,x2,x4,delta
6374 c     delta=0.02D0*r0ij
6375 c      delta=0.2D0*r0ij
6376       x=(rij-r0ij)/delta
6377       if (x.lt.-1.0D0) then
6378         fcont=eps0ij
6379         fprimcont=0.0D0
6380       else if (x.le.1.0D0) then
6381         x2=x*x
6382         x4=x2*x2
6383         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6384         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6385       else
6386         fcont=0.0D0
6387         fprimcont=0.0D0
6388       endif
6389       return
6390       end
6391 c------------------------------------------------------------------------------
6392       subroutine splinthet(theti,delta,ss,ssder)
6393       implicit real*8 (a-h,o-z)
6394       include 'DIMENSIONS'
6395       include 'DIMENSIONS.ZSCOPT'
6396       include 'COMMON.VAR'
6397       include 'COMMON.GEO'
6398       thetup=pi-delta
6399       thetlow=delta
6400       if (theti.gt.pipol) then
6401         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6402       else
6403         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6404         ssder=-ssder
6405       endif
6406       return
6407       end
6408 c------------------------------------------------------------------------------
6409       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6410       implicit none
6411       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6412       double precision ksi,ksi2,ksi3,a1,a2,a3
6413       a1=fprim0*delta/(f1-f0)
6414       a2=3.0d0-2.0d0*a1
6415       a3=a1-2.0d0
6416       ksi=(x-x0)/delta
6417       ksi2=ksi*ksi
6418       ksi3=ksi2*ksi
6419       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6420       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6421       return
6422       end
6423 c------------------------------------------------------------------------------
6424       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6425       implicit none
6426       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6427       double precision ksi,ksi2,ksi3,a1,a2,a3
6428       ksi=(x-x0)/delta
6429       ksi2=ksi*ksi
6430       ksi3=ksi2*ksi
6431       a1=fprim0x*delta
6432       a2=3*(f1x-f0x)-2*fprim0x*delta
6433       a3=fprim0x*delta-2*(f1x-f0x)
6434       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6435       return
6436       end
6437 C-----------------------------------------------------------------------------
6438 #ifdef CRYST_TOR
6439 C-----------------------------------------------------------------------------
6440       subroutine etor(etors,fact)
6441       implicit real*8 (a-h,o-z)
6442       include 'DIMENSIONS'
6443       include 'DIMENSIONS.ZSCOPT'
6444       include 'COMMON.VAR'
6445       include 'COMMON.GEO'
6446       include 'COMMON.LOCAL'
6447       include 'COMMON.TORSION'
6448       include 'COMMON.INTERACT'
6449       include 'COMMON.DERIV'
6450       include 'COMMON.CHAIN'
6451       include 'COMMON.NAMES'
6452       include 'COMMON.IOUNITS'
6453       include 'COMMON.FFIELD'
6454       include 'COMMON.TORCNSTR'
6455       logical lprn
6456 C Set lprn=.true. for debugging
6457       lprn=.false.
6458 c      lprn=.true.
6459       etors=0.0D0
6460       do i=iphi_start,iphi_end
6461         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6462      &      .or. itype(i).eq.ntyp1) cycle
6463         itori=itortyp(itype(i-2))
6464         itori1=itortyp(itype(i-1))
6465         phii=phi(i)
6466         gloci=0.0D0
6467 C Proline-Proline pair is a special case...
6468         if (itori.eq.3 .and. itori1.eq.3) then
6469           if (phii.gt.-dwapi3) then
6470             cosphi=dcos(3*phii)
6471             fac=1.0D0/(1.0D0-cosphi)
6472             etorsi=v1(1,3,3)*fac
6473             etorsi=etorsi+etorsi
6474             etors=etors+etorsi-v1(1,3,3)
6475             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6476           endif
6477           do j=1,3
6478             v1ij=v1(j+1,itori,itori1)
6479             v2ij=v2(j+1,itori,itori1)
6480             cosphi=dcos(j*phii)
6481             sinphi=dsin(j*phii)
6482             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6483             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6484           enddo
6485         else
6486           do j=1,nterm_old
6487             v1ij=v1(j,itori,itori1)
6488             v2ij=v2(j,itori,itori1)
6489             cosphi=dcos(j*phii)
6490             sinphi=dsin(j*phii)
6491             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6492             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6493           enddo
6494         endif
6495         if (lprn)
6496      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6497      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6498      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6499         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6500 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6501       enddo
6502       return
6503       end
6504 c------------------------------------------------------------------------------
6505 #else
6506       subroutine etor(etors,fact)
6507       implicit real*8 (a-h,o-z)
6508       include 'DIMENSIONS'
6509       include 'DIMENSIONS.ZSCOPT'
6510       include 'COMMON.VAR'
6511       include 'COMMON.GEO'
6512       include 'COMMON.LOCAL'
6513       include 'COMMON.TORSION'
6514       include 'COMMON.INTERACT'
6515       include 'COMMON.DERIV'
6516       include 'COMMON.CHAIN'
6517       include 'COMMON.NAMES'
6518       include 'COMMON.IOUNITS'
6519       include 'COMMON.FFIELD'
6520       include 'COMMON.TORCNSTR'
6521       logical lprn
6522 C Set lprn=.true. for debugging
6523       lprn=.false.
6524 c      lprn=.true.
6525       etors=0.0D0
6526       do i=iphi_start,iphi_end
6527         if (i.le.2) cycle
6528         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6529      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6530 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6531 C     &       .or. itype(i).eq.ntyp1) cycle
6532         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6533          if (iabs(itype(i)).eq.20) then
6534          iblock=2
6535          else
6536          iblock=1
6537          endif
6538         itori=itortyp(itype(i-2))
6539         itori1=itortyp(itype(i-1))
6540         phii=phi(i)
6541         gloci=0.0D0
6542 C Regular cosine and sine terms
6543         do j=1,nterm(itori,itori1,iblock)
6544           v1ij=v1(j,itori,itori1,iblock)
6545           v2ij=v2(j,itori,itori1,iblock)
6546           cosphi=dcos(j*phii)
6547           sinphi=dsin(j*phii)
6548           etors=etors+v1ij*cosphi+v2ij*sinphi
6549           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6550         enddo
6551 C Lorentz terms
6552 C                         v1
6553 C  E = SUM ----------------------------------- - v1
6554 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6555 C
6556         cosphi=dcos(0.5d0*phii)
6557         sinphi=dsin(0.5d0*phii)
6558         do j=1,nlor(itori,itori1,iblock)
6559           vl1ij=vlor1(j,itori,itori1)
6560           vl2ij=vlor2(j,itori,itori1)
6561           vl3ij=vlor3(j,itori,itori1)
6562           pom=vl2ij*cosphi+vl3ij*sinphi
6563           pom1=1.0d0/(pom*pom+1.0d0)
6564           etors=etors+vl1ij*pom1
6565 c          if (energy_dec) etors_ii=etors_ii+
6566 c     &                vl1ij*pom1
6567           pom=-pom*pom1*pom1
6568           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6569         enddo
6570 C Subtract the constant term
6571         etors=etors-v0(itori,itori1,iblock)
6572         if (lprn)
6573      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6574      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6575      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6576         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6577 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6578  1215   continue
6579       enddo
6580       return
6581       end
6582 c----------------------------------------------------------------------------
6583       subroutine etor_d(etors_d,fact2)
6584 C 6/23/01 Compute double torsional energy
6585       implicit real*8 (a-h,o-z)
6586       include 'DIMENSIONS'
6587       include 'DIMENSIONS.ZSCOPT'
6588       include 'COMMON.VAR'
6589       include 'COMMON.GEO'
6590       include 'COMMON.LOCAL'
6591       include 'COMMON.TORSION'
6592       include 'COMMON.INTERACT'
6593       include 'COMMON.DERIV'
6594       include 'COMMON.CHAIN'
6595       include 'COMMON.NAMES'
6596       include 'COMMON.IOUNITS'
6597       include 'COMMON.FFIELD'
6598       include 'COMMON.TORCNSTR'
6599       logical lprn
6600 C Set lprn=.true. for debugging
6601       lprn=.false.
6602 c     lprn=.true.
6603       etors_d=0.0D0
6604       do i=iphi_start,iphi_end-1
6605         if (i.le.3) cycle
6606 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6607 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6608          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6609      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6610      &  (itype(i+1).eq.ntyp1)) cycle
6611         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6612      &     goto 1215
6613         itori=itortyp(itype(i-2))
6614         itori1=itortyp(itype(i-1))
6615         itori2=itortyp(itype(i))
6616         phii=phi(i)
6617         phii1=phi(i+1)
6618         gloci1=0.0D0
6619         gloci2=0.0D0
6620         iblock=1
6621         if (iabs(itype(i+1)).eq.20) iblock=2
6622 C Regular cosine and sine terms
6623         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6624           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6625           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6626           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6627           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6628           cosphi1=dcos(j*phii)
6629           sinphi1=dsin(j*phii)
6630           cosphi2=dcos(j*phii1)
6631           sinphi2=dsin(j*phii1)
6632           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6633      &     v2cij*cosphi2+v2sij*sinphi2
6634           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6635           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6636         enddo
6637         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6638           do l=1,k-1
6639             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6640             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6641             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6642             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6643             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6644             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6645             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6646             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6647             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6648      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6649             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6650      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6651             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6652      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6653           enddo
6654         enddo
6655         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6656         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6657  1215   continue
6658       enddo
6659       return
6660       end
6661 #endif
6662 c---------------------------------------------------------------------------
6663 C The rigorous attempt to derive energy function
6664       subroutine etor_kcc(etors,fact)
6665       implicit real*8 (a-h,o-z)
6666       include 'DIMENSIONS'
6667       include 'DIMENSIONS.ZSCOPT'
6668       include 'COMMON.VAR'
6669       include 'COMMON.GEO'
6670       include 'COMMON.LOCAL'
6671       include 'COMMON.TORSION'
6672       include 'COMMON.INTERACT'
6673       include 'COMMON.DERIV'
6674       include 'COMMON.CHAIN'
6675       include 'COMMON.NAMES'
6676       include 'COMMON.IOUNITS'
6677       include 'COMMON.FFIELD'
6678       include 'COMMON.TORCNSTR'
6679       include 'COMMON.CONTROL'
6680       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6681       logical lprn
6682 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6683 C Set lprn=.true. for debugging
6684       lprn=energy_dec
6685 c     lprn=.true.
6686 C      print *,"wchodze kcc"
6687       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6688       etors=0.0D0
6689       do i=iphi_start,iphi_end
6690 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6691 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6692 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6693 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6694         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6695      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6696         itori=itortyp(itype(i-2))
6697         itori1=itortyp(itype(i-1))
6698         phii=phi(i)
6699         glocig=0.0D0
6700         glocit1=0.0d0
6701         glocit2=0.0d0
6702 C to avoid multiple devision by 2
6703 c        theti22=0.5d0*theta(i)
6704 C theta 12 is the theta_1 /2
6705 C theta 22 is theta_2 /2
6706 c        theti12=0.5d0*theta(i-1)
6707 C and appropriate sinus function
6708         sinthet1=dsin(theta(i-1))
6709         sinthet2=dsin(theta(i))
6710         costhet1=dcos(theta(i-1))
6711         costhet2=dcos(theta(i))
6712 C to speed up lets store its mutliplication
6713         sint1t2=sinthet2*sinthet1
6714         sint1t2n=1.0d0
6715 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6716 C +d_n*sin(n*gamma)) *
6717 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6718 C we have two sum 1) Non-Chebyshev which is with n and gamma
6719         nval=nterm_kcc_Tb(itori,itori1)
6720         c1(0)=0.0d0
6721         c2(0)=0.0d0
6722         c1(1)=1.0d0
6723         c2(1)=1.0d0
6724         do j=2,nval
6725           c1(j)=c1(j-1)*costhet1
6726           c2(j)=c2(j-1)*costhet2
6727         enddo
6728         etori=0.0d0
6729         do j=1,nterm_kcc(itori,itori1)
6730           cosphi=dcos(j*phii)
6731           sinphi=dsin(j*phii)
6732           sint1t2n1=sint1t2n
6733           sint1t2n=sint1t2n*sint1t2
6734           sumvalc=0.0d0
6735           gradvalct1=0.0d0
6736           gradvalct2=0.0d0
6737           do k=1,nval
6738             do l=1,nval
6739               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6740               gradvalct1=gradvalct1+
6741      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6742               gradvalct2=gradvalct2+
6743      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6744             enddo
6745           enddo
6746           gradvalct1=-gradvalct1*sinthet1
6747           gradvalct2=-gradvalct2*sinthet2
6748           sumvals=0.0d0
6749           gradvalst1=0.0d0
6750           gradvalst2=0.0d0
6751           do k=1,nval
6752             do l=1,nval
6753               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6754               gradvalst1=gradvalst1+
6755      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6756               gradvalst2=gradvalst2+
6757      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6758             enddo
6759           enddo
6760           gradvalst1=-gradvalst1*sinthet1
6761           gradvalst2=-gradvalst2*sinthet2
6762           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6763 C glocig is the gradient local i site in gamma
6764           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6765 C now gradient over theta_1
6766           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6767      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6768           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6769      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6770         enddo ! j
6771         etors=etors+etori
6772 C derivative over gamma
6773         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6774 C derivative over theta1
6775         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6776 C now derivative over theta2
6777         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6778         if (lprn) then
6779           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6780      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6781           write (iout,*) "c1",(c1(k),k=0,nval),
6782      &    " c2",(c2(k),k=0,nval)
6783           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6784         endif
6785       enddo
6786       return
6787       end
6788 c---------------------------------------------------------------------------------------------
6789       subroutine etor_constr(edihcnstr)
6790       implicit real*8 (a-h,o-z)
6791       include 'DIMENSIONS'
6792       include 'DIMENSIONS.ZSCOPT'
6793       include 'COMMON.VAR'
6794       include 'COMMON.GEO'
6795       include 'COMMON.LOCAL'
6796       include 'COMMON.TORSION'
6797       include 'COMMON.INTERACT'
6798       include 'COMMON.DERIV'
6799       include 'COMMON.CHAIN'
6800       include 'COMMON.NAMES'
6801       include 'COMMON.IOUNITS'
6802       include 'COMMON.FFIELD'
6803       include 'COMMON.TORCNSTR'
6804       include 'COMMON.CONTROL'
6805 ! 6/20/98 - dihedral angle constraints
6806       edihcnstr=0.0d0
6807 c      do i=1,ndih_constr
6808 c      write (iout,*) "idihconstr_start",idihconstr_start,
6809 c     &  " idihconstr_end",idihconstr_end
6810
6811       if (raw_psipred) then
6812         do i=idihconstr_start,idihconstr_end
6813           itori=idih_constr(i)
6814           phii=phi(itori)
6815           gaudih_i=vpsipred(1,i)
6816           gauder_i=0.0d0
6817           do j=1,2
6818             s = sdihed(j,i)
6819             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6820             dexpcos_i=dexp(-cos_i*cos_i)
6821             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6822             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6823      &            *cos_i*dexpcos_i/s**2
6824           enddo
6825           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6826           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6827           if (energy_dec)
6828      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6829      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6830      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6831      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6832      &     -wdihc*dlog(gaudih_i)
6833         enddo
6834       else
6835
6836       do i=idihconstr_start,idihconstr_end
6837         itori=idih_constr(i)
6838         phii=phi(itori)
6839         difi=pinorm(phii-phi0(i))
6840         if (difi.gt.drange(i)) then
6841           difi=difi-drange(i)
6842           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6843           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6844         else if (difi.lt.-drange(i)) then
6845           difi=difi+drange(i)
6846           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6847           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6848         else
6849           difi=0.0
6850         endif
6851       enddo
6852
6853       endif
6854
6855 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6856       return
6857       end
6858 c----------------------------------------------------------------------------
6859 C The rigorous attempt to derive energy function
6860       subroutine ebend_kcc(etheta)
6861
6862       implicit real*8 (a-h,o-z)
6863       include 'DIMENSIONS'
6864       include 'DIMENSIONS.ZSCOPT'
6865       include 'COMMON.VAR'
6866       include 'COMMON.GEO'
6867       include 'COMMON.LOCAL'
6868       include 'COMMON.TORSION'
6869       include 'COMMON.INTERACT'
6870       include 'COMMON.DERIV'
6871       include 'COMMON.CHAIN'
6872       include 'COMMON.NAMES'
6873       include 'COMMON.IOUNITS'
6874       include 'COMMON.FFIELD'
6875       include 'COMMON.TORCNSTR'
6876       include 'COMMON.CONTROL'
6877       logical lprn
6878       double precision thybt1(maxang_kcc)
6879 C Set lprn=.true. for debugging
6880       lprn=energy_dec
6881 c     lprn=.true.
6882 C      print *,"wchodze kcc"
6883       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6884       etheta=0.0D0
6885       do i=ithet_start,ithet_end
6886 c        print *,i,itype(i-1),itype(i),itype(i-2)
6887         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6888      &  .or.itype(i).eq.ntyp1) cycle
6889         iti=iabs(itortyp(itype(i-1)))
6890         sinthet=dsin(theta(i))
6891         costhet=dcos(theta(i))
6892         do j=1,nbend_kcc_Tb(iti)
6893           thybt1(j)=v1bend_chyb(j,iti)
6894         enddo
6895         sumth1thyb=v1bend_chyb(0,iti)+
6896      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6897         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6898      &    sumth1thyb
6899         ihelp=nbend_kcc_Tb(iti)-1
6900         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6901         etheta=etheta+sumth1thyb
6902 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6903         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6904       enddo
6905       return
6906       end
6907 c-------------------------------------------------------------------------------------
6908       subroutine etheta_constr(ethetacnstr)
6909
6910       implicit real*8 (a-h,o-z)
6911       include 'DIMENSIONS'
6912       include 'DIMENSIONS.ZSCOPT'
6913       include 'COMMON.VAR'
6914       include 'COMMON.GEO'
6915       include 'COMMON.LOCAL'
6916       include 'COMMON.TORSION'
6917       include 'COMMON.INTERACT'
6918       include 'COMMON.DERIV'
6919       include 'COMMON.CHAIN'
6920       include 'COMMON.NAMES'
6921       include 'COMMON.IOUNITS'
6922       include 'COMMON.FFIELD'
6923       include 'COMMON.TORCNSTR'
6924       include 'COMMON.CONTROL'
6925       ethetacnstr=0.0d0
6926 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6927       do i=ithetaconstr_start,ithetaconstr_end
6928         itheta=itheta_constr(i)
6929         thetiii=theta(itheta)
6930         difi=pinorm(thetiii-theta_constr0(i))
6931         if (difi.gt.theta_drange(i)) then
6932           difi=difi-theta_drange(i)
6933           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6934           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6935      &    +for_thet_constr(i)*difi**3
6936         else if (difi.lt.-drange(i)) then
6937           difi=difi+drange(i)
6938           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6939           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6940      &    +for_thet_constr(i)*difi**3
6941         else
6942           difi=0.0
6943         endif
6944        if (energy_dec) then
6945         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6946      &    i,itheta,rad2deg*thetiii,
6947      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6948      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6949      &    gloc(itheta+nphi-2,icg)
6950         endif
6951       enddo
6952       return
6953       end
6954 c------------------------------------------------------------------------------
6955 c------------------------------------------------------------------------------
6956       subroutine eback_sc_corr(esccor)
6957 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6958 c        conformational states; temporarily implemented as differences
6959 c        between UNRES torsional potentials (dependent on three types of
6960 c        residues) and the torsional potentials dependent on all 20 types
6961 c        of residues computed from AM1 energy surfaces of terminally-blocked
6962 c        amino-acid residues.
6963       implicit real*8 (a-h,o-z)
6964       include 'DIMENSIONS'
6965       include 'DIMENSIONS.ZSCOPT'
6966       include 'COMMON.VAR'
6967       include 'COMMON.GEO'
6968       include 'COMMON.LOCAL'
6969       include 'COMMON.TORSION'
6970       include 'COMMON.SCCOR'
6971       include 'COMMON.INTERACT'
6972       include 'COMMON.DERIV'
6973       include 'COMMON.CHAIN'
6974       include 'COMMON.NAMES'
6975       include 'COMMON.IOUNITS'
6976       include 'COMMON.FFIELD'
6977       include 'COMMON.CONTROL'
6978       logical lprn
6979 C Set lprn=.true. for debugging
6980       lprn=.false.
6981 c      lprn=.true.
6982 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6983       esccor=0.0D0
6984       do i=itau_start,itau_end
6985         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6986         esccor_ii=0.0D0
6987         isccori=isccortyp(itype(i-2))
6988         isccori1=isccortyp(itype(i-1))
6989         phii=phi(i)
6990         do intertyp=1,3 !intertyp
6991 cc Added 09 May 2012 (Adasko)
6992 cc  Intertyp means interaction type of backbone mainchain correlation:
6993 c   1 = SC...Ca...Ca...Ca
6994 c   2 = Ca...Ca...Ca...SC
6995 c   3 = SC...Ca...Ca...SCi
6996         gloci=0.0D0
6997         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6998      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6999      &      (itype(i-1).eq.ntyp1)))
7000      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7001      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7002      &     .or.(itype(i).eq.ntyp1)))
7003      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7004      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7005      &      (itype(i-3).eq.ntyp1)))) cycle
7006         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7007         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7008      & cycle
7009        do j=1,nterm_sccor(isccori,isccori1)
7010           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7011           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7012           cosphi=dcos(j*tauangle(intertyp,i))
7013           sinphi=dsin(j*tauangle(intertyp,i))
7014            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7015            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7016          enddo
7017 C      write (iout,*)"EBACK_SC_COR",esccor,i
7018 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7019 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7020 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7021         if (lprn)
7022      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7023      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7024      &  (v1sccor(j,1,itori,itori1),j=1,6)
7025      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7026 c        gsccor_loc(i-3)=gloci
7027        enddo !intertyp
7028       enddo
7029       return
7030       end
7031 #ifdef FOURBODY
7032 c------------------------------------------------------------------------------
7033       subroutine multibody(ecorr)
7034 C This subroutine calculates multi-body contributions to energy following
7035 C the idea of Skolnick et al. If side chains I and J make a contact and
7036 C at the same time side chains I+1 and J+1 make a contact, an extra
7037 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.DERIV'
7042       include 'COMMON.INTERACT'
7043       include 'COMMON.CONTACTS'
7044       include 'COMMON.CONTMAT'
7045       include 'COMMON.CORRMAT'
7046       double precision gx(3),gx1(3)
7047       logical lprn
7048
7049 C Set lprn=.true. for debugging
7050       lprn=.false.
7051
7052       if (lprn) then
7053         write (iout,'(a)') 'Contact function values:'
7054         do i=nnt,nct-2
7055           write (iout,'(i2,20(1x,i2,f10.5))')
7056      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7057         enddo
7058       endif
7059       ecorr=0.0D0
7060       do i=nnt,nct
7061         do j=1,3
7062           gradcorr(j,i)=0.0D0
7063           gradxorr(j,i)=0.0D0
7064         enddo
7065       enddo
7066       do i=nnt,nct-2
7067
7068         DO ISHIFT = 3,4
7069
7070         i1=i+ishift
7071         num_conti=num_cont(i)
7072         num_conti1=num_cont(i1)
7073         do jj=1,num_conti
7074           j=jcont(jj,i)
7075           do kk=1,num_conti1
7076             j1=jcont(kk,i1)
7077             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7078 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7079 cd   &                   ' ishift=',ishift
7080 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7081 C The system gains extra energy.
7082               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7083             endif   ! j1==j+-ishift
7084           enddo     ! kk
7085         enddo       ! jj
7086
7087         ENDDO ! ISHIFT
7088
7089       enddo         ! i
7090       return
7091       end
7092 c------------------------------------------------------------------------------
7093       double precision function esccorr(i,j,k,l,jj,kk)
7094       implicit real*8 (a-h,o-z)
7095       include 'DIMENSIONS'
7096       include 'COMMON.IOUNITS'
7097       include 'COMMON.DERIV'
7098       include 'COMMON.INTERACT'
7099       include 'COMMON.CONTACTS'
7100       include 'COMMON.CONTMAT'
7101       include 'COMMON.CORRMAT'
7102       double precision gx(3),gx1(3)
7103       logical lprn
7104       lprn=.false.
7105       eij=facont(jj,i)
7106       ekl=facont(kk,k)
7107 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7108 C Calculate the multi-body contribution to energy.
7109 C Calculate multi-body contributions to the gradient.
7110 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7111 cd   & k,l,(gacont(m,kk,k),m=1,3)
7112       do m=1,3
7113         gx(m) =ekl*gacont(m,jj,i)
7114         gx1(m)=eij*gacont(m,kk,k)
7115         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7116         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7117         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7118         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7119       enddo
7120       do m=i,j-1
7121         do ll=1,3
7122           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7123         enddo
7124       enddo
7125       do m=k,l-1
7126         do ll=1,3
7127           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7128         enddo
7129       enddo
7130       esccorr=-eij*ekl
7131       return
7132       end
7133 c------------------------------------------------------------------------------
7134       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7135 C This subroutine calculates multi-body contributions to hydrogen-bonding
7136       implicit real*8 (a-h,o-z)
7137       include 'DIMENSIONS'
7138       include 'DIMENSIONS.ZSCOPT'
7139       include 'COMMON.IOUNITS'
7140       include 'COMMON.FFIELD'
7141       include 'COMMON.DERIV'
7142       include 'COMMON.INTERACT'
7143       include 'COMMON.CONTACTS'
7144       include 'COMMON.CONTMAT'
7145       include 'COMMON.CORRMAT'
7146       double precision gx(3),gx1(3)
7147       logical lprn,ldone
7148
7149 C Set lprn=.true. for debugging
7150       lprn=.false.
7151       if (lprn) then
7152         write (iout,'(a)') 'Contact function values:'
7153         do i=nnt,nct-2
7154           write (iout,'(2i3,50(1x,i2,f5.2))')
7155      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7156      &    j=1,num_cont_hb(i))
7157         enddo
7158       endif
7159       ecorr=0.0D0
7160 C Remove the loop below after debugging !!!
7161       do i=nnt,nct
7162         do j=1,3
7163           gradcorr(j,i)=0.0D0
7164           gradxorr(j,i)=0.0D0
7165         enddo
7166       enddo
7167 C Calculate the local-electrostatic correlation terms
7168       do i=iatel_s,iatel_e+1
7169         i1=i+1
7170         num_conti=num_cont_hb(i)
7171         num_conti1=num_cont_hb(i+1)
7172         do jj=1,num_conti
7173           j=jcont_hb(jj,i)
7174           do kk=1,num_conti1
7175             j1=jcont_hb(kk,i1)
7176 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7177 c     &         ' jj=',jj,' kk=',kk
7178             if (j1.eq.j+1 .or. j1.eq.j-1) then
7179 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7180 C The system gains extra energy.
7181               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7182               n_corr=n_corr+1
7183             else if (j1.eq.j) then
7184 C Contacts I-J and I-(J+1) occur simultaneously.
7185 C The system loses extra energy.
7186 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7187             endif
7188           enddo ! kk
7189           do kk=1,num_conti
7190             j1=jcont_hb(kk,i)
7191 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7192 c    &         ' jj=',jj,' kk=',kk
7193             if (j1.eq.j+1) then
7194 C Contacts I-J and (I+1)-J occur simultaneously.
7195 C The system loses extra energy.
7196 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7197             endif ! j1==j+1
7198           enddo ! kk
7199         enddo ! jj
7200       enddo ! i
7201       return
7202       end
7203 c------------------------------------------------------------------------------
7204       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7205      &  n_corr1)
7206 C This subroutine calculates multi-body contributions to hydrogen-bonding
7207       implicit real*8 (a-h,o-z)
7208       include 'DIMENSIONS'
7209       include 'DIMENSIONS.ZSCOPT'
7210       include 'COMMON.IOUNITS'
7211 #ifdef MPI
7212       include "mpif.h"
7213 #endif
7214       include 'COMMON.FFIELD'
7215       include 'COMMON.DERIV'
7216       include 'COMMON.LOCAL'
7217       include 'COMMON.INTERACT'
7218       include 'COMMON.CONTACTS'
7219       include 'COMMON.CONTMAT'
7220       include 'COMMON.CORRMAT'
7221       include 'COMMON.CHAIN'
7222       include 'COMMON.CONTROL'
7223       include 'COMMON.SHIELD'
7224       double precision gx(3),gx1(3)
7225       integer num_cont_hb_old(maxres)
7226       logical lprn,ldone
7227       double precision eello4,eello5,eelo6,eello_turn6
7228       external eello4,eello5,eello6,eello_turn6
7229 C Set lprn=.true. for debugging
7230       lprn=.false.
7231       eturn6=0.0d0
7232       if (lprn) then
7233         write (iout,'(a)') 'Contact function values:'
7234         do i=nnt,nct-2
7235           write (iout,'(2i3,50(1x,i2,5f6.3))')
7236      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7237      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7238         enddo
7239       endif
7240       ecorr=0.0D0
7241       ecorr5=0.0d0
7242       ecorr6=0.0d0
7243 C Remove the loop below after debugging !!!
7244       do i=nnt,nct
7245         do j=1,3
7246           gradcorr(j,i)=0.0D0
7247           gradxorr(j,i)=0.0D0
7248         enddo
7249       enddo
7250 C Calculate the dipole-dipole interaction energies
7251       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7252       do i=iatel_s,iatel_e+1
7253         num_conti=num_cont_hb(i)
7254         do jj=1,num_conti
7255           j=jcont_hb(jj,i)
7256 #ifdef MOMENT
7257           call dipole(i,j,jj)
7258 #endif
7259         enddo
7260       enddo
7261       endif
7262 C Calculate the local-electrostatic correlation terms
7263 c                write (iout,*) "gradcorr5 in eello5 before loop"
7264 c                do iii=1,nres
7265 c                  write (iout,'(i5,3f10.5)')
7266 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7267 c                enddo
7268       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7269 c        write (iout,*) "corr loop i",i
7270         i1=i+1
7271         num_conti=num_cont_hb(i)
7272         num_conti1=num_cont_hb(i+1)
7273         do jj=1,num_conti
7274           j=jcont_hb(jj,i)
7275           jp=iabs(j)
7276           do kk=1,num_conti1
7277             j1=jcont_hb(kk,i1)
7278             jp1=iabs(j1)
7279 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7280 c     &         ' jj=',jj,' kk=',kk
7281 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7282             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7283      &          .or. j.lt.0 .and. j1.gt.0) .and.
7284      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7285 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7286 C The system gains extra energy.
7287               n_corr=n_corr+1
7288               sqd1=dsqrt(d_cont(jj,i))
7289               sqd2=dsqrt(d_cont(kk,i1))
7290               sred_geom = sqd1*sqd2
7291               IF (sred_geom.lt.cutoff_corr) THEN
7292                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7293      &            ekont,fprimcont)
7294 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7295 cd     &         ' jj=',jj,' kk=',kk
7296                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7297                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7298                 do l=1,3
7299                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7300                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7301                 enddo
7302                 n_corr1=n_corr1+1
7303 cd               write (iout,*) 'sred_geom=',sred_geom,
7304 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7305 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7306 cd               write (iout,*) "g_contij",g_contij
7307 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7308 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7309                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7310                 if (wcorr4.gt.0.0d0)
7311      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7312 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7313                   if (energy_dec.and.wcorr4.gt.0.0d0)
7314      1                 write (iout,'(a6,4i5,0pf7.3)')
7315      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7316 c                write (iout,*) "gradcorr5 before eello5"
7317 c                do iii=1,nres
7318 c                  write (iout,'(i5,3f10.5)')
7319 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7320 c                enddo
7321                 if (wcorr5.gt.0.0d0)
7322      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7323 c                write (iout,*) "gradcorr5 after eello5"
7324 c                do iii=1,nres
7325 c                  write (iout,'(i5,3f10.5)')
7326 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7327 c                enddo
7328                   if (energy_dec.and.wcorr5.gt.0.0d0)
7329      1                 write (iout,'(a6,4i5,0pf7.3)')
7330      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7331 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7332 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7333                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7334      &               .or. wturn6.eq.0.0d0))then
7335 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7336                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7337                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7338      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7339 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7340 cd     &            'ecorr6=',ecorr6
7341 cd                write (iout,'(4e15.5)') sred_geom,
7342 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7343 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7344 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7345                 else if (wturn6.gt.0.0d0
7346      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7347 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7348                   eturn6=eturn6+eello_turn6(i,jj,kk)
7349                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7350      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7351 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7352                 endif
7353               ENDIF
7354 1111          continue
7355             endif
7356           enddo ! kk
7357         enddo ! jj
7358       enddo ! i
7359       do i=1,nres
7360         num_cont_hb(i)=num_cont_hb_old(i)
7361       enddo
7362 c                write (iout,*) "gradcorr5 in eello5"
7363 c                do iii=1,nres
7364 c                  write (iout,'(i5,3f10.5)')
7365 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7366 c                enddo
7367       return
7368       end
7369 c------------------------------------------------------------------------------
7370       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7371       implicit real*8 (a-h,o-z)
7372       include 'DIMENSIONS'
7373       include 'DIMENSIONS.ZSCOPT'
7374       include 'COMMON.IOUNITS'
7375       include 'COMMON.DERIV'
7376       include 'COMMON.INTERACT'
7377       include 'COMMON.CONTACTS'
7378       include 'COMMON.CONTMAT'
7379       include 'COMMON.CORRMAT'
7380       include 'COMMON.SHIELD'
7381       include 'COMMON.CONTROL'
7382       double precision gx(3),gx1(3)
7383       logical lprn
7384       lprn=.false.
7385 C      print *,"wchodze",fac_shield(i),shield_mode
7386       eij=facont_hb(jj,i)
7387       ekl=facont_hb(kk,k)
7388       ees0pij=ees0p(jj,i)
7389       ees0pkl=ees0p(kk,k)
7390       ees0mij=ees0m(jj,i)
7391       ees0mkl=ees0m(kk,k)
7392       ekont=eij*ekl
7393       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7394 C*
7395 C     & fac_shield(i)**2*fac_shield(j)**2
7396 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7397 C Following 4 lines for diagnostics.
7398 cd    ees0pkl=0.0D0
7399 cd    ees0pij=1.0D0
7400 cd    ees0mkl=0.0D0
7401 cd    ees0mij=1.0D0
7402 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7403 c     & 'Contacts ',i,j,
7404 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7405 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7406 c     & 'gradcorr_long'
7407 C Calculate the multi-body contribution to energy.
7408 C      ecorr=ecorr+ekont*ees
7409 C Calculate multi-body contributions to the gradient.
7410       coeffpees0pij=coeffp*ees0pij
7411       coeffmees0mij=coeffm*ees0mij
7412       coeffpees0pkl=coeffp*ees0pkl
7413       coeffmees0mkl=coeffm*ees0mkl
7414       do ll=1,3
7415 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7416         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7417      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7418      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7419         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7420      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7421      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7422 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7423         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7424      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7425      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7426         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7427      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7428      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7429         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7430      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7431      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7432         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7433         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7434         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7435      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7436      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7437         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7438         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7439 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7440       enddo
7441 c      write (iout,*)
7442 cgrad      do m=i+1,j-1
7443 cgrad        do ll=1,3
7444 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7445 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7446 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7447 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7448 cgrad        enddo
7449 cgrad      enddo
7450 cgrad      do m=k+1,l-1
7451 cgrad        do ll=1,3
7452 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7453 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7454 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7455 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7456 cgrad        enddo
7457 cgrad      enddo
7458 c      write (iout,*) "ehbcorr",ekont*ees
7459 C      print *,ekont,ees,i,k
7460       ehbcorr=ekont*ees
7461 C now gradient over shielding
7462 C      return
7463       if (shield_mode.gt.0) then
7464        j=ees0plist(jj,i)
7465        l=ees0plist(kk,k)
7466 C        print *,i,j,fac_shield(i),fac_shield(j),
7467 C     &fac_shield(k),fac_shield(l)
7468         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7469      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7470           do ilist=1,ishield_list(i)
7471            iresshield=shield_list(ilist,i)
7472            do m=1,3
7473            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7474 C     &      *2.0
7475            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7476      &              rlocshield
7477      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7478             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7479      &+rlocshield
7480            enddo
7481           enddo
7482           do ilist=1,ishield_list(j)
7483            iresshield=shield_list(ilist,j)
7484            do m=1,3
7485            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7486 C     &     *2.0
7487            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7488      &              rlocshield
7489      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7490            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7491      &     +rlocshield
7492            enddo
7493           enddo
7494
7495           do ilist=1,ishield_list(k)
7496            iresshield=shield_list(ilist,k)
7497            do m=1,3
7498            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7499 C     &     *2.0
7500            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7501      &              rlocshield
7502      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7503            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7504      &     +rlocshield
7505            enddo
7506           enddo
7507           do ilist=1,ishield_list(l)
7508            iresshield=shield_list(ilist,l)
7509            do m=1,3
7510            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7511 C     &     *2.0
7512            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7513      &              rlocshield
7514      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7515            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7516      &     +rlocshield
7517            enddo
7518           enddo
7519 C          print *,gshieldx(m,iresshield)
7520           do m=1,3
7521             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7522      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7523             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7524      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7525             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7526      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7527             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7528      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7529
7530             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7531      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7532             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7533      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7534             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7535      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7536             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7537      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7538
7539            enddo
7540       endif
7541       endif
7542       return
7543       end
7544 #ifdef MOMENT
7545 C---------------------------------------------------------------------------
7546       subroutine dipole(i,j,jj)
7547       implicit real*8 (a-h,o-z)
7548       include 'DIMENSIONS'
7549       include 'DIMENSIONS.ZSCOPT'
7550       include 'COMMON.IOUNITS'
7551       include 'COMMON.CHAIN'
7552       include 'COMMON.FFIELD'
7553       include 'COMMON.DERIV'
7554       include 'COMMON.INTERACT'
7555       include 'COMMON.CONTACTS'
7556       include 'COMMON.CONTMAT'
7557       include 'COMMON.CORRMAT'
7558       include 'COMMON.TORSION'
7559       include 'COMMON.VAR'
7560       include 'COMMON.GEO'
7561       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7562      &  auxmat(2,2)
7563       iti1 = itortyp(itype(i+1))
7564       if (j.lt.nres-1) then
7565         itj1 = itype2loc(itype(j+1))
7566       else
7567         itj1=nloctyp
7568       endif
7569       do iii=1,2
7570         dipi(iii,1)=Ub2(iii,i)
7571         dipderi(iii)=Ub2der(iii,i)
7572         dipi(iii,2)=b1(iii,i+1)
7573         dipj(iii,1)=Ub2(iii,j)
7574         dipderj(iii)=Ub2der(iii,j)
7575         dipj(iii,2)=b1(iii,j+1)
7576       enddo
7577       kkk=0
7578       do iii=1,2
7579         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7580         do jjj=1,2
7581           kkk=kkk+1
7582           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7583         enddo
7584       enddo
7585       do kkk=1,5
7586         do lll=1,3
7587           mmm=0
7588           do iii=1,2
7589             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7590      &        auxvec(1))
7591             do jjj=1,2
7592               mmm=mmm+1
7593               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7594             enddo
7595           enddo
7596         enddo
7597       enddo
7598       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7599       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7600       do iii=1,2
7601         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7602       enddo
7603       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7604       do iii=1,2
7605         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7606       enddo
7607       return
7608       end
7609 #endif
7610 C---------------------------------------------------------------------------
7611       subroutine calc_eello(i,j,k,l,jj,kk)
7612 C
7613 C This subroutine computes matrices and vectors needed to calculate
7614 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7615 C
7616       implicit real*8 (a-h,o-z)
7617       include 'DIMENSIONS'
7618       include 'DIMENSIONS.ZSCOPT'
7619       include 'COMMON.IOUNITS'
7620       include 'COMMON.CHAIN'
7621       include 'COMMON.DERIV'
7622       include 'COMMON.INTERACT'
7623       include 'COMMON.CONTACTS'
7624       include 'COMMON.CONTMAT'
7625       include 'COMMON.CORRMAT'
7626       include 'COMMON.TORSION'
7627       include 'COMMON.VAR'
7628       include 'COMMON.GEO'
7629       include 'COMMON.FFIELD'
7630       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7631      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7632       logical lprn
7633       common /kutas/ lprn
7634 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7635 cd     & ' jj=',jj,' kk=',kk
7636 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7637 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7638 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7639       do iii=1,2
7640         do jjj=1,2
7641           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7642           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7643         enddo
7644       enddo
7645       call transpose2(aa1(1,1),aa1t(1,1))
7646       call transpose2(aa2(1,1),aa2t(1,1))
7647       do kkk=1,5
7648         do lll=1,3
7649           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7650      &      aa1tder(1,1,lll,kkk))
7651           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7652      &      aa2tder(1,1,lll,kkk))
7653         enddo
7654       enddo
7655       if (l.eq.j+1) then
7656 C parallel orientation of the two CA-CA-CA frames.
7657         if (i.gt.1) then
7658           iti=itype2loc(itype(i))
7659         else
7660           iti=nloctyp
7661         endif
7662         itk1=itype2loc(itype(k+1))
7663         itj=itype2loc(itype(j))
7664         if (l.lt.nres-1) then
7665           itl1=itype2loc(itype(l+1))
7666         else
7667           itl1=nloctyp
7668         endif
7669 C A1 kernel(j+1) A2T
7670 cd        do iii=1,2
7671 cd          write (iout,'(3f10.5,5x,3f10.5)')
7672 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7673 cd        enddo
7674         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7675      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7676      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7677 C Following matrices are needed only for 6-th order cumulants
7678         IF (wcorr6.gt.0.0d0) THEN
7679         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7680      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7681      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7682         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7683      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7684      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7685      &   ADtEAderx(1,1,1,1,1,1))
7686         lprn=.false.
7687         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7688      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7689      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7690      &   ADtEA1derx(1,1,1,1,1,1))
7691         ENDIF
7692 C End 6-th order cumulants
7693 cd        lprn=.false.
7694 cd        if (lprn) then
7695 cd        write (2,*) 'In calc_eello6'
7696 cd        do iii=1,2
7697 cd          write (2,*) 'iii=',iii
7698 cd          do kkk=1,5
7699 cd            write (2,*) 'kkk=',kkk
7700 cd            do jjj=1,2
7701 cd              write (2,'(3(2f10.5),5x)')
7702 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7703 cd            enddo
7704 cd          enddo
7705 cd        enddo
7706 cd        endif
7707         call transpose2(EUgder(1,1,k),auxmat(1,1))
7708         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7709         call transpose2(EUg(1,1,k),auxmat(1,1))
7710         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7711         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7712         do iii=1,2
7713           do kkk=1,5
7714             do lll=1,3
7715               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7716      &          EAEAderx(1,1,lll,kkk,iii,1))
7717             enddo
7718           enddo
7719         enddo
7720 C A1T kernel(i+1) A2
7721         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7722      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7723      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7724 C Following matrices are needed only for 6-th order cumulants
7725         IF (wcorr6.gt.0.0d0) THEN
7726         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7727      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7728      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7729         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7730      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7731      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7732      &   ADtEAderx(1,1,1,1,1,2))
7733         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7734      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7735      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7736      &   ADtEA1derx(1,1,1,1,1,2))
7737         ENDIF
7738 C End 6-th order cumulants
7739         call transpose2(EUgder(1,1,l),auxmat(1,1))
7740         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7741         call transpose2(EUg(1,1,l),auxmat(1,1))
7742         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7743         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7744         do iii=1,2
7745           do kkk=1,5
7746             do lll=1,3
7747               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7748      &          EAEAderx(1,1,lll,kkk,iii,2))
7749             enddo
7750           enddo
7751         enddo
7752 C AEAb1 and AEAb2
7753 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7754 C They are needed only when the fifth- or the sixth-order cumulants are
7755 C indluded.
7756         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7757         call transpose2(AEA(1,1,1),auxmat(1,1))
7758         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7759         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7760         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7761         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7762         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7763         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7764         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7765         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7766         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7767         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7768         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7769         call transpose2(AEA(1,1,2),auxmat(1,1))
7770         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7771         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7772         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7773         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7774         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7775         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7776         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7777         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7778         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7779         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7780         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7781 C Calculate the Cartesian derivatives of the vectors.
7782         do iii=1,2
7783           do kkk=1,5
7784             do lll=1,3
7785               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7786               call matvec2(auxmat(1,1),b1(1,i),
7787      &          AEAb1derx(1,lll,kkk,iii,1,1))
7788               call matvec2(auxmat(1,1),Ub2(1,i),
7789      &          AEAb2derx(1,lll,kkk,iii,1,1))
7790               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7791      &          AEAb1derx(1,lll,kkk,iii,2,1))
7792               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7793      &          AEAb2derx(1,lll,kkk,iii,2,1))
7794               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7795               call matvec2(auxmat(1,1),b1(1,j),
7796      &          AEAb1derx(1,lll,kkk,iii,1,2))
7797               call matvec2(auxmat(1,1),Ub2(1,j),
7798      &          AEAb2derx(1,lll,kkk,iii,1,2))
7799               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7800      &          AEAb1derx(1,lll,kkk,iii,2,2))
7801               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7802      &          AEAb2derx(1,lll,kkk,iii,2,2))
7803             enddo
7804           enddo
7805         enddo
7806         ENDIF
7807 C End vectors
7808       else
7809 C Antiparallel orientation of the two CA-CA-CA frames.
7810         if (i.gt.1) then
7811           iti=itype2loc(itype(i))
7812         else
7813           iti=nloctyp
7814         endif
7815         itk1=itype2loc(itype(k+1))
7816         itl=itype2loc(itype(l))
7817         itj=itype2loc(itype(j))
7818         if (j.lt.nres-1) then
7819           itj1=itype2loc(itype(j+1))
7820         else
7821           itj1=nloctyp
7822         endif
7823 C A2 kernel(j-1)T A1T
7824         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7825      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7826      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7827 C Following matrices are needed only for 6-th order cumulants
7828         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7829      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7830         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7831      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7832      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7833         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7834      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7835      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7836      &   ADtEAderx(1,1,1,1,1,1))
7837         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7838      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7839      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7840      &   ADtEA1derx(1,1,1,1,1,1))
7841         ENDIF
7842 C End 6-th order cumulants
7843         call transpose2(EUgder(1,1,k),auxmat(1,1))
7844         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7845         call transpose2(EUg(1,1,k),auxmat(1,1))
7846         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7847         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7848         do iii=1,2
7849           do kkk=1,5
7850             do lll=1,3
7851               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7852      &          EAEAderx(1,1,lll,kkk,iii,1))
7853             enddo
7854           enddo
7855         enddo
7856 C A2T kernel(i+1)T A1
7857         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7858      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7859      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7860 C Following matrices are needed only for 6-th order cumulants
7861         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7862      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7863         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7864      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7865      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7866         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7867      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7868      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7869      &   ADtEAderx(1,1,1,1,1,2))
7870         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7871      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7872      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7873      &   ADtEA1derx(1,1,1,1,1,2))
7874         ENDIF
7875 C End 6-th order cumulants
7876         call transpose2(EUgder(1,1,j),auxmat(1,1))
7877         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7878         call transpose2(EUg(1,1,j),auxmat(1,1))
7879         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7880         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7881         do iii=1,2
7882           do kkk=1,5
7883             do lll=1,3
7884               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7885      &          EAEAderx(1,1,lll,kkk,iii,2))
7886             enddo
7887           enddo
7888         enddo
7889 C AEAb1 and AEAb2
7890 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7891 C They are needed only when the fifth- or the sixth-order cumulants are
7892 C indluded.
7893         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7894      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7895         call transpose2(AEA(1,1,1),auxmat(1,1))
7896         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7897         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7898         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7899         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7900         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7901         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7902         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7903         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7904         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7905         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7906         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7907         call transpose2(AEA(1,1,2),auxmat(1,1))
7908         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7909         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7910         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7911         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7912         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7913         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7914         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7915         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7916         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7917         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7918         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7919 C Calculate the Cartesian derivatives of the vectors.
7920         do iii=1,2
7921           do kkk=1,5
7922             do lll=1,3
7923               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7924               call matvec2(auxmat(1,1),b1(1,i),
7925      &          AEAb1derx(1,lll,kkk,iii,1,1))
7926               call matvec2(auxmat(1,1),Ub2(1,i),
7927      &          AEAb2derx(1,lll,kkk,iii,1,1))
7928               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7929      &          AEAb1derx(1,lll,kkk,iii,2,1))
7930               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7931      &          AEAb2derx(1,lll,kkk,iii,2,1))
7932               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7933               call matvec2(auxmat(1,1),b1(1,l),
7934      &          AEAb1derx(1,lll,kkk,iii,1,2))
7935               call matvec2(auxmat(1,1),Ub2(1,l),
7936      &          AEAb2derx(1,lll,kkk,iii,1,2))
7937               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7938      &          AEAb1derx(1,lll,kkk,iii,2,2))
7939               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7940      &          AEAb2derx(1,lll,kkk,iii,2,2))
7941             enddo
7942           enddo
7943         enddo
7944         ENDIF
7945 C End vectors
7946       endif
7947       return
7948       end
7949 C---------------------------------------------------------------------------
7950       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7951      &  KK,KKderg,AKA,AKAderg,AKAderx)
7952       implicit none
7953       integer nderg
7954       logical transp
7955       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7956      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7957      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7958       integer iii,kkk,lll
7959       integer jjj,mmm
7960       logical lprn
7961       common /kutas/ lprn
7962       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7963       do iii=1,nderg
7964         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7965      &    AKAderg(1,1,iii))
7966       enddo
7967 cd      if (lprn) write (2,*) 'In kernel'
7968       do kkk=1,5
7969 cd        if (lprn) write (2,*) 'kkk=',kkk
7970         do lll=1,3
7971           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7972      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7973 cd          if (lprn) then
7974 cd            write (2,*) 'lll=',lll
7975 cd            write (2,*) 'iii=1'
7976 cd            do jjj=1,2
7977 cd              write (2,'(3(2f10.5),5x)')
7978 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7979 cd            enddo
7980 cd          endif
7981           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7982      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7983 cd          if (lprn) then
7984 cd            write (2,*) 'lll=',lll
7985 cd            write (2,*) 'iii=2'
7986 cd            do jjj=1,2
7987 cd              write (2,'(3(2f10.5),5x)')
7988 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7989 cd            enddo
7990 cd          endif
7991         enddo
7992       enddo
7993       return
7994       end
7995 C---------------------------------------------------------------------------
7996       double precision function eello4(i,j,k,l,jj,kk)
7997       implicit real*8 (a-h,o-z)
7998       include 'DIMENSIONS'
7999       include 'DIMENSIONS.ZSCOPT'
8000       include 'COMMON.IOUNITS'
8001       include 'COMMON.CHAIN'
8002       include 'COMMON.DERIV'
8003       include 'COMMON.INTERACT'
8004       include 'COMMON.CONTACTS'
8005       include 'COMMON.CONTMAT'
8006       include 'COMMON.CORRMAT'
8007       include 'COMMON.TORSION'
8008       include 'COMMON.VAR'
8009       include 'COMMON.GEO'
8010       double precision pizda(2,2),ggg1(3),ggg2(3)
8011 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8012 cd        eello4=0.0d0
8013 cd        return
8014 cd      endif
8015 cd      print *,'eello4:',i,j,k,l,jj,kk
8016 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8017 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8018 cold      eij=facont_hb(jj,i)
8019 cold      ekl=facont_hb(kk,k)
8020 cold      ekont=eij*ekl
8021       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8022       if (calc_grad) then
8023 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8024       gcorr_loc(k-1)=gcorr_loc(k-1)
8025      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8026       if (l.eq.j+1) then
8027         gcorr_loc(l-1)=gcorr_loc(l-1)
8028      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8029       else
8030         gcorr_loc(j-1)=gcorr_loc(j-1)
8031      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8032       endif
8033       do iii=1,2
8034         do kkk=1,5
8035           do lll=1,3
8036             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8037      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8038 cd            derx(lll,kkk,iii)=0.0d0
8039           enddo
8040         enddo
8041       enddo
8042 cd      gcorr_loc(l-1)=0.0d0
8043 cd      gcorr_loc(j-1)=0.0d0
8044 cd      gcorr_loc(k-1)=0.0d0
8045 cd      eel4=1.0d0
8046 cd      write (iout,*)'Contacts have occurred for peptide groups',
8047 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8048 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8049       if (j.lt.nres-1) then
8050         j1=j+1
8051         j2=j-1
8052       else
8053         j1=j-1
8054         j2=j-2
8055       endif
8056       if (l.lt.nres-1) then
8057         l1=l+1
8058         l2=l-1
8059       else
8060         l1=l-1
8061         l2=l-2
8062       endif
8063       do ll=1,3
8064 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8065 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8066         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8067         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8068 cgrad        ghalf=0.5d0*ggg1(ll)
8069         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8070         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8071         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8072         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8073         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8074         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8075 cgrad        ghalf=0.5d0*ggg2(ll)
8076         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8077         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8078         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8079         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8080         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8081         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8082       enddo
8083 cgrad      do m=i+1,j-1
8084 cgrad        do ll=1,3
8085 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8086 cgrad        enddo
8087 cgrad      enddo
8088 cgrad      do m=k+1,l-1
8089 cgrad        do ll=1,3
8090 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8091 cgrad        enddo
8092 cgrad      enddo
8093 cgrad      do m=i+2,j2
8094 cgrad        do ll=1,3
8095 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8096 cgrad        enddo
8097 cgrad      enddo
8098 cgrad      do m=k+2,l2
8099 cgrad        do ll=1,3
8100 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8101 cgrad        enddo
8102 cgrad      enddo
8103 cd      do iii=1,nres-3
8104 cd        write (2,*) iii,gcorr_loc(iii)
8105 cd      enddo
8106       endif ! calc_grad
8107       eello4=ekont*eel4
8108 cd      write (2,*) 'ekont',ekont
8109 cd      write (iout,*) 'eello4',ekont*eel4
8110       return
8111       end
8112 C---------------------------------------------------------------------------
8113       double precision function eello5(i,j,k,l,jj,kk)
8114       implicit real*8 (a-h,o-z)
8115       include 'DIMENSIONS'
8116       include 'DIMENSIONS.ZSCOPT'
8117       include 'COMMON.IOUNITS'
8118       include 'COMMON.CHAIN'
8119       include 'COMMON.DERIV'
8120       include 'COMMON.INTERACT'
8121       include 'COMMON.CONTACTS'
8122       include 'COMMON.CONTMAT'
8123       include 'COMMON.CORRMAT'
8124       include 'COMMON.TORSION'
8125       include 'COMMON.VAR'
8126       include 'COMMON.GEO'
8127       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8128       double precision ggg1(3),ggg2(3)
8129 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8130 C                                                                              C
8131 C                            Parallel chains                                   C
8132 C                                                                              C
8133 C          o             o                   o             o                   C
8134 C         /l\           / \             \   / \           / \   /              C
8135 C        /   \         /   \             \ /   \         /   \ /               C
8136 C       j| o |l1       | o |              o| o |         | o |o                C
8137 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8138 C      \i/   \         /   \ /             /   \         /   \                 C
8139 C       o    k1             o                                                  C
8140 C         (I)          (II)                (III)          (IV)                 C
8141 C                                                                              C
8142 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8143 C                                                                              C
8144 C                            Antiparallel chains                               C
8145 C                                                                              C
8146 C          o             o                   o             o                   C
8147 C         /j\           / \             \   / \           / \   /              C
8148 C        /   \         /   \             \ /   \         /   \ /               C
8149 C      j1| o |l        | o |              o| o |         | o |o                C
8150 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8151 C      \i/   \         /   \ /             /   \         /   \                 C
8152 C       o     k1            o                                                  C
8153 C         (I)          (II)                (III)          (IV)                 C
8154 C                                                                              C
8155 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8156 C                                                                              C
8157 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8158 C                                                                              C
8159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8160 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8161 cd        eello5=0.0d0
8162 cd        return
8163 cd      endif
8164 cd      write (iout,*)
8165 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8166 cd     &   ' and',k,l
8167       itk=itype2loc(itype(k))
8168       itl=itype2loc(itype(l))
8169       itj=itype2loc(itype(j))
8170       eello5_1=0.0d0
8171       eello5_2=0.0d0
8172       eello5_3=0.0d0
8173       eello5_4=0.0d0
8174 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8175 cd     &   eel5_3_num,eel5_4_num)
8176       do iii=1,2
8177         do kkk=1,5
8178           do lll=1,3
8179             derx(lll,kkk,iii)=0.0d0
8180           enddo
8181         enddo
8182       enddo
8183 cd      eij=facont_hb(jj,i)
8184 cd      ekl=facont_hb(kk,k)
8185 cd      ekont=eij*ekl
8186 cd      write (iout,*)'Contacts have occurred for peptide groups',
8187 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8188 cd      goto 1111
8189 C Contribution from the graph I.
8190 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8191 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8192       call transpose2(EUg(1,1,k),auxmat(1,1))
8193       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8194       vv(1)=pizda(1,1)-pizda(2,2)
8195       vv(2)=pizda(1,2)+pizda(2,1)
8196       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8197      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8198       if (calc_grad) then
8199 C Explicit gradient in virtual-dihedral angles.
8200       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8201      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8202      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8203       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8204       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8205       vv(1)=pizda(1,1)-pizda(2,2)
8206       vv(2)=pizda(1,2)+pizda(2,1)
8207       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8208      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8209      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8210       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8211       vv(1)=pizda(1,1)-pizda(2,2)
8212       vv(2)=pizda(1,2)+pizda(2,1)
8213       if (l.eq.j+1) then
8214         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8215      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8216      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8217       else
8218         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8219      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8220      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8221       endif
8222 C Cartesian gradient
8223       do iii=1,2
8224         do kkk=1,5
8225           do lll=1,3
8226             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8227      &        pizda(1,1))
8228             vv(1)=pizda(1,1)-pizda(2,2)
8229             vv(2)=pizda(1,2)+pizda(2,1)
8230             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8231      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8232      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8233           enddo
8234         enddo
8235       enddo
8236       endif ! calc_grad
8237 c      goto 1112
8238 c1111  continue
8239 C Contribution from graph II
8240       call transpose2(EE(1,1,k),auxmat(1,1))
8241       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8242       vv(1)=pizda(1,1)+pizda(2,2)
8243       vv(2)=pizda(2,1)-pizda(1,2)
8244       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8245      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8246       if (calc_grad) then
8247 C Explicit gradient in virtual-dihedral angles.
8248       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8249      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8250       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8251       vv(1)=pizda(1,1)+pizda(2,2)
8252       vv(2)=pizda(2,1)-pizda(1,2)
8253       if (l.eq.j+1) then
8254         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8255      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8256      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8257       else
8258         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8259      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8260      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8261       endif
8262 C Cartesian gradient
8263       do iii=1,2
8264         do kkk=1,5
8265           do lll=1,3
8266             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8267      &        pizda(1,1))
8268             vv(1)=pizda(1,1)+pizda(2,2)
8269             vv(2)=pizda(2,1)-pizda(1,2)
8270             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8271      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8272      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8273           enddo
8274         enddo
8275       enddo
8276       endif ! calc_grad
8277 cd      goto 1112
8278 cd1111  continue
8279       if (l.eq.j+1) then
8280 cd        goto 1110
8281 C Parallel orientation
8282 C Contribution from graph III
8283         call transpose2(EUg(1,1,l),auxmat(1,1))
8284         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8285         vv(1)=pizda(1,1)-pizda(2,2)
8286         vv(2)=pizda(1,2)+pizda(2,1)
8287         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8288      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8289         if (calc_grad) then
8290 C Explicit gradient in virtual-dihedral angles.
8291         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8292      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8293      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8294         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8295         vv(1)=pizda(1,1)-pizda(2,2)
8296         vv(2)=pizda(1,2)+pizda(2,1)
8297         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8298      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8299      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8300         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8301         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8302         vv(1)=pizda(1,1)-pizda(2,2)
8303         vv(2)=pizda(1,2)+pizda(2,1)
8304         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8305      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8306      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8307 C Cartesian gradient
8308         do iii=1,2
8309           do kkk=1,5
8310             do lll=1,3
8311               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8312      &          pizda(1,1))
8313               vv(1)=pizda(1,1)-pizda(2,2)
8314               vv(2)=pizda(1,2)+pizda(2,1)
8315               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8316      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8317      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8318             enddo
8319           enddo
8320         enddo
8321 cd        goto 1112
8322 C Contribution from graph IV
8323 cd1110    continue
8324         call transpose2(EE(1,1,l),auxmat(1,1))
8325         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8326         vv(1)=pizda(1,1)+pizda(2,2)
8327         vv(2)=pizda(2,1)-pizda(1,2)
8328         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8329      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8330 C Explicit gradient in virtual-dihedral angles.
8331         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8332      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8333         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8334         vv(1)=pizda(1,1)+pizda(2,2)
8335         vv(2)=pizda(2,1)-pizda(1,2)
8336         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8337      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8338      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8339 C Cartesian gradient
8340         do iii=1,2
8341           do kkk=1,5
8342             do lll=1,3
8343               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8344      &          pizda(1,1))
8345               vv(1)=pizda(1,1)+pizda(2,2)
8346               vv(2)=pizda(2,1)-pizda(1,2)
8347               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8348      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8349      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8350             enddo
8351           enddo
8352         enddo
8353         endif ! calc_grad
8354       else
8355 C Antiparallel orientation
8356 C Contribution from graph III
8357 c        goto 1110
8358         call transpose2(EUg(1,1,j),auxmat(1,1))
8359         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8363      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8364         if (calc_grad) then
8365 C Explicit gradient in virtual-dihedral angles.
8366         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8367      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8368      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8369         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8370         vv(1)=pizda(1,1)-pizda(2,2)
8371         vv(2)=pizda(1,2)+pizda(2,1)
8372         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8373      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8374      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8375         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8376         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8377         vv(1)=pizda(1,1)-pizda(2,2)
8378         vv(2)=pizda(1,2)+pizda(2,1)
8379         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8380      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8381      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8382 C Cartesian gradient
8383         do iii=1,2
8384           do kkk=1,5
8385             do lll=1,3
8386               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8387      &          pizda(1,1))
8388               vv(1)=pizda(1,1)-pizda(2,2)
8389               vv(2)=pizda(1,2)+pizda(2,1)
8390               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8391      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8392      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8393             enddo
8394           enddo
8395         enddo
8396         endif ! calc_grad
8397 cd        goto 1112
8398 C Contribution from graph IV
8399 1110    continue
8400         call transpose2(EE(1,1,j),auxmat(1,1))
8401         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8402         vv(1)=pizda(1,1)+pizda(2,2)
8403         vv(2)=pizda(2,1)-pizda(1,2)
8404         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8405      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8406         if (calc_grad) then
8407 C Explicit gradient in virtual-dihedral angles.
8408         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8409      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8410         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8411         vv(1)=pizda(1,1)+pizda(2,2)
8412         vv(2)=pizda(2,1)-pizda(1,2)
8413         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8414      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8415      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8416 C Cartesian gradient
8417         do iii=1,2
8418           do kkk=1,5
8419             do lll=1,3
8420               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8421      &          pizda(1,1))
8422               vv(1)=pizda(1,1)+pizda(2,2)
8423               vv(2)=pizda(2,1)-pizda(1,2)
8424               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8425      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8426      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8427             enddo
8428           enddo
8429         enddo
8430         endif ! calc_grad
8431       endif
8432 1112  continue
8433       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8434 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8435 cd        write (2,*) 'ijkl',i,j,k,l
8436 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8437 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8438 cd      endif
8439 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8440 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8441 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8442 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8443       if (calc_grad) then
8444       if (j.lt.nres-1) then
8445         j1=j+1
8446         j2=j-1
8447       else
8448         j1=j-1
8449         j2=j-2
8450       endif
8451       if (l.lt.nres-1) then
8452         l1=l+1
8453         l2=l-1
8454       else
8455         l1=l-1
8456         l2=l-2
8457       endif
8458 cd      eij=1.0d0
8459 cd      ekl=1.0d0
8460 cd      ekont=1.0d0
8461 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8462 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8463 C        summed up outside the subrouine as for the other subroutines
8464 C        handling long-range interactions. The old code is commented out
8465 C        with "cgrad" to keep track of changes.
8466       do ll=1,3
8467 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8468 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8469         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8470         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8471 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8472 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8473 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8474 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8475 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8476 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8477 c     &   gradcorr5ij,
8478 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8479 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8480 cgrad        ghalf=0.5d0*ggg1(ll)
8481 cd        ghalf=0.0d0
8482         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8483         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8484         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8485         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8486         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8487         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8488 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8489 cgrad        ghalf=0.5d0*ggg2(ll)
8490 cd        ghalf=0.0d0
8491         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8492         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8493         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8494         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8495         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8496         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8497       enddo
8498       endif ! calc_grad
8499 cd      goto 1112
8500 cgrad      do m=i+1,j-1
8501 cgrad        do ll=1,3
8502 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8503 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8504 cgrad        enddo
8505 cgrad      enddo
8506 cgrad      do m=k+1,l-1
8507 cgrad        do ll=1,3
8508 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8509 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8510 cgrad        enddo
8511 cgrad      enddo
8512 c1112  continue
8513 cgrad      do m=i+2,j2
8514 cgrad        do ll=1,3
8515 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8516 cgrad        enddo
8517 cgrad      enddo
8518 cgrad      do m=k+2,l2
8519 cgrad        do ll=1,3
8520 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8521 cgrad        enddo
8522 cgrad      enddo
8523 cd      do iii=1,nres-3
8524 cd        write (2,*) iii,g_corr5_loc(iii)
8525 cd      enddo
8526       eello5=ekont*eel5
8527 cd      write (2,*) 'ekont',ekont
8528 cd      write (iout,*) 'eello5',ekont*eel5
8529       return
8530       end
8531 c--------------------------------------------------------------------------
8532       double precision function eello6(i,j,k,l,jj,kk)
8533       implicit real*8 (a-h,o-z)
8534       include 'DIMENSIONS'
8535       include 'DIMENSIONS.ZSCOPT'
8536       include 'COMMON.IOUNITS'
8537       include 'COMMON.CHAIN'
8538       include 'COMMON.DERIV'
8539       include 'COMMON.INTERACT'
8540       include 'COMMON.CONTACTS'
8541       include 'COMMON.CONTMAT'
8542       include 'COMMON.CORRMAT'
8543       include 'COMMON.TORSION'
8544       include 'COMMON.VAR'
8545       include 'COMMON.GEO'
8546       include 'COMMON.FFIELD'
8547       double precision ggg1(3),ggg2(3)
8548 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8549 cd        eello6=0.0d0
8550 cd        return
8551 cd      endif
8552 cd      write (iout,*)
8553 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8554 cd     &   ' and',k,l
8555       eello6_1=0.0d0
8556       eello6_2=0.0d0
8557       eello6_3=0.0d0
8558       eello6_4=0.0d0
8559       eello6_5=0.0d0
8560       eello6_6=0.0d0
8561 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8562 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8563       do iii=1,2
8564         do kkk=1,5
8565           do lll=1,3
8566             derx(lll,kkk,iii)=0.0d0
8567           enddo
8568         enddo
8569       enddo
8570 cd      eij=facont_hb(jj,i)
8571 cd      ekl=facont_hb(kk,k)
8572 cd      ekont=eij*ekl
8573 cd      eij=1.0d0
8574 cd      ekl=1.0d0
8575 cd      ekont=1.0d0
8576       if (l.eq.j+1) then
8577         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8578         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8579         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8580         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8581         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8582         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8583       else
8584         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8585         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8586         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8587         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8588         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8589           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8590         else
8591           eello6_5=0.0d0
8592         endif
8593         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8594       endif
8595 C If turn contributions are considered, they will be handled separately.
8596       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8597 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8598 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8599 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8600 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8601 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8602 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8603 cd      goto 1112
8604       if (calc_grad) then
8605       if (j.lt.nres-1) then
8606         j1=j+1
8607         j2=j-1
8608       else
8609         j1=j-1
8610         j2=j-2
8611       endif
8612       if (l.lt.nres-1) then
8613         l1=l+1
8614         l2=l-1
8615       else
8616         l1=l-1
8617         l2=l-2
8618       endif
8619       do ll=1,3
8620 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8621 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8622 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8623 cgrad        ghalf=0.5d0*ggg1(ll)
8624 cd        ghalf=0.0d0
8625         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8626         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8627         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8628         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8629         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8630         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8631         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8632         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8633 cgrad        ghalf=0.5d0*ggg2(ll)
8634 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8635 cd        ghalf=0.0d0
8636         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8637         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8638         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8639         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8640         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8641         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8642       enddo
8643       endif ! calc_grad
8644 cd      goto 1112
8645 cgrad      do m=i+1,j-1
8646 cgrad        do ll=1,3
8647 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8648 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8649 cgrad        enddo
8650 cgrad      enddo
8651 cgrad      do m=k+1,l-1
8652 cgrad        do ll=1,3
8653 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8654 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8655 cgrad        enddo
8656 cgrad      enddo
8657 cgrad1112  continue
8658 cgrad      do m=i+2,j2
8659 cgrad        do ll=1,3
8660 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8661 cgrad        enddo
8662 cgrad      enddo
8663 cgrad      do m=k+2,l2
8664 cgrad        do ll=1,3
8665 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8666 cgrad        enddo
8667 cgrad      enddo
8668 cd      do iii=1,nres-3
8669 cd        write (2,*) iii,g_corr6_loc(iii)
8670 cd      enddo
8671       eello6=ekont*eel6
8672 cd      write (2,*) 'ekont',ekont
8673 cd      write (iout,*) 'eello6',ekont*eel6
8674       return
8675       end
8676 c--------------------------------------------------------------------------
8677       double precision function eello6_graph1(i,j,k,l,imat,swap)
8678       implicit real*8 (a-h,o-z)
8679       include 'DIMENSIONS'
8680       include 'DIMENSIONS.ZSCOPT'
8681       include 'COMMON.IOUNITS'
8682       include 'COMMON.CHAIN'
8683       include 'COMMON.DERIV'
8684       include 'COMMON.INTERACT'
8685       include 'COMMON.CONTACTS'
8686       include 'COMMON.CONTMAT'
8687       include 'COMMON.CORRMAT'
8688       include 'COMMON.TORSION'
8689       include 'COMMON.VAR'
8690       include 'COMMON.GEO'
8691       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8692       logical swap
8693       logical lprn
8694       common /kutas/ lprn
8695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8696 C                                                                              C
8697 C      Parallel       Antiparallel                                             C
8698 C                                                                              C
8699 C          o             o                                                     C
8700 C         /l\           /j\                                                    C
8701 C        /   \         /   \                                                   C
8702 C       /| o |         | o |\                                                  C
8703 C     \ j|/k\|  /   \  |/k\|l /                                                C
8704 C      \ /   \ /     \ /   \ /                                                 C
8705 C       o     o       o     o                                                  C
8706 C       i             i                                                        C
8707 C                                                                              C
8708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8709       itk=itype2loc(itype(k))
8710       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8711       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8712       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8713       call transpose2(EUgC(1,1,k),auxmat(1,1))
8714       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8715       vv1(1)=pizda1(1,1)-pizda1(2,2)
8716       vv1(2)=pizda1(1,2)+pizda1(2,1)
8717       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8718       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8719       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8720       s5=scalar2(vv(1),Dtobr2(1,i))
8721 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8722       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8723       if (calc_grad) then
8724       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8725      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8726      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8727      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8728      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8729      & +scalar2(vv(1),Dtobr2der(1,i)))
8730       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8731       vv1(1)=pizda1(1,1)-pizda1(2,2)
8732       vv1(2)=pizda1(1,2)+pizda1(2,1)
8733       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8734       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8735       if (l.eq.j+1) then
8736         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8737      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8738      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8739      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8740      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8741       else
8742         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8743      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8744      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8745      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8746      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8747       endif
8748       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8749       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8750       vv1(1)=pizda1(1,1)-pizda1(2,2)
8751       vv1(2)=pizda1(1,2)+pizda1(2,1)
8752       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8753      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8754      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8755      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8756       do iii=1,2
8757         if (swap) then
8758           ind=3-iii
8759         else
8760           ind=iii
8761         endif
8762         do kkk=1,5
8763           do lll=1,3
8764             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8765             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8766             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8767             call transpose2(EUgC(1,1,k),auxmat(1,1))
8768             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8769      &        pizda1(1,1))
8770             vv1(1)=pizda1(1,1)-pizda1(2,2)
8771             vv1(2)=pizda1(1,2)+pizda1(2,1)
8772             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8773             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8774      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8775             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8776      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8777             s5=scalar2(vv(1),Dtobr2(1,i))
8778             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8779           enddo
8780         enddo
8781       enddo
8782       endif ! calc_grad
8783       return
8784       end
8785 c----------------------------------------------------------------------------
8786       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8787       implicit real*8 (a-h,o-z)
8788       include 'DIMENSIONS'
8789       include 'DIMENSIONS.ZSCOPT'
8790       include 'COMMON.IOUNITS'
8791       include 'COMMON.CHAIN'
8792       include 'COMMON.DERIV'
8793       include 'COMMON.INTERACT'
8794       include 'COMMON.CONTACTS'
8795       include 'COMMON.CONTMAT'
8796       include 'COMMON.CORRMAT'
8797       include 'COMMON.TORSION'
8798       include 'COMMON.VAR'
8799       include 'COMMON.GEO'
8800       logical swap
8801       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8802      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8803       logical lprn
8804       common /kutas/ lprn
8805 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8806 C                                                                              C
8807 C      Parallel       Antiparallel                                             C
8808 C                                                                              C
8809 C          o             o                                                     C
8810 C     \   /l\           /j\   /                                                C
8811 C      \ /   \         /   \ /                                                 C
8812 C       o| o |         | o |o                                                  C
8813 C     \ j|/k\|      \  |/k\|l                                                  C
8814 C      \ /   \       \ /   \                                                   C
8815 C       o             o                                                        C
8816 C       i             i                                                        C
8817 C                                                                              C
8818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8819 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8820 C AL 7/4/01 s1 would occur in the sixth-order moment,
8821 C           but not in a cluster cumulant
8822 #ifdef MOMENT
8823       s1=dip(1,jj,i)*dip(1,kk,k)
8824 #endif
8825       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8826       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8827       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8828       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8829       call transpose2(EUg(1,1,k),auxmat(1,1))
8830       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8831       vv(1)=pizda(1,1)-pizda(2,2)
8832       vv(2)=pizda(1,2)+pizda(2,1)
8833       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8834 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8835 #ifdef MOMENT
8836       eello6_graph2=-(s1+s2+s3+s4)
8837 #else
8838       eello6_graph2=-(s2+s3+s4)
8839 #endif
8840 c      eello6_graph2=-s3
8841 C Derivatives in gamma(i-1)
8842       if (calc_grad) then
8843       if (i.gt.1) then
8844 #ifdef MOMENT
8845         s1=dipderg(1,jj,i)*dip(1,kk,k)
8846 #endif
8847         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8848         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8849         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8850         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8851 #ifdef MOMENT
8852         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8853 #else
8854         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8855 #endif
8856 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8857       endif
8858 C Derivatives in gamma(k-1)
8859 #ifdef MOMENT
8860       s1=dip(1,jj,i)*dipderg(1,kk,k)
8861 #endif
8862       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8863       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8864       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8865       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8866       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8867       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8868       vv(1)=pizda(1,1)-pizda(2,2)
8869       vv(2)=pizda(1,2)+pizda(2,1)
8870       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8871 #ifdef MOMENT
8872       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8873 #else
8874       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8875 #endif
8876 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8877 C Derivatives in gamma(j-1) or gamma(l-1)
8878       if (j.gt.1) then
8879 #ifdef MOMENT
8880         s1=dipderg(3,jj,i)*dip(1,kk,k)
8881 #endif
8882         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8883         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8884         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8885         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8886         vv(1)=pizda(1,1)-pizda(2,2)
8887         vv(2)=pizda(1,2)+pizda(2,1)
8888         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8889 #ifdef MOMENT
8890         if (swap) then
8891           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8892         else
8893           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8894         endif
8895 #endif
8896         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8897 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8898       endif
8899 C Derivatives in gamma(l-1) or gamma(j-1)
8900       if (l.gt.1) then
8901 #ifdef MOMENT
8902         s1=dip(1,jj,i)*dipderg(3,kk,k)
8903 #endif
8904         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8905         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8906         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8907         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8908         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8909         vv(1)=pizda(1,1)-pizda(2,2)
8910         vv(2)=pizda(1,2)+pizda(2,1)
8911         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8912 #ifdef MOMENT
8913         if (swap) then
8914           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8915         else
8916           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8917         endif
8918 #endif
8919         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8920 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8921       endif
8922 C Cartesian derivatives.
8923       if (lprn) then
8924         write (2,*) 'In eello6_graph2'
8925         do iii=1,2
8926           write (2,*) 'iii=',iii
8927           do kkk=1,5
8928             write (2,*) 'kkk=',kkk
8929             do jjj=1,2
8930               write (2,'(3(2f10.5),5x)')
8931      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8932             enddo
8933           enddo
8934         enddo
8935       endif
8936       do iii=1,2
8937         do kkk=1,5
8938           do lll=1,3
8939 #ifdef MOMENT
8940             if (iii.eq.1) then
8941               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8942             else
8943               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8944             endif
8945 #endif
8946             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8947      &        auxvec(1))
8948             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8949             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8950      &        auxvec(1))
8951             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8952             call transpose2(EUg(1,1,k),auxmat(1,1))
8953             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8954      &        pizda(1,1))
8955             vv(1)=pizda(1,1)-pizda(2,2)
8956             vv(2)=pizda(1,2)+pizda(2,1)
8957             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8958 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8959 #ifdef MOMENT
8960             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8961 #else
8962             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8963 #endif
8964             if (swap) then
8965               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8966             else
8967               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8968             endif
8969           enddo
8970         enddo
8971       enddo
8972       endif ! calc_grad
8973       return
8974       end
8975 c----------------------------------------------------------------------------
8976       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8977       implicit real*8 (a-h,o-z)
8978       include 'DIMENSIONS'
8979       include 'DIMENSIONS.ZSCOPT'
8980       include 'COMMON.IOUNITS'
8981       include 'COMMON.CHAIN'
8982       include 'COMMON.DERIV'
8983       include 'COMMON.INTERACT'
8984       include 'COMMON.CONTACTS'
8985       include 'COMMON.CONTMAT'
8986       include 'COMMON.CORRMAT'
8987       include 'COMMON.TORSION'
8988       include 'COMMON.VAR'
8989       include 'COMMON.GEO'
8990       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8991       logical swap
8992 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8993 C                                                                              C
8994 C      Parallel       Antiparallel                                             C
8995 C                                                                              C
8996 C          o             o                                                     C
8997 C         /l\   /   \   /j\                                                    C
8998 C        /   \ /     \ /   \                                                   C
8999 C       /| o |o       o| o |\                                                  C
9000 C       j|/k\|  /      |/k\|l /                                                C
9001 C        /   \ /       /   \ /                                                 C
9002 C       /     o       /     o                                                  C
9003 C       i             i                                                        C
9004 C                                                                              C
9005 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9006 C
9007 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9008 C           energy moment and not to the cluster cumulant.
9009       iti=itortyp(itype(i))
9010       if (j.lt.nres-1) then
9011         itj1=itype2loc(itype(j+1))
9012       else
9013         itj1=nloctyp
9014       endif
9015       itk=itype2loc(itype(k))
9016       itk1=itype2loc(itype(k+1))
9017       if (l.lt.nres-1) then
9018         itl1=itype2loc(itype(l+1))
9019       else
9020         itl1=nloctyp
9021       endif
9022 #ifdef MOMENT
9023       s1=dip(4,jj,i)*dip(4,kk,k)
9024 #endif
9025       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9026       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9027       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9028       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9029       call transpose2(EE(1,1,k),auxmat(1,1))
9030       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9031       vv(1)=pizda(1,1)+pizda(2,2)
9032       vv(2)=pizda(2,1)-pizda(1,2)
9033       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9034 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9035 cd     & "sum",-(s2+s3+s4)
9036 #ifdef MOMENT
9037       eello6_graph3=-(s1+s2+s3+s4)
9038 #else
9039       eello6_graph3=-(s2+s3+s4)
9040 #endif
9041 c      eello6_graph3=-s4
9042 C Derivatives in gamma(k-1)
9043       if (calc_grad) then
9044       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9045       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9046       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9047       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9048 C Derivatives in gamma(l-1)
9049       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9050       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9051       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9052       vv(1)=pizda(1,1)+pizda(2,2)
9053       vv(2)=pizda(2,1)-pizda(1,2)
9054       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9055       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9056 C Cartesian derivatives.
9057       do iii=1,2
9058         do kkk=1,5
9059           do lll=1,3
9060 #ifdef MOMENT
9061             if (iii.eq.1) then
9062               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9063             else
9064               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9065             endif
9066 #endif
9067             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9068      &        auxvec(1))
9069             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9070             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9071      &        auxvec(1))
9072             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9073             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9074      &        pizda(1,1))
9075             vv(1)=pizda(1,1)+pizda(2,2)
9076             vv(2)=pizda(2,1)-pizda(1,2)
9077             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9078 #ifdef MOMENT
9079             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9080 #else
9081             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9082 #endif
9083             if (swap) then
9084               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9085             else
9086               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9087             endif
9088 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9089           enddo
9090         enddo
9091       enddo
9092       endif ! calc_grad
9093       return
9094       end
9095 c----------------------------------------------------------------------------
9096       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9097       implicit real*8 (a-h,o-z)
9098       include 'DIMENSIONS'
9099       include 'DIMENSIONS.ZSCOPT'
9100       include 'COMMON.IOUNITS'
9101       include 'COMMON.CHAIN'
9102       include 'COMMON.DERIV'
9103       include 'COMMON.INTERACT'
9104       include 'COMMON.CONTACTS'
9105       include 'COMMON.CONTMAT'
9106       include 'COMMON.CORRMAT'
9107       include 'COMMON.TORSION'
9108       include 'COMMON.VAR'
9109       include 'COMMON.GEO'
9110       include 'COMMON.FFIELD'
9111       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9112      & auxvec1(2),auxmat1(2,2)
9113       logical swap
9114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9115 C                                                                              C
9116 C      Parallel       Antiparallel                                             C
9117 C                                                                              C
9118 C          o             o                                                     C
9119 C         /l\   /   \   /j\                                                    C
9120 C        /   \ /     \ /   \                                                   C
9121 C       /| o |o       o| o |\                                                  C
9122 C     \ j|/k\|      \  |/k\|l                                                  C
9123 C      \ /   \       \ /   \                                                   C
9124 C       o     \       o     \                                                  C
9125 C       i             i                                                        C
9126 C                                                                              C
9127 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9128 C
9129 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9130 C           energy moment and not to the cluster cumulant.
9131 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9132       iti=itype2loc(itype(i))
9133       itj=itype2loc(itype(j))
9134       if (j.lt.nres-1) then
9135         itj1=itype2loc(itype(j+1))
9136       else
9137         itj1=nloctyp
9138       endif
9139       itk=itype2loc(itype(k))
9140       if (k.lt.nres-1) then
9141         itk1=itype2loc(itype(k+1))
9142       else
9143         itk1=nloctyp
9144       endif
9145       itl=itype2loc(itype(l))
9146       if (l.lt.nres-1) then
9147         itl1=itype2loc(itype(l+1))
9148       else
9149         itl1=nloctyp
9150       endif
9151 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9152 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9153 cd     & ' itl',itl,' itl1',itl1
9154 #ifdef MOMENT
9155       if (imat.eq.1) then
9156         s1=dip(3,jj,i)*dip(3,kk,k)
9157       else
9158         s1=dip(2,jj,j)*dip(2,kk,l)
9159       endif
9160 #endif
9161       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9162       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9163       if (j.eq.l+1) then
9164         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9165         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9166       else
9167         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9168         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9169       endif
9170       call transpose2(EUg(1,1,k),auxmat(1,1))
9171       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9172       vv(1)=pizda(1,1)-pizda(2,2)
9173       vv(2)=pizda(2,1)+pizda(1,2)
9174       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9175 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9176 #ifdef MOMENT
9177       eello6_graph4=-(s1+s2+s3+s4)
9178 #else
9179       eello6_graph4=-(s2+s3+s4)
9180 #endif
9181 C Derivatives in gamma(i-1)
9182       if (calc_grad) then
9183       if (i.gt.1) then
9184 #ifdef MOMENT
9185         if (imat.eq.1) then
9186           s1=dipderg(2,jj,i)*dip(3,kk,k)
9187         else
9188           s1=dipderg(4,jj,j)*dip(2,kk,l)
9189         endif
9190 #endif
9191         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9192         if (j.eq.l+1) then
9193           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9194           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9195         else
9196           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9197           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9198         endif
9199         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9200         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9201 cd          write (2,*) 'turn6 derivatives'
9202 #ifdef MOMENT
9203           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9204 #else
9205           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9206 #endif
9207         else
9208 #ifdef MOMENT
9209           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9210 #else
9211           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9212 #endif
9213         endif
9214       endif
9215 C Derivatives in gamma(k-1)
9216 #ifdef MOMENT
9217       if (imat.eq.1) then
9218         s1=dip(3,jj,i)*dipderg(2,kk,k)
9219       else
9220         s1=dip(2,jj,j)*dipderg(4,kk,l)
9221       endif
9222 #endif
9223       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9224       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9225       if (j.eq.l+1) then
9226         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9227         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9228       else
9229         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9230         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9231       endif
9232       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9233       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9234       vv(1)=pizda(1,1)-pizda(2,2)
9235       vv(2)=pizda(2,1)+pizda(1,2)
9236       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9237       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9238 #ifdef MOMENT
9239         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9240 #else
9241         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9242 #endif
9243       else
9244 #ifdef MOMENT
9245         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9246 #else
9247         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9248 #endif
9249       endif
9250 C Derivatives in gamma(j-1) or gamma(l-1)
9251       if (l.eq.j+1 .and. l.gt.1) then
9252         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9253         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9254         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9255         vv(1)=pizda(1,1)-pizda(2,2)
9256         vv(2)=pizda(2,1)+pizda(1,2)
9257         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9258         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9259       else if (j.gt.1) then
9260         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9261         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9262         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9263         vv(1)=pizda(1,1)-pizda(2,2)
9264         vv(2)=pizda(2,1)+pizda(1,2)
9265         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9266         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9267           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9268         else
9269           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9270         endif
9271       endif
9272 C Cartesian derivatives.
9273       do iii=1,2
9274         do kkk=1,5
9275           do lll=1,3
9276 #ifdef MOMENT
9277             if (iii.eq.1) then
9278               if (imat.eq.1) then
9279                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9280               else
9281                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9282               endif
9283             else
9284               if (imat.eq.1) then
9285                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9286               else
9287                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9288               endif
9289             endif
9290 #endif
9291             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9292      &        auxvec(1))
9293             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9294             if (j.eq.l+1) then
9295               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9296      &          b1(1,j+1),auxvec(1))
9297               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9298             else
9299               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9300      &          b1(1,l+1),auxvec(1))
9301               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9302             endif
9303             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9304      &        pizda(1,1))
9305             vv(1)=pizda(1,1)-pizda(2,2)
9306             vv(2)=pizda(2,1)+pizda(1,2)
9307             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9308             if (swap) then
9309               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9310 #ifdef MOMENT
9311                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9312      &             -(s1+s2+s4)
9313 #else
9314                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9315      &             -(s2+s4)
9316 #endif
9317                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9318               else
9319 #ifdef MOMENT
9320                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9321 #else
9322                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9323 #endif
9324                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9325               endif
9326             else
9327 #ifdef MOMENT
9328               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9329 #else
9330               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9331 #endif
9332               if (l.eq.j+1) then
9333                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9334               else
9335                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9336               endif
9337             endif
9338           enddo
9339         enddo
9340       enddo
9341       endif ! calc_grad
9342       return
9343       end
9344 c----------------------------------------------------------------------------
9345       double precision function eello_turn6(i,jj,kk)
9346       implicit real*8 (a-h,o-z)
9347       include 'DIMENSIONS'
9348       include 'DIMENSIONS.ZSCOPT'
9349       include 'COMMON.IOUNITS'
9350       include 'COMMON.CHAIN'
9351       include 'COMMON.DERIV'
9352       include 'COMMON.INTERACT'
9353       include 'COMMON.CONTACTS'
9354       include 'COMMON.CONTMAT'
9355       include 'COMMON.CORRMAT'
9356       include 'COMMON.TORSION'
9357       include 'COMMON.VAR'
9358       include 'COMMON.GEO'
9359       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9360      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9361      &  ggg1(3),ggg2(3)
9362       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9363      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9364 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9365 C           the respective energy moment and not to the cluster cumulant.
9366       s1=0.0d0
9367       s8=0.0d0
9368       s13=0.0d0
9369 c
9370       eello_turn6=0.0d0
9371       j=i+4
9372       k=i+1
9373       l=i+3
9374       iti=itype2loc(itype(i))
9375       itk=itype2loc(itype(k))
9376       itk1=itype2loc(itype(k+1))
9377       itl=itype2loc(itype(l))
9378       itj=itype2loc(itype(j))
9379 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9380 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9381 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9382 cd        eello6=0.0d0
9383 cd        return
9384 cd      endif
9385 cd      write (iout,*)
9386 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9387 cd     &   ' and',k,l
9388 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9389       do iii=1,2
9390         do kkk=1,5
9391           do lll=1,3
9392             derx_turn(lll,kkk,iii)=0.0d0
9393           enddo
9394         enddo
9395       enddo
9396 cd      eij=1.0d0
9397 cd      ekl=1.0d0
9398 cd      ekont=1.0d0
9399       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9400 cd      eello6_5=0.0d0
9401 cd      write (2,*) 'eello6_5',eello6_5
9402 #ifdef MOMENT
9403       call transpose2(AEA(1,1,1),auxmat(1,1))
9404       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9405       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9406       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9407 #endif
9408       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9409       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9410       s2 = scalar2(b1(1,k),vtemp1(1))
9411 #ifdef MOMENT
9412       call transpose2(AEA(1,1,2),atemp(1,1))
9413       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9414       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9415       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9416 #endif
9417       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9418       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9419       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9420 #ifdef MOMENT
9421       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9422       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9423       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9424       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9425       ss13 = scalar2(b1(1,k),vtemp4(1))
9426       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9427 #endif
9428 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9429 c      s1=0.0d0
9430 c      s2=0.0d0
9431 c      s8=0.0d0
9432 c      s12=0.0d0
9433 c      s13=0.0d0
9434       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9435 C Derivatives in gamma(i+2)
9436       if (calc_grad) then
9437       s1d =0.0d0
9438       s8d =0.0d0
9439 #ifdef MOMENT
9440       call transpose2(AEA(1,1,1),auxmatd(1,1))
9441       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9442       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9443       call transpose2(AEAderg(1,1,2),atempd(1,1))
9444       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9445       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9446 #endif
9447       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9448       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9449       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9450 c      s1d=0.0d0
9451 c      s2d=0.0d0
9452 c      s8d=0.0d0
9453 c      s12d=0.0d0
9454 c      s13d=0.0d0
9455       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9456 C Derivatives in gamma(i+3)
9457 #ifdef MOMENT
9458       call transpose2(AEA(1,1,1),auxmatd(1,1))
9459       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9460       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9461       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9462 #endif
9463       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9464       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9465       s2d = scalar2(b1(1,k),vtemp1d(1))
9466 #ifdef MOMENT
9467       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9468       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9469 #endif
9470       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9471 #ifdef MOMENT
9472       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9473       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9474       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9475 #endif
9476 c      s1d=0.0d0
9477 c      s2d=0.0d0
9478 c      s8d=0.0d0
9479 c      s12d=0.0d0
9480 c      s13d=0.0d0
9481 #ifdef MOMENT
9482       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9483      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9484 #else
9485       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9486      &               -0.5d0*ekont*(s2d+s12d)
9487 #endif
9488 C Derivatives in gamma(i+4)
9489       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9490       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9491       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9492 #ifdef MOMENT
9493       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9494       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9495       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9496 #endif
9497 c      s1d=0.0d0
9498 c      s2d=0.0d0
9499 c      s8d=0.0d0
9500 C      s12d=0.0d0
9501 c      s13d=0.0d0
9502 #ifdef MOMENT
9503       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9504 #else
9505       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9506 #endif
9507 C Derivatives in gamma(i+5)
9508 #ifdef MOMENT
9509       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9510       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9511       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9512 #endif
9513       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9514       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9515       s2d = scalar2(b1(1,k),vtemp1d(1))
9516 #ifdef MOMENT
9517       call transpose2(AEA(1,1,2),atempd(1,1))
9518       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9519       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9520 #endif
9521       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9522       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9523 #ifdef MOMENT
9524       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9525       ss13d = scalar2(b1(1,k),vtemp4d(1))
9526       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9527 #endif
9528 c      s1d=0.0d0
9529 c      s2d=0.0d0
9530 c      s8d=0.0d0
9531 c      s12d=0.0d0
9532 c      s13d=0.0d0
9533 #ifdef MOMENT
9534       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9535      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9536 #else
9537       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9538      &               -0.5d0*ekont*(s2d+s12d)
9539 #endif
9540 C Cartesian derivatives
9541       do iii=1,2
9542         do kkk=1,5
9543           do lll=1,3
9544 #ifdef MOMENT
9545             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9546             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9547             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9548 #endif
9549             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9550             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9551      &          vtemp1d(1))
9552             s2d = scalar2(b1(1,k),vtemp1d(1))
9553 #ifdef MOMENT
9554             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9555             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9556             s8d = -(atempd(1,1)+atempd(2,2))*
9557      &           scalar2(cc(1,1,l),vtemp2(1))
9558 #endif
9559             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9560      &           auxmatd(1,1))
9561             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9562             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9563 c      s1d=0.0d0
9564 c      s2d=0.0d0
9565 c      s8d=0.0d0
9566 c      s12d=0.0d0
9567 c      s13d=0.0d0
9568 #ifdef MOMENT
9569             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9570      &        - 0.5d0*(s1d+s2d)
9571 #else
9572             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9573      &        - 0.5d0*s2d
9574 #endif
9575 #ifdef MOMENT
9576             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9577      &        - 0.5d0*(s8d+s12d)
9578 #else
9579             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9580      &        - 0.5d0*s12d
9581 #endif
9582           enddo
9583         enddo
9584       enddo
9585 #ifdef MOMENT
9586       do kkk=1,5
9587         do lll=1,3
9588           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9589      &      achuj_tempd(1,1))
9590           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9591           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9592           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9593           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9594           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9595      &      vtemp4d(1))
9596           ss13d = scalar2(b1(1,k),vtemp4d(1))
9597           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9598           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9599         enddo
9600       enddo
9601 #endif
9602 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9603 cd     &  16*eel_turn6_num
9604 cd      goto 1112
9605       if (j.lt.nres-1) then
9606         j1=j+1
9607         j2=j-1
9608       else
9609         j1=j-1
9610         j2=j-2
9611       endif
9612       if (l.lt.nres-1) then
9613         l1=l+1
9614         l2=l-1
9615       else
9616         l1=l-1
9617         l2=l-2
9618       endif
9619       do ll=1,3
9620 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9621 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9622 cgrad        ghalf=0.5d0*ggg1(ll)
9623 cd        ghalf=0.0d0
9624         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9625         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9626         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9627      &    +ekont*derx_turn(ll,2,1)
9628         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9629         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9630      &    +ekont*derx_turn(ll,4,1)
9631         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9632         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9633         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9634 cgrad        ghalf=0.5d0*ggg2(ll)
9635 cd        ghalf=0.0d0
9636         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9637      &    +ekont*derx_turn(ll,2,2)
9638         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9639         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9640      &    +ekont*derx_turn(ll,4,2)
9641         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9642         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9643         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9644       enddo
9645 cd      goto 1112
9646 cgrad      do m=i+1,j-1
9647 cgrad        do ll=1,3
9648 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9649 cgrad        enddo
9650 cgrad      enddo
9651 cgrad      do m=k+1,l-1
9652 cgrad        do ll=1,3
9653 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9654 cgrad        enddo
9655 cgrad      enddo
9656 cgrad1112  continue
9657 cgrad      do m=i+2,j2
9658 cgrad        do ll=1,3
9659 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9660 cgrad        enddo
9661 cgrad      enddo
9662 cgrad      do m=k+2,l2
9663 cgrad        do ll=1,3
9664 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9665 cgrad        enddo
9666 cgrad      enddo
9667 cd      do iii=1,nres-3
9668 cd        write (2,*) iii,g_corr6_loc(iii)
9669 cd      enddo
9670       endif ! calc_grad
9671       eello_turn6=ekont*eel_turn6
9672 cd      write (2,*) 'ekont',ekont
9673 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9674       return
9675       end
9676 #endif
9677 crc-------------------------------------------------
9678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9679       subroutine Eliptransfer(eliptran)
9680       implicit real*8 (a-h,o-z)
9681       include 'DIMENSIONS'
9682       include 'DIMENSIONS.ZSCOPT'
9683       include 'COMMON.GEO'
9684       include 'COMMON.VAR'
9685       include 'COMMON.LOCAL'
9686       include 'COMMON.CHAIN'
9687       include 'COMMON.DERIV'
9688       include 'COMMON.INTERACT'
9689       include 'COMMON.IOUNITS'
9690       include 'COMMON.CALC'
9691       include 'COMMON.CONTROL'
9692       include 'COMMON.SPLITELE'
9693       include 'COMMON.SBRIDGE'
9694 C this is done by Adasko
9695 C      print *,"wchodze"
9696 C structure of box:
9697 C      water
9698 C--bordliptop-- buffore starts
9699 C--bufliptop--- here true lipid starts
9700 C      lipid
9701 C--buflipbot--- lipid ends buffore starts
9702 C--bordlipbot--buffore ends
9703       eliptran=0.0
9704       do i=1,nres
9705 C       do i=1,1
9706         if (itype(i).eq.ntyp1) cycle
9707
9708         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9709         if (positi.le.0) positi=positi+boxzsize
9710 C        print *,i
9711 C first for peptide groups
9712 c for each residue check if it is in lipid or lipid water border area
9713        if ((positi.gt.bordlipbot)
9714      &.and.(positi.lt.bordliptop)) then
9715 C the energy transfer exist
9716         if (positi.lt.buflipbot) then
9717 C what fraction I am in
9718          fracinbuf=1.0d0-
9719      &        ((positi-bordlipbot)/lipbufthick)
9720 C lipbufthick is thickenes of lipid buffore
9721          sslip=sscalelip(fracinbuf)
9722          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9723          eliptran=eliptran+sslip*pepliptran
9724          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9725          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9726 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9727         elseif (positi.gt.bufliptop) then
9728          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9729          sslip=sscalelip(fracinbuf)
9730          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9731          eliptran=eliptran+sslip*pepliptran
9732          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9733          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9734 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9735 C          print *, "doing sscalefor top part"
9736 C         print *,i,sslip,fracinbuf,ssgradlip
9737         else
9738          eliptran=eliptran+pepliptran
9739 C         print *,"I am in true lipid"
9740         endif
9741 C       else
9742 C       eliptran=elpitran+0.0 ! I am in water
9743        endif
9744        enddo
9745 C       print *, "nic nie bylo w lipidzie?"
9746 C now multiply all by the peptide group transfer factor
9747 C       eliptran=eliptran*pepliptran
9748 C now the same for side chains
9749 CV       do i=1,1
9750        do i=1,nres
9751         if (itype(i).eq.ntyp1) cycle
9752         positi=(mod(c(3,i+nres),boxzsize))
9753         if (positi.le.0) positi=positi+boxzsize
9754 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9755 c for each residue check if it is in lipid or lipid water border area
9756 C       respos=mod(c(3,i+nres),boxzsize)
9757 C       print *,positi,bordlipbot,buflipbot
9758        if ((positi.gt.bordlipbot)
9759      & .and.(positi.lt.bordliptop)) then
9760 C the energy transfer exist
9761         if (positi.lt.buflipbot) then
9762          fracinbuf=1.0d0-
9763      &     ((positi-bordlipbot)/lipbufthick)
9764 C lipbufthick is thickenes of lipid buffore
9765          sslip=sscalelip(fracinbuf)
9766          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9767          eliptran=eliptran+sslip*liptranene(itype(i))
9768          gliptranx(3,i)=gliptranx(3,i)
9769      &+ssgradlip*liptranene(itype(i))
9770          gliptranc(3,i-1)= gliptranc(3,i-1)
9771      &+ssgradlip*liptranene(itype(i))
9772 C         print *,"doing sccale for lower part"
9773         elseif (positi.gt.bufliptop) then
9774          fracinbuf=1.0d0-
9775      &((bordliptop-positi)/lipbufthick)
9776          sslip=sscalelip(fracinbuf)
9777          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9778          eliptran=eliptran+sslip*liptranene(itype(i))
9779          gliptranx(3,i)=gliptranx(3,i)
9780      &+ssgradlip*liptranene(itype(i))
9781          gliptranc(3,i-1)= gliptranc(3,i-1)
9782      &+ssgradlip*liptranene(itype(i))
9783 C          print *, "doing sscalefor top part",sslip,fracinbuf
9784         else
9785          eliptran=eliptran+liptranene(itype(i))
9786 C         print *,"I am in true lipid"
9787         endif
9788         endif ! if in lipid or buffor
9789 C       else
9790 C       eliptran=elpitran+0.0 ! I am in water
9791        enddo
9792        return
9793        end
9794
9795
9796 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9797
9798       SUBROUTINE MATVEC2(A1,V1,V2)
9799       implicit real*8 (a-h,o-z)
9800       include 'DIMENSIONS'
9801       DIMENSION A1(2,2),V1(2),V2(2)
9802 c      DO 1 I=1,2
9803 c        VI=0.0
9804 c        DO 3 K=1,2
9805 c    3     VI=VI+A1(I,K)*V1(K)
9806 c        Vaux(I)=VI
9807 c    1 CONTINUE
9808
9809       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9810       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9811
9812       v2(1)=vaux1
9813       v2(2)=vaux2
9814       END
9815 C---------------------------------------
9816       SUBROUTINE MATMAT2(A1,A2,A3)
9817       implicit real*8 (a-h,o-z)
9818       include 'DIMENSIONS'
9819       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9820 c      DIMENSION AI3(2,2)
9821 c        DO  J=1,2
9822 c          A3IJ=0.0
9823 c          DO K=1,2
9824 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9825 c          enddo
9826 c          A3(I,J)=A3IJ
9827 c       enddo
9828 c      enddo
9829
9830       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9831       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9832       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9833       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9834
9835       A3(1,1)=AI3_11
9836       A3(2,1)=AI3_21
9837       A3(1,2)=AI3_12
9838       A3(2,2)=AI3_22
9839       END
9840
9841 c-------------------------------------------------------------------------
9842       double precision function scalar2(u,v)
9843       implicit none
9844       double precision u(2),v(2)
9845       double precision sc
9846       integer i
9847       scalar2=u(1)*v(1)+u(2)*v(2)
9848       return
9849       end
9850
9851 C-----------------------------------------------------------------------------
9852
9853       subroutine transpose2(a,at)
9854       implicit none
9855       double precision a(2,2),at(2,2)
9856       at(1,1)=a(1,1)
9857       at(1,2)=a(2,1)
9858       at(2,1)=a(1,2)
9859       at(2,2)=a(2,2)
9860       return
9861       end
9862 c--------------------------------------------------------------------------
9863       subroutine transpose(n,a,at)
9864       implicit none
9865       integer n,i,j
9866       double precision a(n,n),at(n,n)
9867       do i=1,n
9868         do j=1,n
9869           at(j,i)=a(i,j)
9870         enddo
9871       enddo
9872       return
9873       end
9874 C---------------------------------------------------------------------------
9875       subroutine prodmat3(a1,a2,kk,transp,prod)
9876       implicit none
9877       integer i,j
9878       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9879       logical transp
9880 crc      double precision auxmat(2,2),prod_(2,2)
9881
9882       if (transp) then
9883 crc        call transpose2(kk(1,1),auxmat(1,1))
9884 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9885 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9886
9887            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9888      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9889            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9890      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9891            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9892      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9893            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9894      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9895
9896       else
9897 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9898 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9899
9900            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9901      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9902            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9903      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9904            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9905      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9906            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9907      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9908
9909       endif
9910 c      call transpose2(a2(1,1),a2t(1,1))
9911
9912 crc      print *,transp
9913 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9914 crc      print *,((prod(i,j),i=1,2),j=1,2)
9915
9916       return
9917       end
9918 C-----------------------------------------------------------------------------
9919       double precision function scalar(u,v)
9920       implicit none
9921       double precision u(3),v(3)
9922       double precision sc
9923       integer i
9924       sc=0.0d0
9925       do i=1,3
9926         sc=sc+u(i)*v(i)
9927       enddo
9928       scalar=sc
9929       return
9930       end
9931 C-----------------------------------------------------------------------
9932       double precision function sscale(r)
9933       double precision r,gamm
9934       include "COMMON.SPLITELE"
9935       if(r.lt.r_cut-rlamb) then
9936         sscale=1.0d0
9937       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9938         gamm=(r-(r_cut-rlamb))/rlamb
9939         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9940       else
9941         sscale=0d0
9942       endif
9943       return
9944       end
9945 C-----------------------------------------------------------------------
9946 C-----------------------------------------------------------------------
9947       double precision function sscagrad(r)
9948       double precision r,gamm
9949       include "COMMON.SPLITELE"
9950       if(r.lt.r_cut-rlamb) then
9951         sscagrad=0.0d0
9952       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9953         gamm=(r-(r_cut-rlamb))/rlamb
9954         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9955       else
9956         sscagrad=0.0d0
9957       endif
9958       return
9959       end
9960 C-----------------------------------------------------------------------
9961 C-----------------------------------------------------------------------
9962       double precision function sscalelip(r)
9963       double precision r,gamm
9964       include "COMMON.SPLITELE"
9965 C      if(r.lt.r_cut-rlamb) then
9966 C        sscale=1.0d0
9967 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9968 C        gamm=(r-(r_cut-rlamb))/rlamb
9969         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9970 C      else
9971 C        sscale=0d0
9972 C      endif
9973       return
9974       end
9975 C-----------------------------------------------------------------------
9976       double precision function sscagradlip(r)
9977       double precision r,gamm
9978       include "COMMON.SPLITELE"
9979 C     if(r.lt.r_cut-rlamb) then
9980 C        sscagrad=0.0d0
9981 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9982 C        gamm=(r-(r_cut-rlamb))/rlamb
9983         sscagradlip=r*(6*r-6.0d0)
9984 C      else
9985 C        sscagrad=0.0d0
9986 C      endif
9987       return
9988       end
9989
9990 C-----------------------------------------------------------------------
9991        subroutine set_shield_fac
9992       implicit real*8 (a-h,o-z)
9993       include 'DIMENSIONS'
9994       include 'DIMENSIONS.ZSCOPT'
9995       include 'COMMON.CHAIN'
9996       include 'COMMON.DERIV'
9997       include 'COMMON.IOUNITS'
9998       include 'COMMON.SHIELD'
9999       include 'COMMON.INTERACT'
10000 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10001       double precision div77_81/0.974996043d0/,
10002      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10003
10004 C the vector between center of side_chain and peptide group
10005        double precision pep_side(3),long,side_calf(3),
10006      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10007      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10008 C the line belowe needs to be changed for FGPROC>1
10009       do i=1,nres-1
10010       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10011       ishield_list(i)=0
10012 Cif there two consequtive dummy atoms there is no peptide group between them
10013 C the line below has to be changed for FGPROC>1
10014       VolumeTotal=0.0
10015       do k=1,nres
10016        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10017        dist_pep_side=0.0
10018        dist_side_calf=0.0
10019        do j=1,3
10020 C first lets set vector conecting the ithe side-chain with kth side-chain
10021       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10022 C      pep_side(j)=2.0d0
10023 C and vector conecting the side-chain with its proper calfa
10024       side_calf(j)=c(j,k+nres)-c(j,k)
10025 C      side_calf(j)=2.0d0
10026       pept_group(j)=c(j,i)-c(j,i+1)
10027 C lets have their lenght
10028       dist_pep_side=pep_side(j)**2+dist_pep_side
10029       dist_side_calf=dist_side_calf+side_calf(j)**2
10030       dist_pept_group=dist_pept_group+pept_group(j)**2
10031       enddo
10032        dist_pep_side=dsqrt(dist_pep_side)
10033        dist_pept_group=dsqrt(dist_pept_group)
10034        dist_side_calf=dsqrt(dist_side_calf)
10035       do j=1,3
10036         pep_side_norm(j)=pep_side(j)/dist_pep_side
10037         side_calf_norm(j)=dist_side_calf
10038       enddo
10039 C now sscale fraction
10040        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10041 C       print *,buff_shield,"buff"
10042 C now sscale
10043         if (sh_frac_dist.le.0.0) cycle
10044 C If we reach here it means that this side chain reaches the shielding sphere
10045 C Lets add him to the list for gradient
10046         ishield_list(i)=ishield_list(i)+1
10047 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10048 C this list is essential otherwise problem would be O3
10049         shield_list(ishield_list(i),i)=k
10050 C Lets have the sscale value
10051         if (sh_frac_dist.gt.1.0) then
10052          scale_fac_dist=1.0d0
10053          do j=1,3
10054          sh_frac_dist_grad(j)=0.0d0
10055          enddo
10056         else
10057          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10058      &                   *(2.0*sh_frac_dist-3.0d0)
10059          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10060      &                  /dist_pep_side/buff_shield*0.5
10061 C remember for the final gradient multiply sh_frac_dist_grad(j)
10062 C for side_chain by factor -2 !
10063          do j=1,3
10064          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10065 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10066 C     &                    sh_frac_dist_grad(j)
10067          enddo
10068         endif
10069 C        if ((i.eq.3).and.(k.eq.2)) then
10070 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10071 C     & ,"TU"
10072 C        endif
10073
10074 C this is what is now we have the distance scaling now volume...
10075       short=short_r_sidechain(itype(k))
10076       long=long_r_sidechain(itype(k))
10077       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10078 C now costhet_grad
10079 C       costhet=0.0d0
10080        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10081 C       costhet_fac=0.0d0
10082        do j=1,3
10083          costhet_grad(j)=costhet_fac*pep_side(j)
10084        enddo
10085 C remember for the final gradient multiply costhet_grad(j)
10086 C for side_chain by factor -2 !
10087 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10088 C pep_side0pept_group is vector multiplication
10089       pep_side0pept_group=0.0
10090       do j=1,3
10091       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10092       enddo
10093       cosalfa=(pep_side0pept_group/
10094      & (dist_pep_side*dist_side_calf))
10095       fac_alfa_sin=1.0-cosalfa**2
10096       fac_alfa_sin=dsqrt(fac_alfa_sin)
10097       rkprim=fac_alfa_sin*(long-short)+short
10098 C now costhet_grad
10099        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10100        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10101
10102        do j=1,3
10103          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10104      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10105      &*(long-short)/fac_alfa_sin*cosalfa/
10106      &((dist_pep_side*dist_side_calf))*
10107      &((side_calf(j))-cosalfa*
10108      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10109
10110         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10111      &*(long-short)/fac_alfa_sin*cosalfa
10112      &/((dist_pep_side*dist_side_calf))*
10113      &(pep_side(j)-
10114      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10115        enddo
10116
10117       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10118      &                    /VSolvSphere_div
10119      &                    *wshield
10120 C now the gradient...
10121 C grad_shield is gradient of Calfa for peptide groups
10122 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10123 C     &               costhet,cosphi
10124 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10125 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10126       do j=1,3
10127       grad_shield(j,i)=grad_shield(j,i)
10128 C gradient po skalowaniu
10129      &                +(sh_frac_dist_grad(j)
10130 C  gradient po costhet
10131      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10132      &-scale_fac_dist*(cosphi_grad_long(j))
10133      &/(1.0-cosphi) )*div77_81
10134      &*VofOverlap
10135 C grad_shield_side is Cbeta sidechain gradient
10136       grad_shield_side(j,ishield_list(i),i)=
10137      &        (sh_frac_dist_grad(j)*(-2.0d0)
10138      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10139      &       +scale_fac_dist*(cosphi_grad_long(j))
10140      &        *2.0d0/(1.0-cosphi))
10141      &        *div77_81*VofOverlap
10142
10143        grad_shield_loc(j,ishield_list(i),i)=
10144      &   scale_fac_dist*cosphi_grad_loc(j)
10145      &        *2.0d0/(1.0-cosphi)
10146      &        *div77_81*VofOverlap
10147       enddo
10148       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10149       enddo
10150       fac_shield(i)=VolumeTotal*div77_81+div4_81
10151 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10152       enddo
10153       return
10154       end
10155 C--------------------------------------------------------------------------
10156 C first for shielding is setting of function of side-chains
10157        subroutine set_shield_fac2
10158       implicit real*8 (a-h,o-z)
10159       include 'DIMENSIONS'
10160       include 'DIMENSIONS.ZSCOPT'
10161       include 'COMMON.CHAIN'
10162       include 'COMMON.DERIV'
10163       include 'COMMON.IOUNITS'
10164       include 'COMMON.SHIELD'
10165       include 'COMMON.INTERACT'
10166 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10167       double precision div77_81/0.974996043d0/,
10168      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10169
10170 C the vector between center of side_chain and peptide group
10171        double precision pep_side(3),long,side_calf(3),
10172      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10173      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10174 C the line belowe needs to be changed for FGPROC>1
10175       do i=1,nres-1
10176       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10177       ishield_list(i)=0
10178 Cif there two consequtive dummy atoms there is no peptide group between them
10179 C the line below has to be changed for FGPROC>1
10180       VolumeTotal=0.0
10181       do k=1,nres
10182        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10183        dist_pep_side=0.0
10184        dist_side_calf=0.0
10185        do j=1,3
10186 C first lets set vector conecting the ithe side-chain with kth side-chain
10187       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10188 C      pep_side(j)=2.0d0
10189 C and vector conecting the side-chain with its proper calfa
10190       side_calf(j)=c(j,k+nres)-c(j,k)
10191 C      side_calf(j)=2.0d0
10192       pept_group(j)=c(j,i)-c(j,i+1)
10193 C lets have their lenght
10194       dist_pep_side=pep_side(j)**2+dist_pep_side
10195       dist_side_calf=dist_side_calf+side_calf(j)**2
10196       dist_pept_group=dist_pept_group+pept_group(j)**2
10197       enddo
10198        dist_pep_side=dsqrt(dist_pep_side)
10199        dist_pept_group=dsqrt(dist_pept_group)
10200        dist_side_calf=dsqrt(dist_side_calf)
10201       do j=1,3
10202         pep_side_norm(j)=pep_side(j)/dist_pep_side
10203         side_calf_norm(j)=dist_side_calf
10204       enddo
10205 C now sscale fraction
10206        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10207 C       print *,buff_shield,"buff"
10208 C now sscale
10209         if (sh_frac_dist.le.0.0) cycle
10210 C If we reach here it means that this side chain reaches the shielding sphere
10211 C Lets add him to the list for gradient
10212         ishield_list(i)=ishield_list(i)+1
10213 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10214 C this list is essential otherwise problem would be O3
10215         shield_list(ishield_list(i),i)=k
10216 C Lets have the sscale value
10217         if (sh_frac_dist.gt.1.0) then
10218          scale_fac_dist=1.0d0
10219          do j=1,3
10220          sh_frac_dist_grad(j)=0.0d0
10221          enddo
10222         else
10223          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10224      &                   *(2.0d0*sh_frac_dist-3.0d0)
10225          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10226      &                  /dist_pep_side/buff_shield*0.5d0
10227 C remember for the final gradient multiply sh_frac_dist_grad(j)
10228 C for side_chain by factor -2 !
10229          do j=1,3
10230          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10231 C         sh_frac_dist_grad(j)=0.0d0
10232 C         scale_fac_dist=1.0d0
10233 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10234 C     &                    sh_frac_dist_grad(j)
10235          enddo
10236         endif
10237 C this is what is now we have the distance scaling now volume...
10238       short=short_r_sidechain(itype(k))
10239       long=long_r_sidechain(itype(k))
10240       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10241       sinthet=short/dist_pep_side*costhet
10242 C now costhet_grad
10243 C       costhet=0.6d0
10244 C       sinthet=0.8
10245        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10246 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10247 C     &             -short/dist_pep_side**2/costhet)
10248 C       costhet_fac=0.0d0
10249        do j=1,3
10250          costhet_grad(j)=costhet_fac*pep_side(j)
10251        enddo
10252 C remember for the final gradient multiply costhet_grad(j)
10253 C for side_chain by factor -2 !
10254 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10255 C pep_side0pept_group is vector multiplication
10256       pep_side0pept_group=0.0d0
10257       do j=1,3
10258       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10259       enddo
10260       cosalfa=(pep_side0pept_group/
10261      & (dist_pep_side*dist_side_calf))
10262       fac_alfa_sin=1.0d0-cosalfa**2
10263       fac_alfa_sin=dsqrt(fac_alfa_sin)
10264       rkprim=fac_alfa_sin*(long-short)+short
10265 C      rkprim=short
10266
10267 C now costhet_grad
10268        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10269 C       cosphi=0.6
10270        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10271        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10272      &      dist_pep_side**2)
10273 C       sinphi=0.8
10274        do j=1,3
10275          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10276      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10277      &*(long-short)/fac_alfa_sin*cosalfa/
10278      &((dist_pep_side*dist_side_calf))*
10279      &((side_calf(j))-cosalfa*
10280      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10281 C       cosphi_grad_long(j)=0.0d0
10282         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10283      &*(long-short)/fac_alfa_sin*cosalfa
10284      &/((dist_pep_side*dist_side_calf))*
10285      &(pep_side(j)-
10286      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10287 C       cosphi_grad_loc(j)=0.0d0
10288        enddo
10289 C      print *,sinphi,sinthet
10290       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10291      &                    /VSolvSphere_div
10292 C     &                    *wshield
10293 C now the gradient...
10294       do j=1,3
10295       grad_shield(j,i)=grad_shield(j,i)
10296 C gradient po skalowaniu
10297      &                +(sh_frac_dist_grad(j)*VofOverlap
10298 C  gradient po costhet
10299      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10300      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10301      &       sinphi/sinthet*costhet*costhet_grad(j)
10302      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10303      & )*wshield
10304 C grad_shield_side is Cbeta sidechain gradient
10305       grad_shield_side(j,ishield_list(i),i)=
10306      &        (sh_frac_dist_grad(j)*(-2.0d0)
10307      &        *VofOverlap
10308      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10309      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10310      &       sinphi/sinthet*costhet*costhet_grad(j)
10311      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10312      &       )*wshield
10313
10314        grad_shield_loc(j,ishield_list(i),i)=
10315      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10316      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10317      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10318      &        ))
10319      &        *wshield
10320       enddo
10321       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10322       enddo
10323       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10324 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10325 c     &  " wshield",wshield
10326 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10327       enddo
10328       return
10329       end
10330 C--------------------------------------------------------------------------
10331       double precision function tschebyshev(m,n,x,y)
10332       implicit none
10333       include "DIMENSIONS"
10334       integer i,m,n
10335       double precision x(n),y,yy(0:maxvar),aux
10336 c Tschebyshev polynomial. Note that the first term is omitted
10337 c m=0: the constant term is included
10338 c m=1: the constant term is not included
10339       yy(0)=1.0d0
10340       yy(1)=y
10341       do i=2,n
10342         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10343       enddo
10344       aux=0.0d0
10345       do i=m,n
10346         aux=aux+x(i)*yy(i)
10347       enddo
10348       tschebyshev=aux
10349       return
10350       end
10351 C--------------------------------------------------------------------------
10352       double precision function gradtschebyshev(m,n,x,y)
10353       implicit none
10354       include "DIMENSIONS"
10355       integer i,m,n
10356       double precision x(n+1),y,yy(0:maxvar),aux
10357 c Tschebyshev polynomial. Note that the first term is omitted
10358 c m=0: the constant term is included
10359 c m=1: the constant term is not included
10360       yy(0)=1.0d0
10361       yy(1)=2.0d0*y
10362       do i=2,n
10363         yy(i)=2*y*yy(i-1)-yy(i-2)
10364       enddo
10365       aux=0.0d0
10366       do i=m,n
10367         aux=aux+x(i+1)*yy(i)*(i+1)
10368 C        print *, x(i+1),yy(i),i
10369       enddo
10370       gradtschebyshev=aux
10371       return
10372       end
10373 c----------------------------------------------------------------------------
10374       double precision function sscale2(r,r_cut,r0,rlamb)
10375       implicit none
10376       double precision r,gamm,r_cut,r0,rlamb,rr
10377       rr = dabs(r-r0)
10378 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10379 c      write (2,*) "rr",rr
10380       if(rr.lt.r_cut-rlamb) then
10381         sscale2=1.0d0
10382       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10383         gamm=(rr-(r_cut-rlamb))/rlamb
10384         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10385       else
10386         sscale2=0d0
10387       endif
10388       return
10389       end
10390 C-----------------------------------------------------------------------
10391       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10392       implicit none
10393       double precision r,gamm,r_cut,r0,rlamb,rr
10394       rr = dabs(r-r0)
10395       if(rr.lt.r_cut-rlamb) then
10396         sscalgrad2=0.0d0
10397       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10398         gamm=(rr-(r_cut-rlamb))/rlamb
10399         if (r.ge.r0) then
10400           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10401         else
10402           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10403         endif
10404       else
10405         sscalgrad2=0.0d0
10406       endif
10407       return
10408       end
10409 c----------------------------------------------------------------------------
10410       subroutine e_saxs(Esaxs_constr)
10411       implicit none
10412       include 'DIMENSIONS'
10413       include 'DIMENSIONS.ZSCOPT'
10414       include 'DIMENSIONS.FREE'
10415 #ifdef MPI
10416       include "mpif.h"
10417       include "COMMON.SETUP"
10418       integer IERR
10419 #endif
10420       include 'COMMON.SBRIDGE'
10421       include 'COMMON.CHAIN'
10422       include 'COMMON.GEO'
10423       include 'COMMON.LOCAL'
10424       include 'COMMON.INTERACT'
10425       include 'COMMON.VAR'
10426       include 'COMMON.IOUNITS'
10427       include 'COMMON.DERIV'
10428       include 'COMMON.CONTROL'
10429       include 'COMMON.NAMES'
10430       include 'COMMON.FFIELD'
10431       include 'COMMON.LANGEVIN'
10432       include 'COMMON.SAXS'
10433 c
10434       double precision Esaxs_constr
10435       integer i,iint,j,k,l
10436       double precision PgradC(maxSAXS,3,maxres),
10437      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10438 #ifdef MPI
10439       double precision PgradC_(maxSAXS,3,maxres),
10440      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10441 #endif
10442       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10443      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10444      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10445      & auxX,auxX1,CACAgrad,Cnorm
10446       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10447       double precision dist
10448       external dist
10449 c  SAXS restraint penalty function
10450 #ifdef DEBUG
10451       write(iout,*) "------- SAXS penalty function start -------"
10452       write (iout,*) "nsaxs",nsaxs
10453       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10454       write (iout,*) "Psaxs"
10455       do i=1,nsaxs
10456         write (iout,'(i5,e15.5)') i, Psaxs(i)
10457       enddo
10458 #endif
10459       Esaxs_constr = 0.0d0
10460       do k=1,nsaxs
10461         Pcalc(k)=0.0d0
10462         do j=1,nres
10463           do l=1,3
10464             PgradC(k,l,j)=0.0d0
10465             PgradX(k,l,j)=0.0d0
10466           enddo
10467         enddo
10468       enddo
10469       do i=iatsc_s,iatsc_e
10470        if (itype(i).eq.ntyp1) cycle
10471        do iint=1,nint_gr(i)
10472          do j=istart(i,iint),iend(i,iint)
10473            if (itype(j).eq.ntyp1) cycle
10474 #ifdef ALLSAXS
10475            dijCACA=dist(i,j)
10476            dijCASC=dist(i,j+nres)
10477            dijSCCA=dist(i+nres,j)
10478            dijSCSC=dist(i+nres,j+nres)
10479            sigma2CACA=2.0d0/(pstok**2)
10480            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10481            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10482            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10483            do k=1,nsaxs
10484              dk = distsaxs(k)
10485              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10486              if (itype(j).ne.10) then
10487              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10488              else
10489              endif
10490              expCASC = 0.0d0
10491              if (itype(i).ne.10) then
10492              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10493              else
10494              expSCCA = 0.0d0
10495              endif
10496              if (itype(i).ne.10 .and. itype(j).ne.10) then
10497              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10498              else
10499              expSCSC = 0.0d0
10500              endif
10501              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10502 #ifdef DEBUG
10503              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10504 #endif
10505              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10506              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10507              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10508              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10509              do l=1,3
10510 c CA CA
10511                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10512                PgradC(k,l,i) = PgradC(k,l,i)-aux
10513                PgradC(k,l,j) = PgradC(k,l,j)+aux
10514 c CA SC
10515                if (itype(j).ne.10) then
10516                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10517                PgradC(k,l,i) = PgradC(k,l,i)-aux
10518                PgradC(k,l,j) = PgradC(k,l,j)+aux
10519                PgradX(k,l,j) = PgradX(k,l,j)+aux
10520                endif
10521 c SC CA
10522                if (itype(i).ne.10) then
10523                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10524                PgradX(k,l,i) = PgradX(k,l,i)-aux
10525                PgradC(k,l,i) = PgradC(k,l,i)-aux
10526                PgradC(k,l,j) = PgradC(k,l,j)+aux
10527                endif
10528 c SC SC
10529                if (itype(i).ne.10 .and. itype(j).ne.10) then
10530                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10531                PgradC(k,l,i) = PgradC(k,l,i)-aux
10532                PgradC(k,l,j) = PgradC(k,l,j)+aux
10533                PgradX(k,l,i) = PgradX(k,l,i)-aux
10534                PgradX(k,l,j) = PgradX(k,l,j)+aux
10535                endif
10536              enddo ! l
10537            enddo ! k
10538 #else
10539            dijCACA=dist(i,j)
10540            sigma2CACA=scal_rad**2*0.25d0/
10541      &        (restok(itype(j))**2+restok(itype(i))**2)
10542
10543            IF (saxs_cutoff.eq.0) THEN
10544            do k=1,nsaxs
10545              dk = distsaxs(k)
10546              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10547              Pcalc(k) = Pcalc(k)+expCACA
10548              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10549              do l=1,3
10550                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10551                PgradC(k,l,i) = PgradC(k,l,i)-aux
10552                PgradC(k,l,j) = PgradC(k,l,j)+aux
10553              enddo ! l
10554            enddo ! k
10555            ELSE
10556            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10557            do k=1,nsaxs
10558              dk = distsaxs(k)
10559 c             write (2,*) "ijk",i,j,k
10560              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10561              if (sss2.eq.0.0d0) cycle
10562              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10563              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10564              Pcalc(k) = Pcalc(k)+expCACA
10565 #ifdef DEBUG
10566              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10567 #endif
10568              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10569      &             ssgrad2*expCACA/sss2
10570              do l=1,3
10571 c CA CA
10572                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10573                PgradC(k,l,i) = PgradC(k,l,i)+aux
10574                PgradC(k,l,j) = PgradC(k,l,j)-aux
10575              enddo ! l
10576            enddo ! k
10577            ENDIF
10578 #endif
10579          enddo ! j
10580        enddo ! iint
10581       enddo ! i
10582 #ifdef MPI
10583       if (nfgtasks.gt.1) then
10584         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10585      &    MPI_SUM,king,FG_COMM,IERR)
10586         if (fg_rank.eq.king) then
10587           do k=1,nsaxs
10588             Pcalc(k) = Pcalc_(k)
10589           enddo
10590         endif
10591         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10592      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10593         if (fg_rank.eq.king) then
10594           do i=1,nres
10595             do l=1,3
10596               do k=1,nsaxs
10597                 PgradC(k,l,i) = PgradC_(k,l,i)
10598               enddo
10599             enddo
10600           enddo
10601         endif
10602 #ifdef ALLSAXS
10603         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10604      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10605         if (fg_rank.eq.king) then
10606           do i=1,nres
10607             do l=1,3
10608               do k=1,nsaxs
10609                 PgradX(k,l,i) = PgradX_(k,l,i)
10610               enddo
10611             enddo
10612           enddo
10613         endif
10614 #endif
10615       endif
10616 #endif
10617 #ifdef MPI
10618       if (fg_rank.eq.king) then
10619 #endif
10620       Cnorm = 0.0d0
10621       do k=1,nsaxs
10622         Cnorm = Cnorm + Pcalc(k)
10623       enddo
10624       Esaxs_constr = dlog(Cnorm)-wsaxs0
10625       do k=1,nsaxs
10626         if (Pcalc(k).gt.0.0d0)
10627      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10628 #ifdef DEBUG
10629         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10630 #endif
10631       enddo
10632 #ifdef DEBUG
10633       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10634 #endif
10635       do i=nnt,nct
10636         do l=1,3
10637           auxC=0.0d0
10638           auxC1=0.0d0
10639           auxX=0.0d0
10640           auxX1=0.d0
10641           do k=1,nsaxs
10642             if (Pcalc(k).gt.0)
10643      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10644             auxC1 = auxC1+PgradC(k,l,i)
10645 #ifdef ALLSAXS
10646             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10647             auxX1 = auxX1+PgradX(k,l,i)
10648 #endif
10649           enddo
10650           gsaxsC(l,i) = auxC - auxC1/Cnorm
10651 #ifdef ALLSAXS
10652           gsaxsX(l,i) = auxX - auxX1/Cnorm
10653 #endif
10654 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10655 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10656         enddo
10657       enddo
10658 #ifdef MPI
10659       endif
10660 #endif
10661       return
10662       end
10663 c----------------------------------------------------------------------------
10664       subroutine e_saxsC(Esaxs_constr)
10665       implicit none
10666       include 'DIMENSIONS'
10667       include 'DIMENSIONS.ZSCOPT'
10668       include 'DIMENSIONS.FREE'
10669 #ifdef MPI
10670       include "mpif.h"
10671       include "COMMON.SETUP"
10672       integer IERR
10673 #endif
10674       include 'COMMON.SBRIDGE'
10675       include 'COMMON.CHAIN'
10676       include 'COMMON.GEO'
10677       include 'COMMON.LOCAL'
10678       include 'COMMON.INTERACT'
10679       include 'COMMON.VAR'
10680       include 'COMMON.IOUNITS'
10681       include 'COMMON.DERIV'
10682       include 'COMMON.CONTROL'
10683       include 'COMMON.NAMES'
10684       include 'COMMON.FFIELD'
10685       include 'COMMON.LANGEVIN'
10686       include 'COMMON.SAXS'
10687 c
10688       double precision Esaxs_constr
10689       integer i,iint,j,k,l
10690       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10691 #ifdef MPI
10692       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10693 #endif
10694       double precision dk,dijCASPH,dijSCSPH,
10695      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10696      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10697      & auxX,auxX1,Cnorm
10698 c  SAXS restraint penalty function
10699 #ifdef DEBUG
10700       write(iout,*) "------- SAXS penalty function start -------"
10701       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10702      & " isaxs_end",isaxs_end
10703       write (iout,*) "nnt",nnt," ntc",nct
10704       do i=nnt,nct
10705         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10706      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10707       enddo
10708       do i=nnt,nct
10709         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10710       enddo
10711 #endif
10712       Esaxs_constr = 0.0d0
10713       logPtot=0.0d0
10714       do j=isaxs_start,isaxs_end
10715         Pcalc=0.0d0
10716         do i=1,nres
10717           do l=1,3
10718             PgradC(l,i)=0.0d0
10719             PgradX(l,i)=0.0d0
10720           enddo
10721         enddo
10722         do i=nnt,nct
10723           dijCASPH=0.0d0
10724           dijSCSPH=0.0d0
10725           do l=1,3
10726             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10727           enddo
10728           if (itype(i).ne.10) then
10729           do l=1,3
10730             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10731           enddo
10732           endif
10733           sigma2CA=2.0d0/pstok**2
10734           sigma2SC=4.0d0/restok(itype(i))**2
10735           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10736           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10737           Pcalc = Pcalc+expCASPH+expSCSPH
10738 #ifdef DEBUG
10739           write(*,*) "processor i j Pcalc",
10740      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10741 #endif
10742           CASPHgrad = sigma2CA*expCASPH
10743           SCSPHgrad = sigma2SC*expSCSPH
10744           do l=1,3
10745             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10746             PgradX(l,i) = PgradX(l,i) + aux
10747             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10748           enddo ! l
10749         enddo ! i
10750         do i=nnt,nct
10751           do l=1,3
10752             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10753             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10754           enddo
10755         enddo
10756         logPtot = logPtot - dlog(Pcalc)
10757 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10758 c     &    " logPtot",logPtot
10759       enddo ! j
10760 #ifdef MPI
10761       if (nfgtasks.gt.1) then
10762 c        write (iout,*) "logPtot before reduction",logPtot
10763         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10764      &    MPI_SUM,king,FG_COMM,IERR)
10765         logPtot = logPtot_
10766 c        write (iout,*) "logPtot after reduction",logPtot
10767         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10768      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10769         if (fg_rank.eq.king) then
10770           do i=1,nres
10771             do l=1,3
10772               gsaxsC(l,i) = gsaxsC_(l,i)
10773             enddo
10774           enddo
10775         endif
10776         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10777      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10778         if (fg_rank.eq.king) then
10779           do i=1,nres
10780             do l=1,3
10781               gsaxsX(l,i) = gsaxsX_(l,i)
10782             enddo
10783           enddo
10784         endif
10785       endif
10786 #endif
10787       Esaxs_constr = logPtot
10788       return
10789       end
10790