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,'(a,2i5,3f10.5)')
1346      &                    'r sss evdw',i,j,1.0d0/rij,sss,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         ii=ireschain(i-2)
1798         if (ii.eq.0) cycle
1799         innt=chain_border(1,ii)
1800         inct=chain_border(2,ii)
1801 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1802         if (i.gt. innt+2 .and. i.lt.inct+2) then
1803           iti = itype2loc(itype(i-2))
1804         else
1805           iti=nloctyp
1806         endif
1807 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1808 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1809         if (i.gt. innt+1 .and. i.lt.inct+1) then
1810           iti1 = itype2loc(itype(i-1))
1811         else
1812           iti1=nloctyp
1813         endif
1814 #ifdef NEWCORR
1815         cost1=dcos(theta(i-1))
1816         sint1=dsin(theta(i-1))
1817         sint1sq=sint1*sint1
1818         sint1cub=sint1sq*sint1
1819         sint1cost1=2*sint1*cost1
1820 #ifdef DEBUG
1821         write (iout,*) "bnew1",i,iti
1822         write (iout,*) (bnew1(k,1,iti),k=1,3)
1823         write (iout,*) (bnew1(k,2,iti),k=1,3)
1824         write (iout,*) "bnew2",i,iti
1825         write (iout,*) (bnew2(k,1,iti),k=1,3)
1826         write (iout,*) (bnew2(k,2,iti),k=1,3)
1827 #endif
1828         do k=1,2
1829           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1830           b1(k,i-2)=sint1*b1k
1831           gtb1(k,i-2)=cost1*b1k-sint1sq*
1832      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1833           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1834           b2(k,i-2)=sint1*b2k
1835           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1836      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1837         enddo
1838         do k=1,2
1839           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1840           cc(1,k,i-2)=sint1sq*aux
1841           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1842      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1843           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1844           dd(1,k,i-2)=sint1sq*aux
1845           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1846      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1847         enddo
1848         cc(2,1,i-2)=cc(1,2,i-2)
1849         cc(2,2,i-2)=-cc(1,1,i-2)
1850         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1851         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1852         dd(2,1,i-2)=dd(1,2,i-2)
1853         dd(2,2,i-2)=-dd(1,1,i-2)
1854         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1855         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1856         do k=1,2
1857           do l=1,2
1858             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1859             EE(l,k,i-2)=sint1sq*aux
1860             if (calc_grad)
1861      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1862           enddo
1863         enddo
1864         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1865         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1866         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1867         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1868         if (calc_grad) then
1869         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1870         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1871         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1872         endif
1873 c        b1tilde(1,i-2)=b1(1,i-2)
1874 c        b1tilde(2,i-2)=-b1(2,i-2)
1875 c        b2tilde(1,i-2)=b2(1,i-2)
1876 c        b2tilde(2,i-2)=-b2(2,i-2)
1877 #ifdef DEBUG
1878         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1879         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1880         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1881         write (iout,*) 'theta=', theta(i-1)
1882 #endif
1883 #else
1884 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1885 c          iti = itype2loc(itype(i-2))
1886 c        else
1887 c          iti=nloctyp
1888 c        endif
1889 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1890 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1891 c          iti1 = itype2loc(itype(i-1))
1892 c        else
1893 c          iti1=nloctyp
1894 c        endif
1895         b1(1,i-2)=b(3,iti)
1896         b1(2,i-2)=b(5,iti)
1897         b2(1,i-2)=b(2,iti)
1898         b2(2,i-2)=b(4,iti)
1899         do k=1,2
1900           do l=1,2
1901            CC(k,l,i-2)=ccold(k,l,iti)
1902            DD(k,l,i-2)=ddold(k,l,iti)
1903            EE(k,l,i-2)=eeold(k,l,iti)
1904           enddo
1905         enddo
1906 #endif
1907         b1tilde(1,i-2)= b1(1,i-2)
1908         b1tilde(2,i-2)=-b1(2,i-2)
1909         b2tilde(1,i-2)= b2(1,i-2)
1910         b2tilde(2,i-2)=-b2(2,i-2)
1911 c
1912         Ctilde(1,1,i-2)= CC(1,1,i-2)
1913         Ctilde(1,2,i-2)= CC(1,2,i-2)
1914         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1915         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1916 c
1917         Dtilde(1,1,i-2)= DD(1,1,i-2)
1918         Dtilde(1,2,i-2)= DD(1,2,i-2)
1919         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1920         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1921 #ifdef DEBUG
1922         write(iout,*) "i",i," iti",iti
1923         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1924         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1925 #endif
1926       enddo
1927       do i=3,nres+1
1928         if (i .lt. nres+1) then
1929           sin1=dsin(phi(i))
1930           cos1=dcos(phi(i))
1931           sintab(i-2)=sin1
1932           costab(i-2)=cos1
1933           obrot(1,i-2)=cos1
1934           obrot(2,i-2)=sin1
1935           sin2=dsin(2*phi(i))
1936           cos2=dcos(2*phi(i))
1937           sintab2(i-2)=sin2
1938           costab2(i-2)=cos2
1939           obrot2(1,i-2)=cos2
1940           obrot2(2,i-2)=sin2
1941           Ug(1,1,i-2)=-cos1
1942           Ug(1,2,i-2)=-sin1
1943           Ug(2,1,i-2)=-sin1
1944           Ug(2,2,i-2)= cos1
1945           Ug2(1,1,i-2)=-cos2
1946           Ug2(1,2,i-2)=-sin2
1947           Ug2(2,1,i-2)=-sin2
1948           Ug2(2,2,i-2)= cos2
1949         else
1950           costab(i-2)=1.0d0
1951           sintab(i-2)=0.0d0
1952           obrot(1,i-2)=1.0d0
1953           obrot(2,i-2)=0.0d0
1954           obrot2(1,i-2)=0.0d0
1955           obrot2(2,i-2)=0.0d0
1956           Ug(1,1,i-2)=1.0d0
1957           Ug(1,2,i-2)=0.0d0
1958           Ug(2,1,i-2)=0.0d0
1959           Ug(2,2,i-2)=1.0d0
1960           Ug2(1,1,i-2)=0.0d0
1961           Ug2(1,2,i-2)=0.0d0
1962           Ug2(2,1,i-2)=0.0d0
1963           Ug2(2,2,i-2)=0.0d0
1964         endif
1965         if (i .gt. 3 .and. i .lt. nres+1) then
1966           obrot_der(1,i-2)=-sin1
1967           obrot_der(2,i-2)= cos1
1968           Ugder(1,1,i-2)= sin1
1969           Ugder(1,2,i-2)=-cos1
1970           Ugder(2,1,i-2)=-cos1
1971           Ugder(2,2,i-2)=-sin1
1972           dwacos2=cos2+cos2
1973           dwasin2=sin2+sin2
1974           obrot2_der(1,i-2)=-dwasin2
1975           obrot2_der(2,i-2)= dwacos2
1976           Ug2der(1,1,i-2)= dwasin2
1977           Ug2der(1,2,i-2)=-dwacos2
1978           Ug2der(2,1,i-2)=-dwacos2
1979           Ug2der(2,2,i-2)=-dwasin2
1980         else
1981           obrot_der(1,i-2)=0.0d0
1982           obrot_der(2,i-2)=0.0d0
1983           Ugder(1,1,i-2)=0.0d0
1984           Ugder(1,2,i-2)=0.0d0
1985           Ugder(2,1,i-2)=0.0d0
1986           Ugder(2,2,i-2)=0.0d0
1987           obrot2_der(1,i-2)=0.0d0
1988           obrot2_der(2,i-2)=0.0d0
1989           Ug2der(1,1,i-2)=0.0d0
1990           Ug2der(1,2,i-2)=0.0d0
1991           Ug2der(2,1,i-2)=0.0d0
1992           Ug2der(2,2,i-2)=0.0d0
1993         endif
1994 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1995         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1996           iti = itype2loc(itype(i-2))
1997         else
1998           iti=nloctyp
1999         endif
2000 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2001         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2002           iti1 = itype2loc(itype(i-1))
2003         else
2004           iti1=nloctyp
2005         endif
2006 cd        write (iout,*) '*******i',i,' iti1',iti
2007 cd        write (iout,*) 'b1',b1(:,iti)
2008 cd        write (iout,*) 'b2',b2(:,iti)
2009 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2010 c        if (i .gt. iatel_s+2) then
2011         if (i .gt. nnt+2) then
2012           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2013 #ifdef NEWCORR
2014           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2015 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2016 #endif
2017 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2018 c     &    EE(1,2,iti),EE(2,2,i)
2019           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2020           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2021 c          write(iout,*) "Macierz EUG",
2022 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2023 c     &    eug(2,2,i-2)
2024 #ifdef FOURBODY
2025           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2026      &    then
2027           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2028           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2029           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2030           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2031           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2032           endif
2033 #endif
2034         else
2035           do k=1,2
2036             Ub2(k,i-2)=0.0d0
2037             Ctobr(k,i-2)=0.0d0
2038             Dtobr2(k,i-2)=0.0d0
2039             do l=1,2
2040               EUg(l,k,i-2)=0.0d0
2041               CUg(l,k,i-2)=0.0d0
2042               DUg(l,k,i-2)=0.0d0
2043               DtUg2(l,k,i-2)=0.0d0
2044             enddo
2045           enddo
2046         endif
2047         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2048         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2049         do k=1,2
2050           muder(k,i-2)=Ub2der(k,i-2)
2051         enddo
2052 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2053         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2054           if (itype(i-1).le.ntyp) then
2055             iti1 = itype2loc(itype(i-1))
2056           else
2057             iti1=nloctyp
2058           endif
2059         else
2060           iti1=nloctyp
2061         endif
2062         do k=1,2
2063           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2064         enddo
2065 #ifdef MUOUT
2066         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2067      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2068      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2069      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2070      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2071      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2072 #endif
2073 cd        write (iout,*) 'mu1',mu1(:,i-2)
2074 cd        write (iout,*) 'mu2',mu2(:,i-2)
2075 #ifdef FOURBODY
2076         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2077      &  then
2078         if (calc_grad) then
2079         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2080         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2081         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2082         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2083         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2084         endif
2085 C Vectors and matrices dependent on a single virtual-bond dihedral.
2086         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2087         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2088         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2089         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2090         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2091         if (calc_grad) then
2092         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2093         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2094         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2095         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2096         endif
2097         endif
2098 #endif
2099       enddo
2100 #ifdef FOURBODY
2101 C Matrices dependent on two consecutive virtual-bond dihedrals.
2102 C The order of matrices is from left to right.
2103       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2104      &then
2105       do i=2,nres-1
2106         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2107         if (calc_grad) then
2108         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2109         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2110         endif
2111         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2112         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2113         if (calc_grad) then
2114         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2115         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2116         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2117         endif
2118       enddo
2119       endif
2120 #endif
2121       return
2122       end
2123 C--------------------------------------------------------------------------
2124       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2125 C
2126 C This subroutine calculates the average interaction energy and its gradient
2127 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2128 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2129 C The potential depends both on the distance of peptide-group centers and on
2130 C the orientation of the CA-CA virtual bonds.
2131 C
2132       implicit real*8 (a-h,o-z)
2133 #ifdef MPI
2134       include 'mpif.h'
2135 #endif
2136       include 'DIMENSIONS'
2137       include 'DIMENSIONS.ZSCOPT'
2138       include 'COMMON.CONTROL'
2139       include 'COMMON.IOUNITS'
2140       include 'COMMON.GEO'
2141       include 'COMMON.VAR'
2142       include 'COMMON.LOCAL'
2143       include 'COMMON.CHAIN'
2144       include 'COMMON.DERIV'
2145       include 'COMMON.INTERACT'
2146 #ifdef FOURBODY
2147       include 'COMMON.CONTACTS'
2148       include 'COMMON.CONTMAT'
2149 #endif
2150       include 'COMMON.CORRMAT'
2151       include 'COMMON.TORSION'
2152       include 'COMMON.VECTORS'
2153       include 'COMMON.FFIELD'
2154       include 'COMMON.TIME1'
2155       include 'COMMON.SPLITELE'
2156       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2157      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2158       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2159      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2160       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2161      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2162      &    num_conti,j1,j2
2163 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2164 #ifdef MOMENT
2165       double precision scal_el /1.0d0/
2166 #else
2167       double precision scal_el /0.5d0/
2168 #endif
2169 C 12/13/98
2170 C 13-go grudnia roku pamietnego...
2171       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2172      &                   0.0d0,1.0d0,0.0d0,
2173      &                   0.0d0,0.0d0,1.0d0/
2174 cd      write(iout,*) 'In EELEC'
2175 cd      do i=1,nloctyp
2176 cd        write(iout,*) 'Type',i
2177 cd        write(iout,*) 'B1',B1(:,i)
2178 cd        write(iout,*) 'B2',B2(:,i)
2179 cd        write(iout,*) 'CC',CC(:,:,i)
2180 cd        write(iout,*) 'DD',DD(:,:,i)
2181 cd        write(iout,*) 'EE',EE(:,:,i)
2182 cd      enddo
2183 cd      call check_vecgrad
2184 cd      stop
2185       if (icheckgrad.eq.1) then
2186         do i=1,nres-1
2187           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2188           do k=1,3
2189             dc_norm(k,i)=dc(k,i)*fac
2190           enddo
2191 c          write (iout,*) 'i',i,' fac',fac
2192         enddo
2193       endif
2194       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2195      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2196      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2197 c        call vec_and_deriv
2198 #ifdef TIMING
2199         time01=MPI_Wtime()
2200 #endif
2201         call set_matrices
2202 #ifdef TIMING
2203         time_mat=time_mat+MPI_Wtime()-time01
2204 #endif
2205       endif
2206 cd      do i=1,nres-1
2207 cd        write (iout,*) 'i=',i
2208 cd        do k=1,3
2209 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2210 cd        enddo
2211 cd        do k=1,3
2212 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2213 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2214 cd        enddo
2215 cd      enddo
2216       t_eelecij=0.0d0
2217       ees=0.0D0
2218       evdw1=0.0D0
2219       eel_loc=0.0d0
2220       eello_turn3=0.0d0
2221       eello_turn4=0.0d0
2222       ind=0
2223 #ifdef FOURBODY
2224       do i=1,nres
2225         num_cont_hb(i)=0
2226       enddo
2227 #endif
2228 cd      print '(a)','Enter EELEC'
2229 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2230       do i=1,nres
2231         gel_loc_loc(i)=0.0d0
2232         gcorr_loc(i)=0.0d0
2233       enddo
2234 c
2235 c
2236 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2237 C
2238 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2239 C
2240 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2241       do i=iturn3_start,iturn3_end
2242 c        if (i.le.1) cycle
2243 C        write(iout,*) "tu jest i",i
2244         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2245 C changes suggested by Ana to avoid out of bounds
2246 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2247 c     & .or.((i+4).gt.nres)
2248 c     & .or.((i-1).le.0)
2249 C end of changes by Ana
2250 C dobra zmiana wycofana
2251      &  .or. itype(i+2).eq.ntyp1
2252      &  .or. itype(i+3).eq.ntyp1) cycle
2253 C Adam: Instructions below will switch off existing interactions
2254 c        if(i.gt.1)then
2255 c          if(itype(i-1).eq.ntyp1)cycle
2256 c        end if
2257 c        if(i.LT.nres-3)then
2258 c          if (itype(i+4).eq.ntyp1) cycle
2259 c        end if
2260         dxi=dc(1,i)
2261         dyi=dc(2,i)
2262         dzi=dc(3,i)
2263         dx_normi=dc_norm(1,i)
2264         dy_normi=dc_norm(2,i)
2265         dz_normi=dc_norm(3,i)
2266         xmedi=c(1,i)+0.5d0*dxi
2267         ymedi=c(2,i)+0.5d0*dyi
2268         zmedi=c(3,i)+0.5d0*dzi
2269           xmedi=mod(xmedi,boxxsize)
2270           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2271           ymedi=mod(ymedi,boxysize)
2272           if (ymedi.lt.0) ymedi=ymedi+boxysize
2273           zmedi=mod(zmedi,boxzsize)
2274           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2275         num_conti=0
2276         call eelecij(i,i+2,ees,evdw1,eel_loc)
2277         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2278 #ifdef FOURBODY
2279         num_cont_hb(i)=num_conti
2280 #endif
2281       enddo
2282       do i=iturn4_start,iturn4_end
2283         if (i.lt.1) cycle
2284         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2285 C changes suggested by Ana to avoid out of bounds
2286 c     & .or.((i+5).gt.nres)
2287 c     & .or.((i-1).le.0)
2288 C end of changes suggested by Ana
2289      &    .or. itype(i+3).eq.ntyp1
2290      &    .or. itype(i+4).eq.ntyp1
2291 c     &    .or. itype(i+5).eq.ntyp1
2292 c     &    .or. itype(i).eq.ntyp1
2293 c     &    .or. itype(i-1).eq.ntyp1
2294      &                             ) cycle
2295         dxi=dc(1,i)
2296         dyi=dc(2,i)
2297         dzi=dc(3,i)
2298         dx_normi=dc_norm(1,i)
2299         dy_normi=dc_norm(2,i)
2300         dz_normi=dc_norm(3,i)
2301         xmedi=c(1,i)+0.5d0*dxi
2302         ymedi=c(2,i)+0.5d0*dyi
2303         zmedi=c(3,i)+0.5d0*dzi
2304 C Return atom into box, boxxsize is size of box in x dimension
2305 c  194   continue
2306 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2307 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2308 C Condition for being inside the proper box
2309 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2310 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2311 c        go to 194
2312 c        endif
2313 c  195   continue
2314 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2315 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2316 C Condition for being inside the proper box
2317 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2318 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2319 c        go to 195
2320 c        endif
2321 c  196   continue
2322 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2323 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2324 C Condition for being inside the proper box
2325 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2326 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2327 c        go to 196
2328 c        endif
2329           xmedi=mod(xmedi,boxxsize)
2330           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2331           ymedi=mod(ymedi,boxysize)
2332           if (ymedi.lt.0) ymedi=ymedi+boxysize
2333           zmedi=mod(zmedi,boxzsize)
2334           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2335 #ifdef FOURBODY
2336         num_conti=num_cont_hb(i)
2337 #endif
2338 c        write(iout,*) "JESTEM W PETLI"
2339         call eelecij(i,i+3,ees,evdw1,eel_loc)
2340         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2341      &   call eturn4(i,eello_turn4)
2342 #ifdef FOURBODY
2343         num_cont_hb(i)=num_conti
2344 #endif
2345       enddo   ! i
2346 C Loop over all neighbouring boxes
2347 C      do xshift=-1,1
2348 C      do yshift=-1,1
2349 C      do zshift=-1,1
2350 c
2351 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2352 c
2353 CTU KURWA
2354       do i=iatel_s,iatel_e
2355 C        do i=75,75
2356 c        if (i.le.1) cycle
2357         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2358 C changes suggested by Ana to avoid out of bounds
2359 c     & .or.((i+2).gt.nres)
2360 c     & .or.((i-1).le.0)
2361 C end of changes by Ana
2362 c     &  .or. itype(i+2).eq.ntyp1
2363 c     &  .or. itype(i-1).eq.ntyp1
2364      &                ) cycle
2365         dxi=dc(1,i)
2366         dyi=dc(2,i)
2367         dzi=dc(3,i)
2368         dx_normi=dc_norm(1,i)
2369         dy_normi=dc_norm(2,i)
2370         dz_normi=dc_norm(3,i)
2371         xmedi=c(1,i)+0.5d0*dxi
2372         ymedi=c(2,i)+0.5d0*dyi
2373         zmedi=c(3,i)+0.5d0*dzi
2374           xmedi=mod(xmedi,boxxsize)
2375           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2376           ymedi=mod(ymedi,boxysize)
2377           if (ymedi.lt.0) ymedi=ymedi+boxysize
2378           zmedi=mod(zmedi,boxzsize)
2379           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2380 C          xmedi=xmedi+xshift*boxxsize
2381 C          ymedi=ymedi+yshift*boxysize
2382 C          zmedi=zmedi+zshift*boxzsize
2383
2384 C Return tom into box, boxxsize is size of box in x dimension
2385 c  164   continue
2386 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2387 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2388 C Condition for being inside the proper box
2389 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2390 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2391 c        go to 164
2392 c        endif
2393 c  165   continue
2394 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2395 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2396 C Condition for being inside the proper box
2397 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2398 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2399 c        go to 165
2400 c        endif
2401 c  166   continue
2402 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2403 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2404 cC Condition for being inside the proper box
2405 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2406 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2407 c        go to 166
2408 c        endif
2409
2410 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2411 #ifdef FOURBODY
2412         num_conti=num_cont_hb(i)
2413 #endif
2414 C I TU KURWA
2415         do j=ielstart(i),ielend(i)
2416 C          do j=16,17
2417 C          write (iout,*) i,j
2418 C         if (j.le.1) cycle
2419           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2420 C changes suggested by Ana to avoid out of bounds
2421 c     & .or.((j+2).gt.nres)
2422 c     & .or.((j-1).le.0)
2423 C end of changes by Ana
2424 c     & .or.itype(j+2).eq.ntyp1
2425 c     & .or.itype(j-1).eq.ntyp1
2426      &) cycle
2427           call eelecij(i,j,ees,evdw1,eel_loc)
2428         enddo ! j
2429 #ifdef FOURBODY
2430         num_cont_hb(i)=num_conti
2431 #endif
2432       enddo   ! i
2433 C     enddo   ! zshift
2434 C      enddo   ! yshift
2435 C      enddo   ! xshift
2436
2437 c      write (iout,*) "Number of loop steps in EELEC:",ind
2438 cd      do i=1,nres
2439 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2440 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2441 cd      enddo
2442 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2443 ccc      eel_loc=eel_loc+eello_turn3
2444 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2445       return
2446       end
2447 C-------------------------------------------------------------------------------
2448       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2449       implicit real*8 (a-h,o-z)
2450       include 'DIMENSIONS'
2451       include 'DIMENSIONS.ZSCOPT'
2452 #ifdef MPI
2453       include "mpif.h"
2454 #endif
2455       include 'COMMON.CONTROL'
2456       include 'COMMON.IOUNITS'
2457       include 'COMMON.GEO'
2458       include 'COMMON.VAR'
2459       include 'COMMON.LOCAL'
2460       include 'COMMON.CHAIN'
2461       include 'COMMON.DERIV'
2462       include 'COMMON.INTERACT'
2463 #ifdef FOURBODY
2464       include 'COMMON.CONTACTS'
2465       include 'COMMON.CONTMAT'
2466 #endif
2467       include 'COMMON.CORRMAT'
2468       include 'COMMON.TORSION'
2469       include 'COMMON.VECTORS'
2470       include 'COMMON.FFIELD'
2471       include 'COMMON.TIME1'
2472       include 'COMMON.SPLITELE'
2473       include 'COMMON.SHIELD'
2474       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2475      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2476       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2477      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2478      &    gmuij2(4),gmuji2(4)
2479       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2480      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2481      &    num_conti,j1,j2
2482 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2483 #ifdef MOMENT
2484       double precision scal_el /1.0d0/
2485 #else
2486       double precision scal_el /0.5d0/
2487 #endif
2488 C 12/13/98
2489 C 13-go grudnia roku pamietnego...
2490       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2491      &                   0.0d0,1.0d0,0.0d0,
2492      &                   0.0d0,0.0d0,1.0d0/
2493        integer xshift,yshift,zshift
2494 c          time00=MPI_Wtime()
2495 cd      write (iout,*) "eelecij",i,j
2496 c          ind=ind+1
2497           iteli=itel(i)
2498           itelj=itel(j)
2499           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2500           aaa=app(iteli,itelj)
2501           bbb=bpp(iteli,itelj)
2502           ael6i=ael6(iteli,itelj)
2503           ael3i=ael3(iteli,itelj)
2504           dxj=dc(1,j)
2505           dyj=dc(2,j)
2506           dzj=dc(3,j)
2507           dx_normj=dc_norm(1,j)
2508           dy_normj=dc_norm(2,j)
2509           dz_normj=dc_norm(3,j)
2510 C          xj=c(1,j)+0.5D0*dxj-xmedi
2511 C          yj=c(2,j)+0.5D0*dyj-ymedi
2512 C          zj=c(3,j)+0.5D0*dzj-zmedi
2513           xj=c(1,j)+0.5D0*dxj
2514           yj=c(2,j)+0.5D0*dyj
2515           zj=c(3,j)+0.5D0*dzj
2516           xj=mod(xj,boxxsize)
2517           if (xj.lt.0) xj=xj+boxxsize
2518           yj=mod(yj,boxysize)
2519           if (yj.lt.0) yj=yj+boxysize
2520           zj=mod(zj,boxzsize)
2521           if (zj.lt.0) zj=zj+boxzsize
2522           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2523       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2524       xj_safe=xj
2525       yj_safe=yj
2526       zj_safe=zj
2527       isubchap=0
2528       do xshift=-1,1
2529       do yshift=-1,1
2530       do zshift=-1,1
2531           xj=xj_safe+xshift*boxxsize
2532           yj=yj_safe+yshift*boxysize
2533           zj=zj_safe+zshift*boxzsize
2534           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2535           if(dist_temp.lt.dist_init) then
2536             dist_init=dist_temp
2537             xj_temp=xj
2538             yj_temp=yj
2539             zj_temp=zj
2540             isubchap=1
2541           endif
2542        enddo
2543        enddo
2544        enddo
2545        if (isubchap.eq.1) then
2546           xj=xj_temp-xmedi
2547           yj=yj_temp-ymedi
2548           zj=zj_temp-zmedi
2549        else
2550           xj=xj_safe-xmedi
2551           yj=yj_safe-ymedi
2552           zj=zj_safe-zmedi
2553        endif
2554 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2555 c  174   continue
2556 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2557 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2558 C Condition for being inside the proper box
2559 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2560 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2561 c        go to 174
2562 c        endif
2563 c  175   continue
2564 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2565 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2566 C Condition for being inside the proper box
2567 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2568 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2569 c        go to 175
2570 c        endif
2571 c  176   continue
2572 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2573 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2574 C Condition for being inside the proper box
2575 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2576 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2577 c        go to 176
2578 c        endif
2579 C        endif !endPBC condintion
2580 C        xj=xj-xmedi
2581 C        yj=yj-ymedi
2582 C        zj=zj-zmedi
2583           rij=xj*xj+yj*yj+zj*zj
2584
2585           sss=sscale(sqrt(rij))
2586           if (sss.eq.0.0d0) return
2587           sssgrad=sscagrad(sqrt(rij))
2588 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2589 c     &       " rlamb",rlamb," sss",sss
2590 c            if (sss.gt.0.0d0) then
2591           rrmij=1.0D0/rij
2592           rij=dsqrt(rij)
2593           rmij=1.0D0/rij
2594           r3ij=rrmij*rmij
2595           r6ij=r3ij*r3ij
2596           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2597           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2598           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2599           fac=cosa-3.0D0*cosb*cosg
2600           ev1=aaa*r6ij*r6ij
2601 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2602           if (j.eq.i+2) ev1=scal_el*ev1
2603           ev2=bbb*r6ij
2604           fac3=ael6i*r6ij
2605           fac4=ael3i*r3ij
2606           evdwij=(ev1+ev2)
2607           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2608           el2=fac4*fac
2609 C MARYSIA
2610 C          eesij=(el1+el2)
2611 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2612           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2613           if (shield_mode.gt.0) then
2614 C          fac_shield(i)=0.4
2615 C          fac_shield(j)=0.6
2616           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2617           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2618           eesij=(el1+el2)
2619           ees=ees+eesij
2620           else
2621           fac_shield(i)=1.0
2622           fac_shield(j)=1.0
2623           eesij=(el1+el2)
2624           ees=ees+eesij
2625           endif
2626           evdw1=evdw1+evdwij*sss
2627 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2628 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2629 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2630 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2631
2632           if (energy_dec) then
2633               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2634      &'evdw1',i,j,evdwij
2635      &,iteli,itelj,aaa,evdw1,sss
2636               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2637      &fac_shield(i),fac_shield(j)
2638           endif
2639
2640 C
2641 C Calculate contributions to the Cartesian gradient.
2642 C
2643 #ifdef SPLITELE
2644           facvdw=-6*rrmij*(ev1+evdwij)*sss
2645           facel=-3*rrmij*(el1+eesij)
2646           fac1=fac
2647           erij(1)=xj*rmij
2648           erij(2)=yj*rmij
2649           erij(3)=zj*rmij
2650
2651 *
2652 * Radial derivatives. First process both termini of the fragment (i,j)
2653 *
2654           if (calc_grad) then
2655           ggg(1)=facel*xj
2656           ggg(2)=facel*yj
2657           ggg(3)=facel*zj
2658           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2659      &  (shield_mode.gt.0)) then
2660 C          print *,i,j
2661           do ilist=1,ishield_list(i)
2662            iresshield=shield_list(ilist,i)
2663            do k=1,3
2664            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2665      &      *2.0
2666            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2667      &              rlocshield
2668      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2669             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2670 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2671 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2672 C             if (iresshield.gt.i) then
2673 C               do ishi=i+1,iresshield-1
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             else
2679 C               do ishi=iresshield,i
2680 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2681 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2682 C
2683 C               enddo
2684 C              endif
2685            enddo
2686           enddo
2687           do ilist=1,ishield_list(j)
2688            iresshield=shield_list(ilist,j)
2689            do k=1,3
2690            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2691      &     *2.0
2692            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2693      &              rlocshield
2694      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2695            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2696
2697 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2698 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2699 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2700 C             if (iresshield.gt.j) then
2701 C               do ishi=j+1,iresshield-1
2702 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2703 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2704 C
2705 C               enddo
2706 C            else
2707 C               do ishi=iresshield,j
2708 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2709 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2710 C               enddo
2711 C              endif
2712            enddo
2713           enddo
2714
2715           do k=1,3
2716             gshieldc(k,i)=gshieldc(k,i)+
2717      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2718             gshieldc(k,j)=gshieldc(k,j)+
2719      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2720             gshieldc(k,i-1)=gshieldc(k,i-1)+
2721      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2722             gshieldc(k,j-1)=gshieldc(k,j-1)+
2723      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2724
2725            enddo
2726            endif
2727 c          do k=1,3
2728 c            ghalf=0.5D0*ggg(k)
2729 c            gelc(k,i)=gelc(k,i)+ghalf
2730 c            gelc(k,j)=gelc(k,j)+ghalf
2731 c          enddo
2732 c 9/28/08 AL Gradient compotents will be summed only at the end
2733 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2734           do k=1,3
2735             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2736 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2737             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2738 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2739 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2740 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2741 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2742 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2743           enddo
2744 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2745
2746 *
2747 * Loop over residues i+1 thru j-1.
2748 *
2749 cgrad          do k=i+1,j-1
2750 cgrad            do l=1,3
2751 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2752 cgrad            enddo
2753 cgrad          enddo
2754           if (sss.gt.0.0) then
2755           facvdw=facvdw+sssgrad*rmij*evdwij
2756           ggg(1)=facvdw*xj
2757           ggg(2)=facvdw*yj
2758           ggg(3)=facvdw*zj
2759           else
2760           ggg(1)=0.0
2761           ggg(2)=0.0
2762           ggg(3)=0.0
2763           endif
2764 c          do k=1,3
2765 c            ghalf=0.5D0*ggg(k)
2766 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2767 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2768 c          enddo
2769 c 9/28/08 AL Gradient compotents will be summed only at the end
2770           do k=1,3
2771             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2772             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2773           enddo
2774 *
2775 * Loop over residues i+1 thru j-1.
2776 *
2777 cgrad          do k=i+1,j-1
2778 cgrad            do l=1,3
2779 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2780 cgrad            enddo
2781 cgrad          enddo
2782           endif ! calc_grad
2783 #else
2784 C MARYSIA
2785           facvdw=(ev1+evdwij)
2786           facel=(el1+eesij)
2787           fac1=fac
2788           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2789      &       +(evdwij+eesij)*sssgrad*rrmij
2790           erij(1)=xj*rmij
2791           erij(2)=yj*rmij
2792           erij(3)=zj*rmij
2793 *
2794 * Radial derivatives. First process both termini of the fragment (i,j)
2795 *
2796           if (calc_grad) then
2797           ggg(1)=fac*xj
2798 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2799           ggg(2)=fac*yj
2800 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2801           ggg(3)=fac*zj
2802 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2803 c          do k=1,3
2804 c            ghalf=0.5D0*ggg(k)
2805 c            gelc(k,i)=gelc(k,i)+ghalf
2806 c            gelc(k,j)=gelc(k,j)+ghalf
2807 c          enddo
2808 c 9/28/08 AL Gradient compotents will be summed only at the end
2809           do k=1,3
2810             gelc_long(k,j)=gelc(k,j)+ggg(k)
2811             gelc_long(k,i)=gelc(k,i)-ggg(k)
2812           enddo
2813 *
2814 * Loop over residues i+1 thru j-1.
2815 *
2816 cgrad          do k=i+1,j-1
2817 cgrad            do l=1,3
2818 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2819 cgrad            enddo
2820 cgrad          enddo
2821 c 9/28/08 AL Gradient compotents will be summed only at the end
2822           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2823           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2824           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2825           do k=1,3
2826             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2827             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2828           enddo
2829           endif ! calc_grad
2830 #endif
2831 *
2832 * Angular part
2833 *
2834           if (calc_grad) then
2835           ecosa=2.0D0*fac3*fac1+fac4
2836           fac4=-3.0D0*fac4
2837           fac3=-6.0D0*fac3
2838           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2839           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2840           do k=1,3
2841             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2842             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2843           enddo
2844 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2845 cd   &          (dcosg(k),k=1,3)
2846           do k=1,3
2847             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2848      &      fac_shield(i)**2*fac_shield(j)**2
2849           enddo
2850 c          do k=1,3
2851 c            ghalf=0.5D0*ggg(k)
2852 c            gelc(k,i)=gelc(k,i)+ghalf
2853 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2854 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2855 c            gelc(k,j)=gelc(k,j)+ghalf
2856 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2857 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2858 c          enddo
2859 cgrad          do k=i+1,j-1
2860 cgrad            do l=1,3
2861 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2862 cgrad            enddo
2863 cgrad          enddo
2864 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2865           do k=1,3
2866             gelc(k,i)=gelc(k,i)
2867      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2868      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2869      &           *fac_shield(i)**2*fac_shield(j)**2
2870             gelc(k,j)=gelc(k,j)
2871      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2872      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2873      &           *fac_shield(i)**2*fac_shield(j)**2
2874             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2875             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2876           enddo
2877 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2878
2879 C MARYSIA
2880 c          endif !sscale
2881           endif ! calc_grad
2882           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2883      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2884      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2885 C
2886 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2887 C   energy of a peptide unit is assumed in the form of a second-order
2888 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2889 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2890 C   are computed for EVERY pair of non-contiguous peptide groups.
2891 C
2892
2893           if (j.lt.nres-1) then
2894             j1=j+1
2895             j2=j-1
2896           else
2897             j1=j-1
2898             j2=j-2
2899           endif
2900           kkk=0
2901           lll=0
2902           do k=1,2
2903             do l=1,2
2904               kkk=kkk+1
2905               muij(kkk)=mu(k,i)*mu(l,j)
2906 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2907 #ifdef NEWCORR
2908              if (calc_grad) then
2909              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2910 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2911              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2912              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2913 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2914              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2915              endif
2916 #endif
2917             enddo
2918           enddo
2919 #ifdef DEBUG
2920           write (iout,*) 'EELEC: i',i,' j',j
2921           write (iout,*) 'j',j,' j1',j1,' j2',j2
2922           write(iout,*) 'muij',muij
2923           write (iout,*) "uy",uy(:,i)
2924           write (iout,*) "uz",uz(:,j)
2925           write (iout,*) "erij",erij
2926 #endif
2927           ury=scalar(uy(1,i),erij)
2928           urz=scalar(uz(1,i),erij)
2929           vry=scalar(uy(1,j),erij)
2930           vrz=scalar(uz(1,j),erij)
2931           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2932           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2933           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2934           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2935           fac=dsqrt(-ael6i)*r3ij
2936           a22=a22*fac
2937           a23=a23*fac
2938           a32=a32*fac
2939           a33=a33*fac
2940 cd          write (iout,'(4i5,4f10.5)')
2941 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2942 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2943 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2944 cd     &      uy(:,j),uz(:,j)
2945 cd          write (iout,'(4f10.5)')
2946 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2947 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2948 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2949 cd           write (iout,'(9f10.5/)')
2950 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2951 C Derivatives of the elements of A in virtual-bond vectors
2952           if (calc_grad) then
2953           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2954           do k=1,3
2955             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2956             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2957             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2958             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2959             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2960             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2961             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2962             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2963             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2964             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2965             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2966             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2967           enddo
2968 C Compute radial contributions to the gradient
2969           facr=-3.0d0*rrmij
2970           a22der=a22*facr
2971           a23der=a23*facr
2972           a32der=a32*facr
2973           a33der=a33*facr
2974           agg(1,1)=a22der*xj
2975           agg(2,1)=a22der*yj
2976           agg(3,1)=a22der*zj
2977           agg(1,2)=a23der*xj
2978           agg(2,2)=a23der*yj
2979           agg(3,2)=a23der*zj
2980           agg(1,3)=a32der*xj
2981           agg(2,3)=a32der*yj
2982           agg(3,3)=a32der*zj
2983           agg(1,4)=a33der*xj
2984           agg(2,4)=a33der*yj
2985           agg(3,4)=a33der*zj
2986 C Add the contributions coming from er
2987           fac3=-3.0d0*fac
2988           do k=1,3
2989             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2990             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2991             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2992             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2993           enddo
2994           do k=1,3
2995 C Derivatives in DC(i)
2996 cgrad            ghalf1=0.5d0*agg(k,1)
2997 cgrad            ghalf2=0.5d0*agg(k,2)
2998 cgrad            ghalf3=0.5d0*agg(k,3)
2999 cgrad            ghalf4=0.5d0*agg(k,4)
3000             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3001      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3002             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3003      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3004             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3005      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3006             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3007      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3008 C Derivatives in DC(i+1)
3009             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3010      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3011             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3012      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3013             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3014      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3015             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3016      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3017 C Derivatives in DC(j)
3018             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3019      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3020             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3021      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3022             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3023      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3024             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3025      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3026 C Derivatives in DC(j+1) or DC(nres-1)
3027             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3028      &      -3.0d0*vryg(k,3)*ury)
3029             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3030      &      -3.0d0*vrzg(k,3)*ury)
3031             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3032      &      -3.0d0*vryg(k,3)*urz)
3033             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3034      &      -3.0d0*vrzg(k,3)*urz)
3035 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3036 cgrad              do l=1,4
3037 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3038 cgrad              enddo
3039 cgrad            endif
3040           enddo
3041           endif ! calc_grad
3042           acipa(1,1)=a22
3043           acipa(1,2)=a23
3044           acipa(2,1)=a32
3045           acipa(2,2)=a33
3046           a22=-a22
3047           a23=-a23
3048           if (calc_grad) then
3049           do l=1,2
3050             do k=1,3
3051               agg(k,l)=-agg(k,l)
3052               aggi(k,l)=-aggi(k,l)
3053               aggi1(k,l)=-aggi1(k,l)
3054               aggj(k,l)=-aggj(k,l)
3055               aggj1(k,l)=-aggj1(k,l)
3056             enddo
3057           enddo
3058           endif ! calc_grad
3059           if (j.lt.nres-1) then
3060             a22=-a22
3061             a32=-a32
3062             do l=1,3,2
3063               do k=1,3
3064                 agg(k,l)=-agg(k,l)
3065                 aggi(k,l)=-aggi(k,l)
3066                 aggi1(k,l)=-aggi1(k,l)
3067                 aggj(k,l)=-aggj(k,l)
3068                 aggj1(k,l)=-aggj1(k,l)
3069               enddo
3070             enddo
3071           else
3072             a22=-a22
3073             a23=-a23
3074             a32=-a32
3075             a33=-a33
3076             do l=1,4
3077               do k=1,3
3078                 agg(k,l)=-agg(k,l)
3079                 aggi(k,l)=-aggi(k,l)
3080                 aggi1(k,l)=-aggi1(k,l)
3081                 aggj(k,l)=-aggj(k,l)
3082                 aggj1(k,l)=-aggj1(k,l)
3083               enddo
3084             enddo
3085           endif
3086           ENDIF ! WCORR
3087           IF (wel_loc.gt.0.0d0) THEN
3088 C Contribution to the local-electrostatic energy coming from the i-j pair
3089           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3090      &     +a33*muij(4)
3091 #ifdef DEBUG
3092           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3093      &     " a33",a33
3094           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3095      &     " wel_loc",wel_loc
3096 #endif
3097           if (shield_mode.eq.0) then
3098            fac_shield(i)=1.0
3099            fac_shield(j)=1.0
3100 C          else
3101 C           fac_shield(i)=0.4
3102 C           fac_shield(j)=0.6
3103           endif
3104           eel_loc_ij=eel_loc_ij
3105      &    *fac_shield(i)*fac_shield(j)*sss
3106           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3107      &            'eelloc',i,j,eel_loc_ij
3108 c           if (eel_loc_ij.ne.0)
3109 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3110 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3111
3112           eel_loc=eel_loc+eel_loc_ij
3113 C Now derivative over eel_loc
3114           if (calc_grad) then
3115           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3116      &  (shield_mode.gt.0)) then
3117 C          print *,i,j
3118
3119           do ilist=1,ishield_list(i)
3120            iresshield=shield_list(ilist,i)
3121            do k=1,3
3122            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3123      &                                          /fac_shield(i)
3124 C     &      *2.0
3125            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3126      &              rlocshield
3127      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3128             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3129      &      +rlocshield
3130            enddo
3131           enddo
3132           do ilist=1,ishield_list(j)
3133            iresshield=shield_list(ilist,j)
3134            do k=1,3
3135            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3136      &                                       /fac_shield(j)
3137 C     &     *2.0
3138            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3139      &              rlocshield
3140      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3141            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3142      &             +rlocshield
3143
3144            enddo
3145           enddo
3146
3147           do k=1,3
3148             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3149      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3150             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3151      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3152             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3153      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3154             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3155      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3156            enddo
3157            endif
3158
3159
3160 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3161 c     &                     ' eel_loc_ij',eel_loc_ij
3162 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3163 C Calculate patrial derivative for theta angle
3164 #ifdef NEWCORR
3165          geel_loc_ij=(a22*gmuij1(1)
3166      &     +a23*gmuij1(2)
3167      &     +a32*gmuij1(3)
3168      &     +a33*gmuij1(4))
3169      &    *fac_shield(i)*fac_shield(j)*sss
3170 c         write(iout,*) "derivative over thatai"
3171 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3172 c     &   a33*gmuij1(4)
3173          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3174      &      geel_loc_ij*wel_loc
3175 c         write(iout,*) "derivative over thatai-1"
3176 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3177 c     &   a33*gmuij2(4)
3178          geel_loc_ij=
3179      &     a22*gmuij2(1)
3180      &     +a23*gmuij2(2)
3181      &     +a32*gmuij2(3)
3182      &     +a33*gmuij2(4)
3183          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3184      &      geel_loc_ij*wel_loc
3185      &    *fac_shield(i)*fac_shield(j)*sss
3186
3187 c  Derivative over j residue
3188          geel_loc_ji=a22*gmuji1(1)
3189      &     +a23*gmuji1(2)
3190      &     +a32*gmuji1(3)
3191      &     +a33*gmuji1(4)
3192 c         write(iout,*) "derivative over thataj"
3193 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3194 c     &   a33*gmuji1(4)
3195
3196         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3197      &      geel_loc_ji*wel_loc
3198      &    *fac_shield(i)*fac_shield(j)
3199
3200          geel_loc_ji=
3201      &     +a22*gmuji2(1)
3202      &     +a23*gmuji2(2)
3203      &     +a32*gmuji2(3)
3204      &     +a33*gmuji2(4)
3205 c         write(iout,*) "derivative over thataj-1"
3206 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3207 c     &   a33*gmuji2(4)
3208          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3209      &      geel_loc_ji*wel_loc
3210      &    *fac_shield(i)*fac_shield(j)*sss
3211 #endif
3212 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3213
3214 C Partial derivatives in virtual-bond dihedral angles gamma
3215           if (i.gt.1)
3216      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3217      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3218      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3219      &    *fac_shield(i)*fac_shield(j)
3220
3221           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3222      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3223      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3224      &    *fac_shield(i)*fac_shield(j)
3225 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3226           aux=eel_loc_ij/sss*sssgrad*rmij
3227           ggg(1)=aux*xj
3228           ggg(2)=aux*yj
3229           ggg(3)=aux*zj
3230           do l=1,3
3231             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3232      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3233      &    *fac_shield(i)*fac_shield(j)*sss
3234             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3235             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3236 cgrad            ghalf=0.5d0*ggg(l)
3237 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3238 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3239           enddo
3240 cgrad          do k=i+1,j2
3241 cgrad            do l=1,3
3242 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3243 cgrad            enddo
3244 cgrad          enddo
3245 C Remaining derivatives of eello
3246           do l=1,3
3247             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3248      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3249      &    *fac_shield(i)*fac_shield(j)
3250
3251             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3252      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3253      &    *fac_shield(i)*fac_shield(j)
3254
3255             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3256      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3257      &    *fac_shield(i)*fac_shield(j)
3258
3259             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3260      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3261      &    *fac_shield(i)*fac_shield(j)
3262
3263           enddo
3264           endif ! calc_grad
3265           ENDIF
3266
3267
3268 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3269 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3270 #ifdef FOURBODY
3271           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3272      &       .and. num_conti.le.maxconts) then
3273 c            write (iout,*) i,j," entered corr"
3274 C
3275 C Calculate the contact function. The ith column of the array JCONT will
3276 C contain the numbers of atoms that make contacts with the atom I (of numbers
3277 C greater than I). The arrays FACONT and GACONT will contain the values of
3278 C the contact function and its derivative.
3279 c           r0ij=1.02D0*rpp(iteli,itelj)
3280 c           r0ij=1.11D0*rpp(iteli,itelj)
3281             r0ij=2.20D0*rpp(iteli,itelj)
3282 c           r0ij=1.55D0*rpp(iteli,itelj)
3283             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3284             if (fcont.gt.0.0D0) then
3285               num_conti=num_conti+1
3286               if (num_conti.gt.maxconts) then
3287                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3288      &                         ' will skip next contacts for this conf.'
3289               else
3290                 jcont_hb(num_conti,i)=j
3291 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3292 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3293                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3294      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3295 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3296 C  terms.
3297                 d_cont(num_conti,i)=rij
3298 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3299 C     --- Electrostatic-interaction matrix ---
3300                 a_chuj(1,1,num_conti,i)=a22
3301                 a_chuj(1,2,num_conti,i)=a23
3302                 a_chuj(2,1,num_conti,i)=a32
3303                 a_chuj(2,2,num_conti,i)=a33
3304 C     --- Gradient of rij
3305                 if (calc_grad) then
3306                 do kkk=1,3
3307                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3308                 enddo
3309                 kkll=0
3310                 do k=1,2
3311                   do l=1,2
3312                     kkll=kkll+1
3313                     do m=1,3
3314                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3315                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3316                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3317                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3318                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3319                     enddo
3320                   enddo
3321                 enddo
3322                 endif ! calc_grad
3323                 ENDIF
3324                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3325 C Calculate contact energies
3326                 cosa4=4.0D0*cosa
3327                 wij=cosa-3.0D0*cosb*cosg
3328                 cosbg1=cosb+cosg
3329                 cosbg2=cosb-cosg
3330 c               fac3=dsqrt(-ael6i)/r0ij**3
3331                 fac3=dsqrt(-ael6i)*r3ij
3332 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3333                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3334                 if (ees0tmp.gt.0) then
3335                   ees0pij=dsqrt(ees0tmp)
3336                 else
3337                   ees0pij=0
3338                 endif
3339 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3340                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3341                 if (ees0tmp.gt.0) then
3342                   ees0mij=dsqrt(ees0tmp)
3343                 else
3344                   ees0mij=0
3345                 endif
3346 c               ees0mij=0.0D0
3347                 if (shield_mode.eq.0) then
3348                 fac_shield(i)=1.0d0
3349                 fac_shield(j)=1.0d0
3350                 else
3351                 ees0plist(num_conti,i)=j
3352 C                fac_shield(i)=0.4d0
3353 C                fac_shield(j)=0.6d0
3354                 endif
3355                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3356      &          *fac_shield(i)*fac_shield(j)
3357                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3358      &          *fac_shield(i)*fac_shield(j)
3359 C Diagnostics. Comment out or remove after debugging!
3360 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3361 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3362 c               ees0m(num_conti,i)=0.0D0
3363 C End diagnostics.
3364 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3365 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3366 C Angular derivatives of the contact function
3367
3368                 ees0pij1=fac3/ees0pij
3369                 ees0mij1=fac3/ees0mij
3370                 fac3p=-3.0D0*fac3*rrmij
3371                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3372                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3373 c               ees0mij1=0.0D0
3374                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3375                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3376                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3377                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3378                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3379                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3380                 ecosap=ecosa1+ecosa2
3381                 ecosbp=ecosb1+ecosb2
3382                 ecosgp=ecosg1+ecosg2
3383                 ecosam=ecosa1-ecosa2
3384                 ecosbm=ecosb1-ecosb2
3385                 ecosgm=ecosg1-ecosg2
3386 C Diagnostics
3387 c               ecosap=ecosa1
3388 c               ecosbp=ecosb1
3389 c               ecosgp=ecosg1
3390 c               ecosam=0.0D0
3391 c               ecosbm=0.0D0
3392 c               ecosgm=0.0D0
3393 C End diagnostics
3394                 facont_hb(num_conti,i)=fcont
3395
3396                 if (calc_grad) then
3397                 fprimcont=fprimcont/rij
3398 cd              facont_hb(num_conti,i)=1.0D0
3399 C Following line is for diagnostics.
3400 cd              fprimcont=0.0D0
3401                 do k=1,3
3402                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3403                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3404                 enddo
3405                 do k=1,3
3406                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3407                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3408                 enddo
3409                 gggp(1)=gggp(1)+ees0pijp*xj
3410      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3411                 gggp(2)=gggp(2)+ees0pijp*yj
3412      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3413                 gggp(3)=gggp(3)+ees0pijp*zj
3414      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3415                 gggm(1)=gggm(1)+ees0mijp*xj
3416      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3417                 gggm(2)=gggm(2)+ees0mijp*yj
3418      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3419                 gggm(3)=gggm(3)+ees0mijp*zj
3420      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3421 C Derivatives due to the contact function
3422                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3423                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3424                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3425                 do k=1,3
3426 c
3427 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3428 c          following the change of gradient-summation algorithm.
3429 c
3430 cgrad                  ghalfp=0.5D0*gggp(k)
3431 cgrad                  ghalfm=0.5D0*gggm(k)
3432                   gacontp_hb1(k,num_conti,i)=!ghalfp
3433      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3434      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3435      &          *fac_shield(i)*fac_shield(j)*sss
3436
3437                   gacontp_hb2(k,num_conti,i)=!ghalfp
3438      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3439      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3440      &          *fac_shield(i)*fac_shield(j)*sss
3441
3442                   gacontp_hb3(k,num_conti,i)=gggp(k)
3443      &          *fac_shield(i)*fac_shield(j)*sss
3444
3445                   gacontm_hb1(k,num_conti,i)=!ghalfm
3446      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3447      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3448      &          *fac_shield(i)*fac_shield(j)*sss
3449
3450                   gacontm_hb2(k,num_conti,i)=!ghalfm
3451      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3452      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3453      &          *fac_shield(i)*fac_shield(j)*sss
3454
3455                   gacontm_hb3(k,num_conti,i)=gggm(k)
3456      &          *fac_shield(i)*fac_shield(j)*sss
3457
3458                 enddo
3459 C Diagnostics. Comment out or remove after debugging!
3460 cdiag           do k=1,3
3461 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3462 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3463 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3464 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3465 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3466 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3467 cdiag           enddo
3468
3469                  endif ! calc_grad
3470
3471               ENDIF ! wcorr
3472               endif  ! num_conti.le.maxconts
3473             endif  ! fcont.gt.0
3474           endif    ! j.gt.i+1
3475 #endif
3476           if (calc_grad) then
3477           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3478             do k=1,4
3479               do l=1,3
3480                 ghalf=0.5d0*agg(l,k)
3481                 aggi(l,k)=aggi(l,k)+ghalf
3482                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3483                 aggj(l,k)=aggj(l,k)+ghalf
3484               enddo
3485             enddo
3486             if (j.eq.nres-1 .and. i.lt.j-2) then
3487               do k=1,4
3488                 do l=1,3
3489                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3490                 enddo
3491               enddo
3492             endif
3493           endif
3494           endif ! calc_grad
3495 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3496       return
3497       end
3498 C-----------------------------------------------------------------------------
3499       subroutine eturn3(i,eello_turn3)
3500 C Third- and fourth-order contributions from turns
3501       implicit real*8 (a-h,o-z)
3502       include 'DIMENSIONS'
3503       include 'DIMENSIONS.ZSCOPT'
3504       include 'COMMON.IOUNITS'
3505       include 'COMMON.GEO'
3506       include 'COMMON.VAR'
3507       include 'COMMON.LOCAL'
3508       include 'COMMON.CHAIN'
3509       include 'COMMON.DERIV'
3510       include 'COMMON.INTERACT'
3511       include 'COMMON.CONTACTS'
3512       include 'COMMON.TORSION'
3513       include 'COMMON.VECTORS'
3514       include 'COMMON.FFIELD'
3515       include 'COMMON.CONTROL'
3516       include 'COMMON.SHIELD'
3517       include 'COMMON.CORRMAT'
3518       dimension ggg(3)
3519       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3520      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3521      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3522      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3523      &  auxgmat2(2,2),auxgmatt2(2,2)
3524       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3525      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3526       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3527      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3528      &    num_conti,j1,j2
3529       j=i+2
3530 c      write (iout,*) "eturn3",i,j,j1,j2
3531       a_temp(1,1)=a22
3532       a_temp(1,2)=a23
3533       a_temp(2,1)=a32
3534       a_temp(2,2)=a33
3535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3536 C
3537 C               Third-order contributions
3538 C
3539 C                 (i+2)o----(i+3)
3540 C                      | |
3541 C                      | |
3542 C                 (i+1)o----i
3543 C
3544 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3545 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3546         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3547 c auxalary matices for theta gradient
3548 c auxalary matrix for i+1 and constant i+2
3549         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3550 c auxalary matrix for i+2 and constant i+1
3551         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3552         call transpose2(auxmat(1,1),auxmat1(1,1))
3553         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3554         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3555         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3556         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3557         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3558         if (shield_mode.eq.0) then
3559         fac_shield(i)=1.0
3560         fac_shield(j)=1.0
3561 C        else
3562 C        fac_shield(i)=0.4
3563 C        fac_shield(j)=0.6
3564         endif
3565         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3566      &  *fac_shield(i)*fac_shield(j)
3567         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3568      &  *fac_shield(i)*fac_shield(j)
3569         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3570      &    eello_t3
3571         if (calc_grad) then
3572 C#ifdef NEWCORR
3573 C Derivatives in theta
3574         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3575      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3576      &   *fac_shield(i)*fac_shield(j)
3577         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3578      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3579      &   *fac_shield(i)*fac_shield(j)
3580 C#endif
3581
3582 C Derivatives in shield mode
3583           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3584      &  (shield_mode.gt.0)) then
3585 C          print *,i,j
3586
3587           do ilist=1,ishield_list(i)
3588            iresshield=shield_list(ilist,i)
3589            do k=1,3
3590            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3591 C     &      *2.0
3592            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3593      &              rlocshield
3594      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3595             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3596      &      +rlocshield
3597            enddo
3598           enddo
3599           do ilist=1,ishield_list(j)
3600            iresshield=shield_list(ilist,j)
3601            do k=1,3
3602            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3603 C     &     *2.0
3604            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3605      &              rlocshield
3606      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3607            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3608      &             +rlocshield
3609
3610            enddo
3611           enddo
3612
3613           do k=1,3
3614             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3615      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3616             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3617      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3618             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3619      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3620             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3621      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3622            enddo
3623            endif
3624
3625 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3626 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3627 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3628 cd     &    ' eello_turn3_num',4*eello_turn3_num
3629 C Derivatives in gamma(i)
3630         call matmat2(EUgder(1,1,i+1),EUg(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)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3634      &   *fac_shield(i)*fac_shield(j)
3635 C Derivatives in gamma(i+1)
3636         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3637         call transpose2(auxmat2(1,1),auxmat3(1,1))
3638         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3639         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3640      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3641      &   *fac_shield(i)*fac_shield(j)
3642 C Cartesian derivatives
3643         do l=1,3
3644 c            ghalf1=0.5d0*agg(l,1)
3645 c            ghalf2=0.5d0*agg(l,2)
3646 c            ghalf3=0.5d0*agg(l,3)
3647 c            ghalf4=0.5d0*agg(l,4)
3648           a_temp(1,1)=aggi(l,1)!+ghalf1
3649           a_temp(1,2)=aggi(l,2)!+ghalf2
3650           a_temp(2,1)=aggi(l,3)!+ghalf3
3651           a_temp(2,2)=aggi(l,4)!+ghalf4
3652           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3653           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3654      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3655      &   *fac_shield(i)*fac_shield(j)
3656
3657           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3658           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3659           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3660           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3661           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3662           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3663      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3664      &   *fac_shield(i)*fac_shield(j)
3665           a_temp(1,1)=aggj(l,1)!+ghalf1
3666           a_temp(1,2)=aggj(l,2)!+ghalf2
3667           a_temp(2,1)=aggj(l,3)!+ghalf3
3668           a_temp(2,2)=aggj(l,4)!+ghalf4
3669           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3670           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3671      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3672      &   *fac_shield(i)*fac_shield(j)
3673           a_temp(1,1)=aggj1(l,1)
3674           a_temp(1,2)=aggj1(l,2)
3675           a_temp(2,1)=aggj1(l,3)
3676           a_temp(2,2)=aggj1(l,4)
3677           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3678           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3679      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3680      &   *fac_shield(i)*fac_shield(j)
3681         enddo
3682
3683         endif ! calc_grad
3684
3685       return
3686       end
3687 C-------------------------------------------------------------------------------
3688       subroutine eturn4(i,eello_turn4)
3689 C Third- and fourth-order contributions from turns
3690       implicit real*8 (a-h,o-z)
3691       include 'DIMENSIONS'
3692       include 'DIMENSIONS.ZSCOPT'
3693       include 'COMMON.IOUNITS'
3694       include 'COMMON.GEO'
3695       include 'COMMON.VAR'
3696       include 'COMMON.LOCAL'
3697       include 'COMMON.CHAIN'
3698       include 'COMMON.DERIV'
3699       include 'COMMON.INTERACT'
3700       include 'COMMON.CONTACTS'
3701       include 'COMMON.TORSION'
3702       include 'COMMON.VECTORS'
3703       include 'COMMON.FFIELD'
3704       include 'COMMON.CONTROL'
3705       include 'COMMON.SHIELD'
3706       include 'COMMON.CORRMAT'
3707       dimension ggg(3)
3708       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3709      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3710      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3711      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3712      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3713      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3714      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3715       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3716      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3717       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3718      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3719      &    num_conti,j1,j2
3720       j=i+3
3721 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3722 C
3723 C               Fourth-order contributions
3724 C
3725 C                 (i+3)o----(i+4)
3726 C                     /  |
3727 C               (i+2)o   |
3728 C                     \  |
3729 C                 (i+1)o----i
3730 C
3731 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3732 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3733 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3734 c        write(iout,*)"WCHODZE W PROGRAM"
3735         a_temp(1,1)=a22
3736         a_temp(1,2)=a23
3737         a_temp(2,1)=a32
3738         a_temp(2,2)=a33
3739         iti1=itype2loc(itype(i+1))
3740         iti2=itype2loc(itype(i+2))
3741         iti3=itype2loc(itype(i+3))
3742 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3743         call transpose2(EUg(1,1,i+1),e1t(1,1))
3744         call transpose2(Eug(1,1,i+2),e2t(1,1))
3745         call transpose2(Eug(1,1,i+3),e3t(1,1))
3746 C Ematrix derivative in theta
3747         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3748         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3749         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3750         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3751 c       eta1 in derivative theta
3752         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3753         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754 c       auxgvec is derivative of Ub2 so i+3 theta
3755         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3756 c       auxalary matrix of E i+1
3757         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3758 c        s1=0.0
3759 c        gs1=0.0
3760         s1=scalar2(b1(1,i+2),auxvec(1))
3761 c derivative of theta i+2 with constant i+3
3762         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3763 c derivative of theta i+2 with constant i+2
3764         gs32=scalar2(b1(1,i+2),auxgvec(1))
3765 c derivative of E matix in theta of i+1
3766         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3767
3768         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3769 c       ea31 in derivative theta
3770         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3771         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3772 c auxilary matrix auxgvec of Ub2 with constant E matirx
3773         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3774 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3775         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3776
3777 c        s2=0.0
3778 c        gs2=0.0
3779         s2=scalar2(b1(1,i+1),auxvec(1))
3780 c derivative of theta i+1 with constant i+3
3781         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3782 c derivative of theta i+2 with constant i+1
3783         gs21=scalar2(b1(1,i+1),auxgvec(1))
3784 c derivative of theta i+3 with constant i+1
3785         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3786 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3787 c     &  gtb1(1,i+1)
3788         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3789 c two derivatives over diffetent matrices
3790 c gtae3e2 is derivative over i+3
3791         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3792 c ae3gte2 is derivative over i+2
3793         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3794         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3795 c three possible derivative over theta E matices
3796 c i+1
3797         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3798 c i+2
3799         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3800 c i+3
3801         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3802         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3803
3804         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3805         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3806         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3807         if (shield_mode.eq.0) then
3808         fac_shield(i)=1.0
3809         fac_shield(j)=1.0
3810 C        else
3811 C        fac_shield(i)=0.6
3812 C        fac_shield(j)=0.4
3813         endif
3814         eello_turn4=eello_turn4-(s1+s2+s3)
3815      &  *fac_shield(i)*fac_shield(j)
3816         eello_t4=-(s1+s2+s3)
3817      &  *fac_shield(i)*fac_shield(j)
3818 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3819         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3820      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3821 C Now derivative over shield:
3822           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3823      &  (shield_mode.gt.0)) then
3824 C          print *,i,j
3825
3826           do ilist=1,ishield_list(i)
3827            iresshield=shield_list(ilist,i)
3828            do k=1,3
3829            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3830 C     &      *2.0
3831            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3832      &              rlocshield
3833      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3834             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3835      &      +rlocshield
3836            enddo
3837           enddo
3838           do ilist=1,ishield_list(j)
3839            iresshield=shield_list(ilist,j)
3840            do k=1,3
3841            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3842 C     &     *2.0
3843            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3844      &              rlocshield
3845      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3846            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3847      &             +rlocshield
3848
3849            enddo
3850           enddo
3851
3852           do k=1,3
3853             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3854      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3855             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3856      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3857             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3858      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3859             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3860      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3861            enddo
3862            endif
3863 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3864 cd     &    ' eello_turn4_num',8*eello_turn4_num
3865 #ifdef NEWCORR
3866         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3867      &                  -(gs13+gsE13+gsEE1)*wturn4
3868      &  *fac_shield(i)*fac_shield(j)
3869         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3870      &                    -(gs23+gs21+gsEE2)*wturn4
3871      &  *fac_shield(i)*fac_shield(j)
3872
3873         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3874      &                    -(gs32+gsE31+gsEE3)*wturn4
3875      &  *fac_shield(i)*fac_shield(j)
3876
3877 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3878 c     &   gs2
3879 #endif
3880         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3881      &      'eturn4',i,j,-(s1+s2+s3)
3882 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3883 c     &    ' eello_turn4_num',8*eello_turn4_num
3884 C Derivatives in gamma(i)
3885         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3886         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3887         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3888         s1=scalar2(b1(1,i+2),auxvec(1))
3889         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3890         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3891         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3892      &  *fac_shield(i)*fac_shield(j)
3893 C Derivatives in gamma(i+1)
3894         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3895         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3896         s2=scalar2(b1(1,i+1),auxvec(1))
3897         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3898         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3900         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3901      &  *fac_shield(i)*fac_shield(j)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,i+2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,i+1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913      &  *fac_shield(i)*fac_shield(j)
3914         if (calc_grad) then
3915 C Cartesian derivatives
3916 C Derivatives of this turn contributions in DC(i+2)
3917         if (j.lt.nres-1) then
3918           do l=1,3
3919             a_temp(1,1)=agg(l,1)
3920             a_temp(1,2)=agg(l,2)
3921             a_temp(2,1)=agg(l,3)
3922             a_temp(2,2)=agg(l,4)
3923             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3924             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3925             s1=scalar2(b1(1,i+2),auxvec(1))
3926             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3927             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3928             s2=scalar2(b1(1,i+1),auxvec(1))
3929             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3930             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3931             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3932             ggg(l)=-(s1+s2+s3)
3933             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3934      &  *fac_shield(i)*fac_shield(j)
3935           enddo
3936         endif
3937 C Remaining derivatives of this turn contribution
3938         do l=1,3
3939           a_temp(1,1)=aggi(l,1)
3940           a_temp(1,2)=aggi(l,2)
3941           a_temp(2,1)=aggi(l,3)
3942           a_temp(2,2)=aggi(l,4)
3943           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3944           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3945           s1=scalar2(b1(1,i+2),auxvec(1))
3946           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3947           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3948           s2=scalar2(b1(1,i+1),auxvec(1))
3949           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3950           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3951           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3952           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3953      &  *fac_shield(i)*fac_shield(j)
3954           a_temp(1,1)=aggi1(l,1)
3955           a_temp(1,2)=aggi1(l,2)
3956           a_temp(2,1)=aggi1(l,3)
3957           a_temp(2,2)=aggi1(l,4)
3958           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3959           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3960           s1=scalar2(b1(1,i+2),auxvec(1))
3961           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3962           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3963           s2=scalar2(b1(1,i+1),auxvec(1))
3964           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3965           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3966           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3967           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3968      &  *fac_shield(i)*fac_shield(j)
3969           a_temp(1,1)=aggj(l,1)
3970           a_temp(1,2)=aggj(l,2)
3971           a_temp(2,1)=aggj(l,3)
3972           a_temp(2,2)=aggj(l,4)
3973           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3974           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3975           s1=scalar2(b1(1,i+2),auxvec(1))
3976           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3977           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3978           s2=scalar2(b1(1,i+1),auxvec(1))
3979           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3980           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3981           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3982           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3983      &  *fac_shield(i)*fac_shield(j)
3984           a_temp(1,1)=aggj1(l,1)
3985           a_temp(1,2)=aggj1(l,2)
3986           a_temp(2,1)=aggj1(l,3)
3987           a_temp(2,2)=aggj1(l,4)
3988           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3989           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3990           s1=scalar2(b1(1,i+2),auxvec(1))
3991           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3992           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3993           s2=scalar2(b1(1,i+1),auxvec(1))
3994           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3995           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3996           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3997 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3998           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3999      &  *fac_shield(i)*fac_shield(j)
4000         enddo
4001
4002         endif ! calc_grad
4003
4004       return
4005       end
4006 C-----------------------------------------------------------------------------
4007       subroutine vecpr(u,v,w)
4008       implicit real*8(a-h,o-z)
4009       dimension u(3),v(3),w(3)
4010       w(1)=u(2)*v(3)-u(3)*v(2)
4011       w(2)=-u(1)*v(3)+u(3)*v(1)
4012       w(3)=u(1)*v(2)-u(2)*v(1)
4013       return
4014       end
4015 C-----------------------------------------------------------------------------
4016       subroutine unormderiv(u,ugrad,unorm,ungrad)
4017 C This subroutine computes the derivatives of a normalized vector u, given
4018 C the derivatives computed without normalization conditions, ugrad. Returns
4019 C ungrad.
4020       implicit none
4021       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4022       double precision vec(3)
4023       double precision scalar
4024       integer i,j
4025 c      write (2,*) 'ugrad',ugrad
4026 c      write (2,*) 'u',u
4027       do i=1,3
4028         vec(i)=scalar(ugrad(1,i),u(1))
4029       enddo
4030 c      write (2,*) 'vec',vec
4031       do i=1,3
4032         do j=1,3
4033           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4034         enddo
4035       enddo
4036 c      write (2,*) 'ungrad',ungrad
4037       return
4038       end
4039 C-----------------------------------------------------------------------------
4040       subroutine escp(evdw2,evdw2_14)
4041 C
4042 C This subroutine calculates the excluded-volume interaction energy between
4043 C peptide-group centers and side chains and its gradient in virtual-bond and
4044 C side-chain vectors.
4045 C
4046       implicit real*8 (a-h,o-z)
4047       include 'DIMENSIONS'
4048       include 'DIMENSIONS.ZSCOPT'
4049       include 'COMMON.CONTROL'
4050       include 'COMMON.GEO'
4051       include 'COMMON.VAR'
4052       include 'COMMON.LOCAL'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.DERIV'
4055       include 'COMMON.INTERACT'
4056       include 'COMMON.FFIELD'
4057       include 'COMMON.IOUNITS'
4058       dimension ggg(3)
4059       evdw2=0.0D0
4060       evdw2_14=0.0d0
4061 cd    print '(a)','Enter ESCP'
4062 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4063 c     &  ' scal14',scal14
4064       do i=iatscp_s,iatscp_e
4065         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4066         iteli=itel(i)
4067 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4068 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4069         if (iteli.eq.0) goto 1225
4070         xi=0.5D0*(c(1,i)+c(1,i+1))
4071         yi=0.5D0*(c(2,i)+c(2,i+1))
4072         zi=0.5D0*(c(3,i)+c(3,i+1))
4073 C Returning the ith atom to box
4074           xi=mod(xi,boxxsize)
4075           if (xi.lt.0) xi=xi+boxxsize
4076           yi=mod(yi,boxysize)
4077           if (yi.lt.0) yi=yi+boxysize
4078           zi=mod(zi,boxzsize)
4079           if (zi.lt.0) zi=zi+boxzsize
4080         do iint=1,nscp_gr(i)
4081
4082         do j=iscpstart(i,iint),iscpend(i,iint)
4083           itypj=iabs(itype(j))
4084           if (itypj.eq.ntyp1) cycle
4085 C Uncomment following three lines for SC-p interactions
4086 c         xj=c(1,nres+j)-xi
4087 c         yj=c(2,nres+j)-yi
4088 c         zj=c(3,nres+j)-zi
4089 C Uncomment following three lines for Ca-p interactions
4090           xj=c(1,j)
4091           yj=c(2,j)
4092           zj=c(3,j)
4093 C returning the jth atom to box
4094           xj=mod(xj,boxxsize)
4095           if (xj.lt.0) xj=xj+boxxsize
4096           yj=mod(yj,boxysize)
4097           if (yj.lt.0) yj=yj+boxysize
4098           zj=mod(zj,boxzsize)
4099           if (zj.lt.0) zj=zj+boxzsize
4100       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4101       xj_safe=xj
4102       yj_safe=yj
4103       zj_safe=zj
4104       subchap=0
4105 C Finding the closest jth atom
4106       do xshift=-1,1
4107       do yshift=-1,1
4108       do zshift=-1,1
4109           xj=xj_safe+xshift*boxxsize
4110           yj=yj_safe+yshift*boxysize
4111           zj=zj_safe+zshift*boxzsize
4112           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4113           if(dist_temp.lt.dist_init) then
4114             dist_init=dist_temp
4115             xj_temp=xj
4116             yj_temp=yj
4117             zj_temp=zj
4118             subchap=1
4119           endif
4120        enddo
4121        enddo
4122        enddo
4123        if (subchap.eq.1) then
4124           xj=xj_temp-xi
4125           yj=yj_temp-yi
4126           zj=zj_temp-zi
4127        else
4128           xj=xj_safe-xi
4129           yj=yj_safe-yi
4130           zj=zj_safe-zi
4131        endif
4132           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4133 C sss is scaling function for smoothing the cutoff gradient otherwise
4134 C the gradient would not be continuouse
4135           sss=sscale(1.0d0/(dsqrt(rrij)))
4136           if (sss.le.0.0d0) cycle
4137           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4138           fac=rrij**expon2
4139           e1=fac*fac*aad(itypj,iteli)
4140           e2=fac*bad(itypj,iteli)
4141           if (iabs(j-i) .le. 2) then
4142             e1=scal14*e1
4143             e2=scal14*e2
4144             evdw2_14=evdw2_14+(e1+e2)*sss
4145           endif
4146           evdwij=e1+e2
4147 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4148 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4149 c     &       bad(itypj,iteli)
4150           evdw2=evdw2+evdwij*sss
4151           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4152      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4153      &       bad(itypj,iteli)
4154
4155           if (calc_grad) then
4156 C
4157 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4158 C
4159           fac=-(evdwij+e1)*rrij*sss
4160           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4161           ggg(1)=xj*fac
4162           ggg(2)=yj*fac
4163           ggg(3)=zj*fac
4164           if (j.lt.i) then
4165 cd          write (iout,*) 'j<i'
4166 C Uncomment following three lines for SC-p interactions
4167 c           do k=1,3
4168 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4169 c           enddo
4170           else
4171 cd          write (iout,*) 'j>i'
4172             do k=1,3
4173               ggg(k)=-ggg(k)
4174 C Uncomment following line for SC-p interactions
4175 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4176             enddo
4177           endif
4178           do k=1,3
4179             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4180           enddo
4181           kstart=min0(i+1,j)
4182           kend=max0(i-1,j-1)
4183 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4184 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4185           do k=kstart,kend
4186             do l=1,3
4187               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4188             enddo
4189           enddo
4190           endif ! calc_grad
4191         enddo
4192         enddo ! iint
4193  1225   continue
4194       enddo ! i
4195       do i=1,nct
4196         do j=1,3
4197           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4198           gradx_scp(j,i)=expon*gradx_scp(j,i)
4199         enddo
4200       enddo
4201 C******************************************************************************
4202 C
4203 C                              N O T E !!!
4204 C
4205 C To save time the factor EXPON has been extracted from ALL components
4206 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4207 C use!
4208 C
4209 C******************************************************************************
4210       return
4211       end
4212 C--------------------------------------------------------------------------
4213       subroutine edis(ehpb)
4214 C
4215 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4216 C
4217       implicit real*8 (a-h,o-z)
4218       include 'DIMENSIONS'
4219       include 'DIMENSIONS.ZSCOPT'
4220       include 'COMMON.SBRIDGE'
4221       include 'COMMON.CHAIN'
4222       include 'COMMON.DERIV'
4223       include 'COMMON.VAR'
4224       include 'COMMON.INTERACT'
4225       include 'COMMON.CONTROL'
4226       include 'COMMON.IOUNITS'
4227       dimension ggg(3),ggg_peak(3,1000)
4228       ehpb=0.0D0
4229       do i=1,3
4230        ggg(i)=0.0d0
4231       enddo
4232 c 8/21/18 AL: added explicit restraints on reference coords
4233 c      write (iout,*) "restr_on_coord",restr_on_coord
4234       if (restr_on_coord) then
4235
4236       do i=nnt,nct
4237         ecoor=0.0d0
4238         if (itype(i).eq.ntyp1) cycle
4239         do j=1,3
4240           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4241           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4242         enddo
4243         if (itype(i).ne.10) then
4244           do j=1,3
4245             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4246             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4247           enddo
4248         endif
4249         if (energy_dec) write (iout,*)
4250      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4251         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4252       enddo
4253
4254       endif
4255
4256 C      write (iout,*) ,"link_end",link_end,constr_dist
4257 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4258 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4259 c     &  " constr_dist",constr_dist
4260       if (link_end.eq.0.and.link_end_peak.eq.0) return
4261       do i=link_start_peak,link_end_peak
4262         ehpb_peak=0.0d0
4263 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4264 c     &   ipeak(1,i),ipeak(2,i)
4265         do ip=ipeak(1,i),ipeak(2,i)
4266           ii=ihpb_peak(ip)
4267           jj=jhpb_peak(ip)
4268           dd=dist(ii,jj)
4269           iip=ip-ipeak(1,i)+1
4270 C iii and jjj point to the residues for which the distance is assigned.
4271 c          if (ii.gt.nres) then
4272 c            iii=ii-nres
4273 c            jjj=jj-nres
4274 c          else
4275 c            iii=ii
4276 c            jjj=jj
4277 c          endif
4278           if (ii.gt.nres) then
4279             iii=ii-nres
4280           else
4281             iii=ii
4282           endif
4283           if (jj.gt.nres) then
4284             jjj=jj-nres
4285           else
4286             jjj=jj
4287           endif
4288           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4289           aux=dexp(-scal_peak*aux)
4290           ehpb_peak=ehpb_peak+aux
4291           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4292      &      forcon_peak(ip))*aux/dd
4293           do j=1,3
4294             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4295           enddo
4296           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4297      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4298      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4299         enddo
4300 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4301         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4302         do ip=ipeak(1,i),ipeak(2,i)
4303           iip=ip-ipeak(1,i)+1
4304           do j=1,3
4305             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4306           enddo
4307           ii=ihpb_peak(ip)
4308           jj=jhpb_peak(ip)
4309 C iii and jjj point to the residues for which the distance is assigned.
4310           if (ii.gt.nres) then
4311             iii=ii-nres
4312             jjj=jj-nres
4313           else
4314             iii=ii
4315             jjj=jj
4316           endif
4317           if (iii.lt.ii) then
4318             do j=1,3
4319               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4320             enddo
4321           endif
4322           if (jjj.lt.jj) then
4323             do j=1,3
4324               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4325             enddo
4326           endif
4327           do k=1,3
4328             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4329             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4330           enddo
4331         enddo
4332       enddo
4333       do i=link_start,link_end
4334 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4335 C CA-CA distance used in regularization of structure.
4336         ii=ihpb(i)
4337         jj=jhpb(i)
4338 C iii and jjj point to the residues for which the distance is assigned.
4339         if (ii.gt.nres) then
4340           iii=ii-nres
4341         else
4342           iii=ii
4343         endif
4344         if (jj.gt.nres) then
4345           jjj=jj-nres
4346         else
4347           jjj=jj
4348         endif
4349 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4350 c     &    dhpb(i),dhpb1(i),forcon(i)
4351 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4352 C    distance and angle dependent SS bond potential.
4353 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4354 C     & iabs(itype(jjj)).eq.1) then
4355 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4356 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4357         if (.not.dyn_ss .and. i.le.nss) then
4358 C 15/02/13 CC dynamic SSbond - additional check
4359           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4360      &        iabs(itype(jjj)).eq.1) then
4361            call ssbond_ene(iii,jjj,eij)
4362            ehpb=ehpb+2*eij
4363          endif
4364 cd          write (iout,*) "eij",eij
4365 cd   &   ' waga=',waga,' fac=',fac
4366 !        else if (ii.gt.nres .and. jj.gt.nres) then
4367         else
4368 C Calculate the distance between the two points and its difference from the
4369 C target distance.
4370           dd=dist(ii,jj)
4371           if (irestr_type(i).eq.11) then
4372             ehpb=ehpb+fordepth(i)!**4.0d0
4373      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4374             fac=fordepth(i)!**4.0d0
4375      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4376             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4377      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4378      &        ehpb,irestr_type(i)
4379           else if (irestr_type(i).eq.10) then
4380 c AL 6//19/2018 cross-link restraints
4381             xdis = 0.5d0*(dd/forcon(i))**2
4382             expdis = dexp(-xdis)
4383 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4384             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4385 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4386 c     &          " wboltzd",wboltzd
4387             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4388 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4389             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4390      &           *expdis/(aux*forcon(i)**2)
4391             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4392      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4393      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4394           else if (irestr_type(i).eq.2) then
4395 c Quartic restraints
4396             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4397             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4398      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4399      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4400             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4401           else
4402 c Quadratic restraints
4403             rdis=dd-dhpb(i)
4404 C Get the force constant corresponding to this distance.
4405             waga=forcon(i)
4406 C Calculate the contribution to energy.
4407             ehpb=ehpb+0.5d0*waga*rdis*rdis
4408             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4409      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4410      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4411 C
4412 C Evaluate gradient.
4413 C
4414             fac=waga*rdis/dd
4415           endif
4416 c Calculate Cartesian gradient
4417           do j=1,3
4418             ggg(j)=fac*(c(j,jj)-c(j,ii))
4419           enddo
4420 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4421 C If this is a SC-SC distance, we need to calculate the contributions to the
4422 C Cartesian gradient in the SC vectors (ghpbx).
4423           if (iii.lt.ii) then
4424             do j=1,3
4425               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4426             enddo
4427           endif
4428           if (jjj.lt.jj) then
4429             do j=1,3
4430               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4431             enddo
4432           endif
4433           do k=1,3
4434             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4435             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4436           enddo
4437         endif
4438       enddo
4439       return
4440       end
4441 C--------------------------------------------------------------------------
4442       subroutine ssbond_ene(i,j,eij)
4443 C
4444 C Calculate the distance and angle dependent SS-bond potential energy
4445 C using a free-energy function derived based on RHF/6-31G** ab initio
4446 C calculations of diethyl disulfide.
4447 C
4448 C A. Liwo and U. Kozlowska, 11/24/03
4449 C
4450       implicit real*8 (a-h,o-z)
4451       include 'DIMENSIONS'
4452       include 'DIMENSIONS.ZSCOPT'
4453       include 'COMMON.SBRIDGE'
4454       include 'COMMON.CHAIN'
4455       include 'COMMON.DERIV'
4456       include 'COMMON.LOCAL'
4457       include 'COMMON.INTERACT'
4458       include 'COMMON.VAR'
4459       include 'COMMON.IOUNITS'
4460       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4461       itypi=iabs(itype(i))
4462       xi=c(1,nres+i)
4463       yi=c(2,nres+i)
4464       zi=c(3,nres+i)
4465       dxi=dc_norm(1,nres+i)
4466       dyi=dc_norm(2,nres+i)
4467       dzi=dc_norm(3,nres+i)
4468       dsci_inv=dsc_inv(itypi)
4469       itypj=iabs(itype(j))
4470       dscj_inv=dsc_inv(itypj)
4471       xj=c(1,nres+j)-xi
4472       yj=c(2,nres+j)-yi
4473       zj=c(3,nres+j)-zi
4474       dxj=dc_norm(1,nres+j)
4475       dyj=dc_norm(2,nres+j)
4476       dzj=dc_norm(3,nres+j)
4477       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4478       rij=dsqrt(rrij)
4479       erij(1)=xj*rij
4480       erij(2)=yj*rij
4481       erij(3)=zj*rij
4482       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4483       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4484       om12=dxi*dxj+dyi*dyj+dzi*dzj
4485       do k=1,3
4486         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4487         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4488       enddo
4489       rij=1.0d0/rij
4490       deltad=rij-d0cm
4491       deltat1=1.0d0-om1
4492       deltat2=1.0d0+om2
4493       deltat12=om2-om1+2.0d0
4494       cosphi=om12-om1*om2
4495       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4496      &  +akct*deltad*deltat12
4497      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4498 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4499 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4500 c     &  " deltat12",deltat12," eij",eij
4501       ed=2*akcm*deltad+akct*deltat12
4502       pom1=akct*deltad
4503       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4504       eom1=-2*akth*deltat1-pom1-om2*pom2
4505       eom2= 2*akth*deltat2+pom1-om1*pom2
4506       eom12=pom2
4507       do k=1,3
4508         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4509       enddo
4510       do k=1,3
4511         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4512      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4513         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4514      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4515       enddo
4516 C
4517 C Calculate the components of the gradient in DC and X
4518 C
4519       do k=i,j-1
4520         do l=1,3
4521           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4522         enddo
4523       enddo
4524       return
4525       end
4526 C--------------------------------------------------------------------------
4527 c MODELLER restraint function
4528       subroutine e_modeller(ehomology_constr)
4529       implicit real*8 (a-h,o-z)
4530       include 'DIMENSIONS'
4531       include 'DIMENSIONS.ZSCOPT'
4532       include 'DIMENSIONS.FREE'
4533       integer nnn, i, j, k, ki, irec, l
4534       integer katy, odleglosci, test7
4535       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4536       real*8 distance(max_template),distancek(max_template),
4537      &    min_odl,godl(max_template),dih_diff(max_template)
4538
4539 c
4540 c     FP - 30/10/2014 Temporary specifications for homology restraints
4541 c
4542       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4543      &                 sgtheta
4544       double precision, dimension (maxres) :: guscdiff,usc_diff
4545       double precision, dimension (max_template) ::
4546      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4547      &           theta_diff
4548
4549       include 'COMMON.SBRIDGE'
4550       include 'COMMON.CHAIN'
4551       include 'COMMON.GEO'
4552       include 'COMMON.DERIV'
4553       include 'COMMON.LOCAL'
4554       include 'COMMON.INTERACT'
4555       include 'COMMON.VAR'
4556       include 'COMMON.IOUNITS'
4557       include 'COMMON.CONTROL'
4558       include 'COMMON.HOMRESTR'
4559       include 'COMMON.HOMOLOGY'
4560       include 'COMMON.SETUP'
4561       include 'COMMON.NAMES'
4562
4563       do i=1,max_template
4564         distancek(i)=9999999.9
4565       enddo
4566
4567       odleg=0.0d0
4568
4569 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4570 c function)
4571 C AL 5/2/14 - Introduce list of restraints
4572 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4573 #ifdef DEBUG
4574       write(iout,*) "------- dist restrs start -------"
4575 #endif
4576       do ii = link_start_homo,link_end_homo
4577          i = ires_homo(ii)
4578          j = jres_homo(ii)
4579          dij=dist(i,j)
4580 c        write (iout,*) "dij(",i,j,") =",dij
4581          nexl=0
4582          do k=1,constr_homology
4583            if(.not.l_homo(k,ii)) then
4584               nexl=nexl+1
4585               cycle
4586            endif
4587            distance(k)=odl(k,ii)-dij
4588 c          write (iout,*) "distance(",k,") =",distance(k)
4589 c
4590 c          For Gaussian-type Urestr
4591 c
4592            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4593 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4594 c          write (iout,*) "distancek(",k,") =",distancek(k)
4595 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4596 c
4597 c          For Lorentzian-type Urestr
4598 c
4599            if (waga_dist.lt.0.0d0) then
4600               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4601               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4602      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4603            endif
4604          enddo
4605
4606 c         min_odl=minval(distancek)
4607          do kk=1,constr_homology
4608           if(l_homo(kk,ii)) then
4609             min_odl=distancek(kk)
4610             exit
4611           endif
4612          enddo
4613          do kk=1,constr_homology
4614           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4615      &              min_odl=distancek(kk)
4616          enddo
4617 c        write (iout,* )"min_odl",min_odl
4618 #ifdef DEBUG
4619          write (iout,*) "ij dij",i,j,dij
4620          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4621          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4622          write (iout,* )"min_odl",min_odl
4623 #endif
4624 #ifdef OLDRESTR
4625          odleg2=0.0d0
4626 #else
4627          if (waga_dist.ge.0.0d0) then
4628            odleg2=nexl
4629          else
4630            odleg2=0.0d0
4631          endif
4632 #endif
4633          do k=1,constr_homology
4634 c Nie wiem po co to liczycie jeszcze raz!
4635 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4636 c     &              (2*(sigma_odl(i,j,k))**2))
4637            if(.not.l_homo(k,ii)) cycle
4638            if (waga_dist.ge.0.0d0) then
4639 c
4640 c          For Gaussian-type Urestr
4641 c
4642             godl(k)=dexp(-distancek(k)+min_odl)
4643             odleg2=odleg2+godl(k)
4644 c
4645 c          For Lorentzian-type Urestr
4646 c
4647            else
4648             odleg2=odleg2+distancek(k)
4649            endif
4650
4651 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4652 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4653 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4654 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4655
4656          enddo
4657 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4658 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4659 #ifdef DEBUG
4660          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4661          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4662 #endif
4663            if (waga_dist.ge.0.0d0) then
4664 c
4665 c          For Gaussian-type Urestr
4666 c
4667               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4668 c
4669 c          For Lorentzian-type Urestr
4670 c
4671            else
4672               odleg=odleg+odleg2/constr_homology
4673            endif
4674 c
4675 #ifdef GRAD
4676 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4677 c Gradient
4678 c
4679 c          For Gaussian-type Urestr
4680 c
4681          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4682          sum_sgodl=0.0d0
4683          do k=1,constr_homology
4684 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4685 c     &           *waga_dist)+min_odl
4686 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4687 c
4688          if(.not.l_homo(k,ii)) cycle
4689          if (waga_dist.ge.0.0d0) then
4690 c          For Gaussian-type Urestr
4691 c
4692            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4693 c
4694 c          For Lorentzian-type Urestr
4695 c
4696          else
4697            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4698      &           sigma_odlir(k,ii)**2)**2)
4699          endif
4700            sum_sgodl=sum_sgodl+sgodl
4701
4702 c            sgodl2=sgodl2+sgodl
4703 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4704 c      write(iout,*) "constr_homology=",constr_homology
4705 c      write(iout,*) i, j, k, "TEST K"
4706          enddo
4707          if (waga_dist.ge.0.0d0) then
4708 c
4709 c          For Gaussian-type Urestr
4710 c
4711             grad_odl3=waga_homology(iset)*waga_dist
4712      &                *sum_sgodl/(sum_godl*dij)
4713 c
4714 c          For Lorentzian-type Urestr
4715 c
4716          else
4717 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4718 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4719             grad_odl3=-waga_homology(iset)*waga_dist*
4720      &                sum_sgodl/(constr_homology*dij)
4721          endif
4722 c
4723 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4724
4725
4726 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4727 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4728 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4729
4730 ccc      write(iout,*) godl, sgodl, grad_odl3
4731
4732 c          grad_odl=grad_odl+grad_odl3
4733
4734          do jik=1,3
4735             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4736 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4737 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4738 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4739             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4740             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4741 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4742 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4743 c         if (i.eq.25.and.j.eq.27) then
4744 c         write(iout,*) "jik",jik,"i",i,"j",j
4745 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4746 c         write(iout,*) "grad_odl3",grad_odl3
4747 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4748 c         write(iout,*) "ggodl",ggodl
4749 c         write(iout,*) "ghpbc(",jik,i,")",
4750 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4751 c     &                 ghpbc(jik,j)
4752 c         endif
4753          enddo
4754 #endif
4755 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4756 ccc     & dLOG(odleg2),"-odleg=", -odleg
4757
4758       enddo ! ii-loop for dist
4759 #ifdef DEBUG
4760       write(iout,*) "------- dist restrs end -------"
4761 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4762 c    &     waga_d.eq.1.0d0) call sum_gradient
4763 #endif
4764 c Pseudo-energy and gradient from dihedral-angle restraints from
4765 c homology templates
4766 c      write (iout,*) "End of distance loop"
4767 c      call flush(iout)
4768       kat=0.0d0
4769 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4770 #ifdef DEBUG
4771       write(iout,*) "------- dih restrs start -------"
4772       do i=idihconstr_start_homo,idihconstr_end_homo
4773         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4774       enddo
4775 #endif
4776       do i=idihconstr_start_homo,idihconstr_end_homo
4777         kat2=0.0d0
4778 c        betai=beta(i,i+1,i+2,i+3)
4779         betai = phi(i)
4780 c       write (iout,*) "betai =",betai
4781         do k=1,constr_homology
4782           dih_diff(k)=pinorm(dih(k,i)-betai)
4783 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4784 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4785 c     &                                   -(6.28318-dih_diff(i,k))
4786 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4787 c     &                                   6.28318+dih_diff(i,k)
4788 #ifdef OLD_DIHED
4789           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4790 #else
4791           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4792 #endif
4793 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4794           gdih(k)=dexp(kat3)
4795           kat2=kat2+gdih(k)
4796 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4797 c          write(*,*)""
4798         enddo
4799 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4800 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4801 #ifdef DEBUG
4802         write (iout,*) "i",i," betai",betai," kat2",kat2
4803         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4804 #endif
4805         if (kat2.le.1.0d-14) cycle
4806         kat=kat-dLOG(kat2/constr_homology)
4807 c       write (iout,*) "kat",kat ! sum of -ln-s
4808
4809 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4810 ccc     & dLOG(kat2), "-kat=", -kat
4811
4812 #ifdef GRAD
4813 c ----------------------------------------------------------------------
4814 c Gradient
4815 c ----------------------------------------------------------------------
4816
4817         sum_gdih=kat2
4818         sum_sgdih=0.0d0
4819         do k=1,constr_homology
4820 #ifdef OLD_DIHED
4821           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4822 #else
4823           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4824 #endif
4825 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4826           sum_sgdih=sum_sgdih+sgdih
4827         enddo
4828 c       grad_dih3=sum_sgdih/sum_gdih
4829         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4830
4831 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4832 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4833 ccc     & gloc(nphi+i-3,icg)
4834         gloc(i,icg)=gloc(i,icg)+grad_dih3
4835 c        if (i.eq.25) then
4836 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4837 c        endif
4838 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4839 ccc     & gloc(nphi+i-3,icg)
4840 #endif
4841       enddo ! i-loop for dih
4842 #ifdef DEBUG
4843       write(iout,*) "------- dih restrs end -------"
4844 #endif
4845
4846 c Pseudo-energy and gradient for theta angle restraints from
4847 c homology templates
4848 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4849 c adapted
4850
4851 c
4852 c     For constr_homology reference structures (FP)
4853 c
4854 c     Uconst_back_tot=0.0d0
4855       Eval=0.0d0
4856       Erot=0.0d0
4857 c     Econstr_back legacy
4858 #ifdef GRAD
4859       do i=1,nres
4860 c     do i=ithet_start,ithet_end
4861        dutheta(i)=0.0d0
4862 c     enddo
4863 c     do i=loc_start,loc_end
4864         do j=1,3
4865           duscdiff(j,i)=0.0d0
4866           duscdiffx(j,i)=0.0d0
4867         enddo
4868       enddo
4869 #endif
4870 c
4871 c     do iref=1,nref
4872 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4873 c     write (iout,*) "waga_theta",waga_theta
4874       if (waga_theta.gt.0.0d0) then
4875 #ifdef DEBUG
4876       write (iout,*) "usampl",usampl
4877       write(iout,*) "------- theta restrs start -------"
4878 c     do i=ithet_start,ithet_end
4879 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4880 c     enddo
4881 #endif
4882 c     write (iout,*) "maxres",maxres,"nres",nres
4883
4884       do i=ithet_start,ithet_end
4885 c
4886 c     do i=1,nfrag_back
4887 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4888 c
4889 c Deviation of theta angles wrt constr_homology ref structures
4890 c
4891         utheta_i=0.0d0 ! argument of Gaussian for single k
4892         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4893 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4894 c       over residues in a fragment
4895 c       write (iout,*) "theta(",i,")=",theta(i)
4896         do k=1,constr_homology
4897 c
4898 c         dtheta_i=theta(j)-thetaref(j,iref)
4899 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4900           theta_diff(k)=thetatpl(k,i)-theta(i)
4901 c
4902           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4903 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4904           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4905           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4906 c         Gradient for single Gaussian restraint in subr Econstr_back
4907 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4908 c
4909         enddo
4910 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4911 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4912
4913 c
4914 #ifdef GRAD
4915 c         Gradient for multiple Gaussian restraint
4916         sum_gtheta=gutheta_i
4917         sum_sgtheta=0.0d0
4918         do k=1,constr_homology
4919 c        New generalized expr for multiple Gaussian from Econstr_back
4920          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4921 c
4922 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4923           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4924         enddo
4925 c
4926 c       Final value of gradient using same var as in Econstr_back
4927         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4928      &               *waga_homology(iset)
4929 c       dutheta(i)=sum_sgtheta/sum_gtheta
4930 c
4931 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4932 #endif
4933         Eval=Eval-dLOG(gutheta_i/constr_homology)
4934 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4935 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4936 c       Uconst_back=Uconst_back+utheta(i)
4937       enddo ! (i-loop for theta)
4938 #ifdef DEBUG
4939       write(iout,*) "------- theta restrs end -------"
4940 #endif
4941       endif
4942 c
4943 c Deviation of local SC geometry
4944 c
4945 c Separation of two i-loops (instructed by AL - 11/3/2014)
4946 c
4947 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4948 c     write (iout,*) "waga_d",waga_d
4949
4950 #ifdef DEBUG
4951       write(iout,*) "------- SC restrs start -------"
4952       write (iout,*) "Initial duscdiff,duscdiffx"
4953       do i=loc_start,loc_end
4954         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4955      &                 (duscdiffx(jik,i),jik=1,3)
4956       enddo
4957 #endif
4958       do i=loc_start,loc_end
4959         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4960         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4961 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4962 c       write(iout,*) "xxtab, yytab, zztab"
4963 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4964         do k=1,constr_homology
4965 c
4966           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4967 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4968           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4969           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4970 c         write(iout,*) "dxx, dyy, dzz"
4971 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4972 c
4973           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4974 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4975 c         uscdiffk(k)=usc_diff(i)
4976           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4977           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4978 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4979 c     &      xxref(j),yyref(j),zzref(j)
4980         enddo
4981 c
4982 c       Gradient
4983 c
4984 c       Generalized expression for multiple Gaussian acc to that for a single
4985 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4986 c
4987 c       Original implementation
4988 c       sum_guscdiff=guscdiff(i)
4989 c
4990 c       sum_sguscdiff=0.0d0
4991 c       do k=1,constr_homology
4992 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4993 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4994 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4995 c       enddo
4996 c
4997 c       Implementation of new expressions for gradient (Jan. 2015)
4998 c
4999 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
5000 #ifdef GRAD
5001         do k=1,constr_homology
5002 c
5003 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
5004 c       before. Now the drivatives should be correct
5005 c
5006           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
5007 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
5008           dyy=-yytpl(k,i)+yytab(i) ! ibid y
5009           dzz=-zztpl(k,i)+zztab(i) ! ibid z
5010 c
5011 c         New implementation
5012 c
5013           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
5014      &                 sigma_d(k,i) ! for the grad wrt r'
5015 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
5016 c
5017 c
5018 c        New implementation
5019          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
5020          do jik=1,3
5021             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
5022      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
5023      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
5024             duscdiff(jik,i)=duscdiff(jik,i)+
5025      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
5026      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
5027             duscdiffx(jik,i)=duscdiffx(jik,i)+
5028      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
5029      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
5030 c
5031 #ifdef DEBUG
5032              write(iout,*) "jik",jik,"i",i
5033              write(iout,*) "dxx, dyy, dzz"
5034              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
5035              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
5036 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
5037 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
5038 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
5039 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
5040 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
5041 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
5042 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
5043 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
5044 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
5045 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
5046 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
5047 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
5048 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
5049 c            endif
5050 #endif
5051          enddo
5052         enddo
5053 #endif
5054 c
5055 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
5056 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
5057 c
5058 c        write (iout,*) i," uscdiff",uscdiff(i)
5059 c
5060 c Put together deviations from local geometry
5061
5062 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
5063 c      &            wfrag_back(3,i,iset)*uscdiff(i)
5064         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
5065 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
5066 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
5067 c       Uconst_back=Uconst_back+usc_diff(i)
5068 c
5069 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
5070 c
5071 c     New implment: multiplied by sum_sguscdiff
5072 c
5073
5074       enddo ! (i-loop for dscdiff)
5075
5076 c      endif
5077
5078 #ifdef DEBUG
5079       write(iout,*) "------- SC restrs end -------"
5080         write (iout,*) "------ After SC loop in e_modeller ------"
5081         do i=loc_start,loc_end
5082          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
5083          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
5084         enddo
5085       if (waga_theta.eq.1.0d0) then
5086       write (iout,*) "in e_modeller after SC restr end: dutheta"
5087       do i=ithet_start,ithet_end
5088         write (iout,*) i,dutheta(i)
5089       enddo
5090       endif
5091       if (waga_d.eq.1.0d0) then
5092       write (iout,*) "e_modeller after SC loop: duscdiff/x"
5093       do i=1,nres
5094         write (iout,*) i,(duscdiff(j,i),j=1,3)
5095         write (iout,*) i,(duscdiffx(j,i),j=1,3)
5096       enddo
5097       endif
5098 #endif
5099
5100 c Total energy from homology restraints
5101 #ifdef DEBUG
5102       write (iout,*) "odleg",odleg," kat",kat
5103       write (iout,*) "odleg",odleg," kat",kat
5104       write (iout,*) "Eval",Eval," Erot",Erot
5105       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5106       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5107       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5108 #endif
5109 c
5110 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5111 c
5112 c     ehomology_constr=odleg+kat
5113 c
5114 c     For Lorentzian-type Urestr
5115 c
5116
5117       if (waga_dist.ge.0.0d0) then
5118 c
5119 c          For Gaussian-type Urestr
5120 c
5121 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5122 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5123         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5124      &              waga_theta*Eval+waga_d*Erot
5125 c     write (iout,*) "ehomology_constr=",ehomology_constr
5126       else
5127 c
5128 c          For Lorentzian-type Urestr
5129 c
5130 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5131 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5132         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5133      &              waga_theta*Eval+waga_d*Erot
5134 c     write (iout,*) "ehomology_constr=",ehomology_constr
5135       endif
5136 #ifdef DEBUG
5137       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5138      & "Eval",waga_theta,eval,
5139      &   "Erot",waga_d,Erot
5140       write (iout,*) "ehomology_constr",ehomology_constr
5141 #endif
5142       return
5143
5144   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5145   747 format(a12,i4,i4,i4,f8.3,f8.3)
5146   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5147   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5148   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5149      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5150       end
5151 c-----------------------------------------------------------------------
5152       subroutine ebond(estr)
5153 c
5154 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5155 c
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'DIMENSIONS.ZSCOPT'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.GEO'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.VAR'
5164       include 'COMMON.CHAIN'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.NAMES'
5167       include 'COMMON.FFIELD'
5168       include 'COMMON.CONTROL'
5169       double precision u(3),ud(3)
5170       estr=0.0d0
5171       estr1=0.0d0
5172 c      write (iout,*) "distchainmax",distchainmax
5173       do i=nnt+1,nct
5174 #ifdef FIVEDIAG
5175         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5176         diff = vbld(i)-vbldp0
5177 #else
5178         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5179 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5180 C          do j=1,3
5181 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5182 C     &      *dc(j,i-1)/vbld(i)
5183 C          enddo
5184 C          if (energy_dec) write(iout,*)
5185 C     &       "estr1",i,vbld(i),distchainmax,
5186 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5187 C        else
5188          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5189         diff = vbld(i)-vbldpDUM
5190 C         write(iout,*) i,diff
5191          else
5192           diff = vbld(i)-vbldp0
5193 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5194          endif
5195 #endif
5196           estr=estr+diff*diff
5197           do j=1,3
5198             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5199           enddo
5200 C        endif
5201           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5202      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5203       enddo
5204       estr=0.5d0*AKP*estr+estr1
5205 c
5206 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5207 c
5208       do i=nnt,nct
5209         iti=iabs(itype(i))
5210         if (iti.ne.10 .and. iti.ne.ntyp1) then
5211           nbi=nbondterm(iti)
5212           if (nbi.eq.1) then
5213             diff=vbld(i+nres)-vbldsc0(1,iti)
5214             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5215      &      vbldsc0(1,iti),diff,
5216      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5217             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5218             do j=1,3
5219               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5220             enddo
5221           else
5222             do j=1,nbi
5223               diff=vbld(i+nres)-vbldsc0(j,iti)
5224               ud(j)=aksc(j,iti)*diff
5225               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5226             enddo
5227             uprod=u(1)
5228             do j=2,nbi
5229               uprod=uprod*u(j)
5230             enddo
5231             usum=0.0d0
5232             usumsqder=0.0d0
5233             do j=1,nbi
5234               uprod1=1.0d0
5235               uprod2=1.0d0
5236               do k=1,nbi
5237                 if (k.ne.j) then
5238                   uprod1=uprod1*u(k)
5239                   uprod2=uprod2*u(k)*u(k)
5240                 endif
5241               enddo
5242               usum=usum+uprod1
5243               usumsqder=usumsqder+ud(j)*uprod2
5244             enddo
5245 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5246 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5247             estr=estr+uprod/usum
5248             do j=1,3
5249              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5250             enddo
5251           endif
5252         endif
5253       enddo
5254       return
5255       end
5256 #ifdef CRYST_THETA
5257 C--------------------------------------------------------------------------
5258       subroutine ebend(etheta,ethetacnstr)
5259 C
5260 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5261 C angles gamma and its derivatives in consecutive thetas and gammas.
5262 C
5263       implicit real*8 (a-h,o-z)
5264       include 'DIMENSIONS'
5265       include 'DIMENSIONS.ZSCOPT'
5266       include 'COMMON.LOCAL'
5267       include 'COMMON.GEO'
5268       include 'COMMON.INTERACT'
5269       include 'COMMON.DERIV'
5270       include 'COMMON.VAR'
5271       include 'COMMON.CHAIN'
5272       include 'COMMON.IOUNITS'
5273       include 'COMMON.NAMES'
5274       include 'COMMON.FFIELD'
5275       include 'COMMON.TORCNSTR'
5276       common /calcthet/ term1,term2,termm,diffak,ratak,
5277      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5278      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5279       double precision y(2),z(2)
5280       delta=0.02d0*pi
5281 c      time11=dexp(-2*time)
5282 c      time12=1.0d0
5283       etheta=0.0D0
5284 c      write (iout,*) "nres",nres
5285 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5286 c      write (iout,*) ithet_start,ithet_end
5287       do i=ithet_start,ithet_end
5288 C        if (itype(i-1).eq.ntyp1) cycle
5289         if (i.le.2) cycle
5290         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5291      &  .or.itype(i).eq.ntyp1) cycle
5292 C Zero the energy function and its derivative at 0 or pi.
5293         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5294         it=itype(i-1)
5295         ichir1=isign(1,itype(i-2))
5296         ichir2=isign(1,itype(i))
5297          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5298          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5299          if (itype(i-1).eq.10) then
5300           itype1=isign(10,itype(i-2))
5301           ichir11=isign(1,itype(i-2))
5302           ichir12=isign(1,itype(i-2))
5303           itype2=isign(10,itype(i))
5304           ichir21=isign(1,itype(i))
5305           ichir22=isign(1,itype(i))
5306          endif
5307          if (i.eq.3) then
5308           y(1)=0.0D0
5309           y(2)=0.0D0
5310           else
5311
5312         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5313 #ifdef OSF
5314           phii=phi(i)
5315 c          icrc=0
5316 c          call proc_proc(phii,icrc)
5317           if (icrc.eq.1) phii=150.0
5318 #else
5319           phii=phi(i)
5320 #endif
5321           y(1)=dcos(phii)
5322           y(2)=dsin(phii)
5323         else
5324           y(1)=0.0D0
5325           y(2)=0.0D0
5326         endif
5327         endif
5328         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5329 #ifdef OSF
5330           phii1=phi(i+1)
5331 c          icrc=0
5332 c          call proc_proc(phii1,icrc)
5333           if (icrc.eq.1) phii1=150.0
5334           phii1=pinorm(phii1)
5335           z(1)=cos(phii1)
5336 #else
5337           phii1=phi(i+1)
5338           z(1)=dcos(phii1)
5339 #endif
5340           z(2)=dsin(phii1)
5341         else
5342           z(1)=0.0D0
5343           z(2)=0.0D0
5344         endif
5345 C Calculate the "mean" value of theta from the part of the distribution
5346 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5347 C In following comments this theta will be referred to as t_c.
5348         thet_pred_mean=0.0d0
5349         do k=1,2
5350             athetk=athet(k,it,ichir1,ichir2)
5351             bthetk=bthet(k,it,ichir1,ichir2)
5352           if (it.eq.10) then
5353              athetk=athet(k,itype1,ichir11,ichir12)
5354              bthetk=bthet(k,itype2,ichir21,ichir22)
5355           endif
5356           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5357         enddo
5358 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5359         dthett=thet_pred_mean*ssd
5360         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5361 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5362 C Derivatives of the "mean" values in gamma1 and gamma2.
5363         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5364      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5365          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5366      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5367          if (it.eq.10) then
5368       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5369      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5370         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5371      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5372          endif
5373         if (theta(i).gt.pi-delta) then
5374           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5375      &         E_tc0)
5376           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5377           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5378           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5379      &        E_theta)
5380           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5381      &        E_tc)
5382         else if (theta(i).lt.delta) then
5383           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5384           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5385           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5386      &        E_theta)
5387           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5388           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5389      &        E_tc)
5390         else
5391           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5392      &        E_theta,E_tc)
5393         endif
5394         etheta=etheta+ethetai
5395 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5396 c     &      'ebend',i,ethetai,theta(i),itype(i)
5397 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5398 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5399         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5400         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5401         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5402 c 1215   continue
5403       enddo
5404       ethetacnstr=0.0d0
5405 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5406       do i=1,ntheta_constr
5407         itheta=itheta_constr(i)
5408         thetiii=theta(itheta)
5409         difi=pinorm(thetiii-theta_constr0(i))
5410         if (difi.gt.theta_drange(i)) then
5411           difi=difi-theta_drange(i)
5412           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5413           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5414      &    +for_thet_constr(i)*difi**3
5415         else if (difi.lt.-drange(i)) then
5416           difi=difi+drange(i)
5417           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5418           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5419      &    +for_thet_constr(i)*difi**3
5420         else
5421           difi=0.0
5422         endif
5423 C       if (energy_dec) then
5424 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5425 C     &    i,itheta,rad2deg*thetiii,
5426 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5427 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5428 C     &    gloc(itheta+nphi-2,icg)
5429 C        endif
5430       enddo
5431 C Ufff.... We've done all this!!!
5432       return
5433       end
5434 C---------------------------------------------------------------------------
5435       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5436      &     E_tc)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.LOCAL'
5440       include 'COMMON.IOUNITS'
5441       common /calcthet/ term1,term2,termm,diffak,ratak,
5442      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5443      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5444 C Calculate the contributions to both Gaussian lobes.
5445 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5446 C The "polynomial part" of the "standard deviation" of this part of
5447 C the distribution.
5448         sig=polthet(3,it)
5449         do j=2,0,-1
5450           sig=sig*thet_pred_mean+polthet(j,it)
5451         enddo
5452 C Derivative of the "interior part" of the "standard deviation of the"
5453 C gamma-dependent Gaussian lobe in t_c.
5454         sigtc=3*polthet(3,it)
5455         do j=2,1,-1
5456           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5457         enddo
5458         sigtc=sig*sigtc
5459 C Set the parameters of both Gaussian lobes of the distribution.
5460 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5461         fac=sig*sig+sigc0(it)
5462         sigcsq=fac+fac
5463         sigc=1.0D0/sigcsq
5464 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5465         sigsqtc=-4.0D0*sigcsq*sigtc
5466 c       print *,i,sig,sigtc,sigsqtc
5467 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5468         sigtc=-sigtc/(fac*fac)
5469 C Following variable is sigma(t_c)**(-2)
5470         sigcsq=sigcsq*sigcsq
5471         sig0i=sig0(it)
5472         sig0inv=1.0D0/sig0i**2
5473         delthec=thetai-thet_pred_mean
5474         delthe0=thetai-theta0i
5475         term1=-0.5D0*sigcsq*delthec*delthec
5476         term2=-0.5D0*sig0inv*delthe0*delthe0
5477 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5478 C NaNs in taking the logarithm. We extract the largest exponent which is added
5479 C to the energy (this being the log of the distribution) at the end of energy
5480 C term evaluation for this virtual-bond angle.
5481         if (term1.gt.term2) then
5482           termm=term1
5483           term2=dexp(term2-termm)
5484           term1=1.0d0
5485         else
5486           termm=term2
5487           term1=dexp(term1-termm)
5488           term2=1.0d0
5489         endif
5490 C The ratio between the gamma-independent and gamma-dependent lobes of
5491 C the distribution is a Gaussian function of thet_pred_mean too.
5492         diffak=gthet(2,it)-thet_pred_mean
5493         ratak=diffak/gthet(3,it)**2
5494         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5495 C Let's differentiate it in thet_pred_mean NOW.
5496         aktc=ak*ratak
5497 C Now put together the distribution terms to make complete distribution.
5498         termexp=term1+ak*term2
5499         termpre=sigc+ak*sig0i
5500 C Contribution of the bending energy from this theta is just the -log of
5501 C the sum of the contributions from the two lobes and the pre-exponential
5502 C factor. Simple enough, isn't it?
5503         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5504 C NOW the derivatives!!!
5505 C 6/6/97 Take into account the deformation.
5506         E_theta=(delthec*sigcsq*term1
5507      &       +ak*delthe0*sig0inv*term2)/termexp
5508         E_tc=((sigtc+aktc*sig0i)/termpre
5509      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5510      &       aktc*term2)/termexp)
5511       return
5512       end
5513 c-----------------------------------------------------------------------------
5514       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5515       implicit real*8 (a-h,o-z)
5516       include 'DIMENSIONS'
5517       include 'COMMON.LOCAL'
5518       include 'COMMON.IOUNITS'
5519       common /calcthet/ term1,term2,termm,diffak,ratak,
5520      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5521      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5522       delthec=thetai-thet_pred_mean
5523       delthe0=thetai-theta0i
5524 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5525       t3 = thetai-thet_pred_mean
5526       t6 = t3**2
5527       t9 = term1
5528       t12 = t3*sigcsq
5529       t14 = t12+t6*sigsqtc
5530       t16 = 1.0d0
5531       t21 = thetai-theta0i
5532       t23 = t21**2
5533       t26 = term2
5534       t27 = t21*t26
5535       t32 = termexp
5536       t40 = t32**2
5537       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5538      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5539      & *(-t12*t9-ak*sig0inv*t27)
5540       return
5541       end
5542 #else
5543 C--------------------------------------------------------------------------
5544       subroutine ebend(etheta)
5545 C
5546 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5547 C angles gamma and its derivatives in consecutive thetas and gammas.
5548 C ab initio-derived potentials from
5549 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5550 C
5551       implicit real*8 (a-h,o-z)
5552       include 'DIMENSIONS'
5553       include 'DIMENSIONS.ZSCOPT'
5554       include 'COMMON.LOCAL'
5555       include 'COMMON.GEO'
5556       include 'COMMON.INTERACT'
5557       include 'COMMON.DERIV'
5558       include 'COMMON.VAR'
5559       include 'COMMON.CHAIN'
5560       include 'COMMON.IOUNITS'
5561       include 'COMMON.NAMES'
5562       include 'COMMON.FFIELD'
5563       include 'COMMON.CONTROL'
5564       include 'COMMON.TORCNSTR'
5565       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5566      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5567      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5568      & sinph1ph2(maxdouble,maxdouble)
5569       logical lprn /.false./, lprn1 /.false./
5570       etheta=0.0D0
5571 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5572       do i=ithet_start,ithet_end
5573 C         if (i.eq.2) cycle
5574 C        if (itype(i-1).eq.ntyp1) cycle
5575         if (i.le.2) cycle
5576         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5577      &  .or.itype(i).eq.ntyp1) cycle
5578         if (iabs(itype(i+1)).eq.20) iblock=2
5579         if (iabs(itype(i+1)).ne.20) iblock=1
5580         dethetai=0.0d0
5581         dephii=0.0d0
5582         dephii1=0.0d0
5583         theti2=0.5d0*theta(i)
5584         ityp2=ithetyp((itype(i-1)))
5585         do k=1,nntheterm
5586           coskt(k)=dcos(k*theti2)
5587           sinkt(k)=dsin(k*theti2)
5588         enddo
5589 cu        if (i.eq.3) then
5590 cu          phii=0.0d0
5591 cu          ityp1=nthetyp+1
5592 cu          do k=1,nsingle
5593 cu            cosph1(k)=0.0d0
5594 cu            sinph1(k)=0.0d0
5595 cu          enddo
5596 cu        else
5597         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5598 #ifdef OSF
5599           phii=phi(i)
5600           if (phii.ne.phii) phii=150.0
5601 #else
5602           phii=phi(i)
5603 #endif
5604           ityp1=ithetyp((itype(i-2)))
5605           do k=1,nsingle
5606             cosph1(k)=dcos(k*phii)
5607             sinph1(k)=dsin(k*phii)
5608           enddo
5609         else
5610           phii=0.0d0
5611 c          ityp1=nthetyp+1
5612           do k=1,nsingle
5613             ityp1=ithetyp((itype(i-2)))
5614             cosph1(k)=0.0d0
5615             sinph1(k)=0.0d0
5616           enddo
5617         endif
5618         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5619 #ifdef OSF
5620           phii1=phi(i+1)
5621           if (phii1.ne.phii1) phii1=150.0
5622           phii1=pinorm(phii1)
5623 #else
5624           phii1=phi(i+1)
5625 #endif
5626           ityp3=ithetyp((itype(i)))
5627           do k=1,nsingle
5628             cosph2(k)=dcos(k*phii1)
5629             sinph2(k)=dsin(k*phii1)
5630           enddo
5631         else
5632           phii1=0.0d0
5633 c          ityp3=nthetyp+1
5634           ityp3=ithetyp((itype(i)))
5635           do k=1,nsingle
5636             cosph2(k)=0.0d0
5637             sinph2(k)=0.0d0
5638           enddo
5639         endif
5640 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5641 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5642 c        call flush(iout)
5643         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5644         do k=1,ndouble
5645           do l=1,k-1
5646             ccl=cosph1(l)*cosph2(k-l)
5647             ssl=sinph1(l)*sinph2(k-l)
5648             scl=sinph1(l)*cosph2(k-l)
5649             csl=cosph1(l)*sinph2(k-l)
5650             cosph1ph2(l,k)=ccl-ssl
5651             cosph1ph2(k,l)=ccl+ssl
5652             sinph1ph2(l,k)=scl+csl
5653             sinph1ph2(k,l)=scl-csl
5654           enddo
5655         enddo
5656         if (lprn) then
5657         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5658      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5659         write (iout,*) "coskt and sinkt"
5660         do k=1,nntheterm
5661           write (iout,*) k,coskt(k),sinkt(k)
5662         enddo
5663         endif
5664         do k=1,ntheterm
5665           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5666           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5667      &      *coskt(k)
5668           if (lprn)
5669      &    write (iout,*) "k",k,"
5670      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5671      &     " ethetai",ethetai
5672         enddo
5673         if (lprn) then
5674         write (iout,*) "cosph and sinph"
5675         do k=1,nsingle
5676           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5677         enddo
5678         write (iout,*) "cosph1ph2 and sinph2ph2"
5679         do k=2,ndouble
5680           do l=1,k-1
5681             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5682      &         sinph1ph2(l,k),sinph1ph2(k,l)
5683           enddo
5684         enddo
5685         write(iout,*) "ethetai",ethetai
5686         endif
5687         do m=1,ntheterm2
5688           do k=1,nsingle
5689             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5690      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5691      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5692      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5693             ethetai=ethetai+sinkt(m)*aux
5694             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5695             dephii=dephii+k*sinkt(m)*(
5696      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5697      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5698             dephii1=dephii1+k*sinkt(m)*(
5699      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5700      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5701             if (lprn)
5702      &      write (iout,*) "m",m," k",k," bbthet",
5703      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5704      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5705      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5706      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5707           enddo
5708         enddo
5709         if (lprn)
5710      &  write(iout,*) "ethetai",ethetai
5711         do m=1,ntheterm3
5712           do k=2,ndouble
5713             do l=1,k-1
5714               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5715      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5716      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5717      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5718               ethetai=ethetai+sinkt(m)*aux
5719               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5720               dephii=dephii+l*sinkt(m)*(
5721      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5722      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5723      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5724      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5725               dephii1=dephii1+(k-l)*sinkt(m)*(
5726      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5727      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5728      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5729      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5730               if (lprn) then
5731               write (iout,*) "m",m," k",k," l",l," ffthet",
5732      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5733      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5734      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5735      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5736      &            " ethetai",ethetai
5737               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5738      &            cosph1ph2(k,l)*sinkt(m),
5739      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5740               endif
5741             enddo
5742           enddo
5743         enddo
5744 10      continue
5745         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5746      &   i,theta(i)*rad2deg,phii*rad2deg,
5747      &   phii1*rad2deg,ethetai
5748         etheta=etheta+ethetai
5749         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5750         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5751 c        gloc(nphi+i-2,icg)=wang*dethetai
5752         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5753       enddo
5754       return
5755       end
5756 #endif
5757 #ifdef CRYST_SC
5758 c-----------------------------------------------------------------------------
5759       subroutine esc(escloc)
5760 C Calculate the local energy of a side chain and its derivatives in the
5761 C corresponding virtual-bond valence angles THETA and the spherical angles
5762 C ALPHA and OMEGA.
5763       implicit real*8 (a-h,o-z)
5764       include 'DIMENSIONS'
5765       include 'DIMENSIONS.ZSCOPT'
5766       include 'COMMON.GEO'
5767       include 'COMMON.LOCAL'
5768       include 'COMMON.VAR'
5769       include 'COMMON.INTERACT'
5770       include 'COMMON.DERIV'
5771       include 'COMMON.CHAIN'
5772       include 'COMMON.IOUNITS'
5773       include 'COMMON.NAMES'
5774       include 'COMMON.FFIELD'
5775       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5776      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5777       common /sccalc/ time11,time12,time112,theti,it,nlobit
5778       delta=0.02d0*pi
5779       escloc=0.0D0
5780 C      write (iout,*) 'ESC'
5781       do i=loc_start,loc_end
5782         it=itype(i)
5783         if (it.eq.ntyp1) cycle
5784         if (it.eq.10) goto 1
5785         nlobit=nlob(iabs(it))
5786 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5787 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5788         theti=theta(i+1)-pipol
5789         x(1)=dtan(theti)
5790         x(2)=alph(i)
5791         x(3)=omeg(i)
5792 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5793
5794         if (x(2).gt.pi-delta) then
5795           xtemp(1)=x(1)
5796           xtemp(2)=pi-delta
5797           xtemp(3)=x(3)
5798           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5799           xtemp(2)=pi
5800           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5801           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5802      &        escloci,dersc(2))
5803           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5804      &        ddersc0(1),dersc(1))
5805           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5806      &        ddersc0(3),dersc(3))
5807           xtemp(2)=pi-delta
5808           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5809           xtemp(2)=pi
5810           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5811           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5812      &            dersc0(2),esclocbi,dersc02)
5813           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5814      &            dersc12,dersc01)
5815           call splinthet(x(2),0.5d0*delta,ss,ssd)
5816           dersc0(1)=dersc01
5817           dersc0(2)=dersc02
5818           dersc0(3)=0.0d0
5819           do k=1,3
5820             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5821           enddo
5822           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5823           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5824      &             esclocbi,ss,ssd
5825           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5826 c         escloci=esclocbi
5827 c         write (iout,*) escloci
5828         else if (x(2).lt.delta) then
5829           xtemp(1)=x(1)
5830           xtemp(2)=delta
5831           xtemp(3)=x(3)
5832           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5833           xtemp(2)=0.0d0
5834           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5835           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5836      &        escloci,dersc(2))
5837           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5838      &        ddersc0(1),dersc(1))
5839           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5840      &        ddersc0(3),dersc(3))
5841           xtemp(2)=delta
5842           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5843           xtemp(2)=0.0d0
5844           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5845           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5846      &            dersc0(2),esclocbi,dersc02)
5847           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5848      &            dersc12,dersc01)
5849           dersc0(1)=dersc01
5850           dersc0(2)=dersc02
5851           dersc0(3)=0.0d0
5852           call splinthet(x(2),0.5d0*delta,ss,ssd)
5853           do k=1,3
5854             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5855           enddo
5856           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5857 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5858 c     &             esclocbi,ss,ssd
5859           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5860 C         write (iout,*) 'i=',i, escloci
5861         else
5862           call enesc(x,escloci,dersc,ddummy,.false.)
5863         endif
5864
5865         escloc=escloc+escloci
5866 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5867             write (iout,'(a6,i5,0pf7.3)')
5868      &     'escloc',i,escloci
5869
5870         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5871      &   wscloc*dersc(1)
5872         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5873         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5874     1   continue
5875       enddo
5876       return
5877       end
5878 C---------------------------------------------------------------------------
5879       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5880       implicit real*8 (a-h,o-z)
5881       include 'DIMENSIONS'
5882       include 'COMMON.GEO'
5883       include 'COMMON.LOCAL'
5884       include 'COMMON.IOUNITS'
5885       common /sccalc/ time11,time12,time112,theti,it,nlobit
5886       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5887       double precision contr(maxlob,-1:1)
5888       logical mixed
5889 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5890         escloc_i=0.0D0
5891         do j=1,3
5892           dersc(j)=0.0D0
5893           if (mixed) ddersc(j)=0.0d0
5894         enddo
5895         x3=x(3)
5896
5897 C Because of periodicity of the dependence of the SC energy in omega we have
5898 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5899 C To avoid underflows, first compute & store the exponents.
5900
5901         do iii=-1,1
5902
5903           x(3)=x3+iii*dwapi
5904
5905           do j=1,nlobit
5906             do k=1,3
5907               z(k)=x(k)-censc(k,j,it)
5908             enddo
5909             do k=1,3
5910               Axk=0.0D0
5911               do l=1,3
5912                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5913               enddo
5914               Ax(k,j,iii)=Axk
5915             enddo
5916             expfac=0.0D0
5917             do k=1,3
5918               expfac=expfac+Ax(k,j,iii)*z(k)
5919             enddo
5920             contr(j,iii)=expfac
5921           enddo ! j
5922
5923         enddo ! iii
5924
5925         x(3)=x3
5926 C As in the case of ebend, we want to avoid underflows in exponentiation and
5927 C subsequent NaNs and INFs in energy calculation.
5928 C Find the largest exponent
5929         emin=contr(1,-1)
5930         do iii=-1,1
5931           do j=1,nlobit
5932             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5933           enddo
5934         enddo
5935         emin=0.5D0*emin
5936 cd      print *,'it=',it,' emin=',emin
5937
5938 C Compute the contribution to SC energy and derivatives
5939         do iii=-1,1
5940
5941           do j=1,nlobit
5942             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5943 cd          print *,'j=',j,' expfac=',expfac
5944             escloc_i=escloc_i+expfac
5945             do k=1,3
5946               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5947             enddo
5948             if (mixed) then
5949               do k=1,3,2
5950                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5951      &            +gaussc(k,2,j,it))*expfac
5952               enddo
5953             endif
5954           enddo
5955
5956         enddo ! iii
5957
5958         dersc(1)=dersc(1)/cos(theti)**2
5959         ddersc(1)=ddersc(1)/cos(theti)**2
5960         ddersc(3)=ddersc(3)
5961
5962         escloci=-(dlog(escloc_i)-emin)
5963         do j=1,3
5964           dersc(j)=dersc(j)/escloc_i
5965         enddo
5966         if (mixed) then
5967           do j=1,3,2
5968             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5969           enddo
5970         endif
5971       return
5972       end
5973 C------------------------------------------------------------------------------
5974       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5975       implicit real*8 (a-h,o-z)
5976       include 'DIMENSIONS'
5977       include 'COMMON.GEO'
5978       include 'COMMON.LOCAL'
5979       include 'COMMON.IOUNITS'
5980       common /sccalc/ time11,time12,time112,theti,it,nlobit
5981       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5982       double precision contr(maxlob)
5983       logical mixed
5984
5985       escloc_i=0.0D0
5986
5987       do j=1,3
5988         dersc(j)=0.0D0
5989       enddo
5990
5991       do j=1,nlobit
5992         do k=1,2
5993           z(k)=x(k)-censc(k,j,it)
5994         enddo
5995         z(3)=dwapi
5996         do k=1,3
5997           Axk=0.0D0
5998           do l=1,3
5999             Axk=Axk+gaussc(l,k,j,it)*z(l)
6000           enddo
6001           Ax(k,j)=Axk
6002         enddo
6003         expfac=0.0D0
6004         do k=1,3
6005           expfac=expfac+Ax(k,j)*z(k)
6006         enddo
6007         contr(j)=expfac
6008       enddo ! j
6009
6010 C As in the case of ebend, we want to avoid underflows in exponentiation and
6011 C subsequent NaNs and INFs in energy calculation.
6012 C Find the largest exponent
6013       emin=contr(1)
6014       do j=1,nlobit
6015         if (emin.gt.contr(j)) emin=contr(j)
6016       enddo
6017       emin=0.5D0*emin
6018
6019 C Compute the contribution to SC energy and derivatives
6020
6021       dersc12=0.0d0
6022       do j=1,nlobit
6023         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6024         escloc_i=escloc_i+expfac
6025         do k=1,2
6026           dersc(k)=dersc(k)+Ax(k,j)*expfac
6027         enddo
6028         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6029      &            +gaussc(1,2,j,it))*expfac
6030         dersc(3)=0.0d0
6031       enddo
6032
6033       dersc(1)=dersc(1)/cos(theti)**2
6034       dersc12=dersc12/cos(theti)**2
6035       escloci=-(dlog(escloc_i)-emin)
6036       do j=1,2
6037         dersc(j)=dersc(j)/escloc_i
6038       enddo
6039       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6040       return
6041       end
6042 #else
6043 c----------------------------------------------------------------------------------
6044       subroutine esc(escloc)
6045 C Calculate the local energy of a side chain and its derivatives in the
6046 C corresponding virtual-bond valence angles THETA and the spherical angles
6047 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6048 C added by Urszula Kozlowska. 07/11/2007
6049 C
6050       implicit real*8 (a-h,o-z)
6051       include 'DIMENSIONS'
6052       include 'DIMENSIONS.ZSCOPT'
6053       include 'COMMON.GEO'
6054       include 'COMMON.LOCAL'
6055       include 'COMMON.VAR'
6056       include 'COMMON.SCROT'
6057       include 'COMMON.INTERACT'
6058       include 'COMMON.DERIV'
6059       include 'COMMON.CHAIN'
6060       include 'COMMON.IOUNITS'
6061       include 'COMMON.NAMES'
6062       include 'COMMON.FFIELD'
6063       include 'COMMON.CONTROL'
6064       include 'COMMON.VECTORS'
6065       double precision x_prime(3),y_prime(3),z_prime(3)
6066      &    , sumene,dsc_i,dp2_i,x(65),
6067      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6068      &    de_dxx,de_dyy,de_dzz,de_dt
6069       double precision s1_t,s1_6_t,s2_t,s2_6_t
6070       double precision
6071      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6072      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6073      & dt_dCi(3),dt_dCi1(3)
6074       common /sccalc/ time11,time12,time112,theti,it,nlobit
6075       delta=0.02d0*pi
6076       escloc=0.0D0
6077       do i=loc_start,loc_end
6078         if (itype(i).eq.ntyp1) cycle
6079         costtab(i+1) =dcos(theta(i+1))
6080         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6081         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6082         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6083         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6084         cosfac=dsqrt(cosfac2)
6085         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6086         sinfac=dsqrt(sinfac2)
6087         it=iabs(itype(i))
6088         if (it.eq.10) goto 1
6089 c
6090 C  Compute the axes of tghe local cartesian coordinates system; store in
6091 c   x_prime, y_prime and z_prime
6092 c
6093         do j=1,3
6094           x_prime(j) = 0.00
6095           y_prime(j) = 0.00
6096           z_prime(j) = 0.00
6097         enddo
6098 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6099 C     &   dc_norm(3,i+nres)
6100         do j = 1,3
6101           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6102           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6103         enddo
6104         do j = 1,3
6105           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6106         enddo
6107 c       write (2,*) "i",i
6108 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6109 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6110 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6111 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6112 c      & " xy",scalar(x_prime(1),y_prime(1)),
6113 c      & " xz",scalar(x_prime(1),z_prime(1)),
6114 c      & " yy",scalar(y_prime(1),y_prime(1)),
6115 c      & " yz",scalar(y_prime(1),z_prime(1)),
6116 c      & " zz",scalar(z_prime(1),z_prime(1))
6117 c
6118 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6119 C to local coordinate system. Store in xx, yy, zz.
6120 c
6121         xx=0.0d0
6122         yy=0.0d0
6123         zz=0.0d0
6124         do j = 1,3
6125           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6126           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6127           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6128         enddo
6129
6130         xxtab(i)=xx
6131         yytab(i)=yy
6132         zztab(i)=zz
6133 C
6134 C Compute the energy of the ith side cbain
6135 C
6136 c        write (2,*) "xx",xx," yy",yy," zz",zz
6137         it=iabs(itype(i))
6138         do j = 1,65
6139           x(j) = sc_parmin(j,it)
6140         enddo
6141 #ifdef CHECK_COORD
6142 Cc diagnostics - remove later
6143         xx1 = dcos(alph(2))
6144         yy1 = dsin(alph(2))*dcos(omeg(2))
6145         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6146         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6147      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6148      &    xx1,yy1,zz1
6149 C,"  --- ", xx_w,yy_w,zz_w
6150 c end diagnostics
6151 #endif
6152         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6153      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6154      &   + x(10)*yy*zz
6155         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6156      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6157      & + x(20)*yy*zz
6158         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6159      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6160      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6161      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6162      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6163      &  +x(40)*xx*yy*zz
6164         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6165      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6166      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6167      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6168      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6169      &  +x(60)*xx*yy*zz
6170         dsc_i   = 0.743d0+x(61)
6171         dp2_i   = 1.9d0+x(62)
6172         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6173      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6174         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6175      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6176         s1=(1+x(63))/(0.1d0 + dscp1)
6177         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6178         s2=(1+x(65))/(0.1d0 + dscp2)
6179         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6180         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6181      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6182 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6183 c     &   sumene4,
6184 c     &   dscp1,dscp2,sumene
6185 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6186         escloc = escloc + sumene
6187 c        write (2,*) "escloc",escloc
6188 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6189 c     &  zz,xx,yy
6190         if (.not. calc_grad) goto 1
6191 #ifdef DEBUG
6192 C
6193 C This section to check the numerical derivatives of the energy of ith side
6194 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6195 C #define DEBUG in the code to turn it on.
6196 C
6197         write (2,*) "sumene               =",sumene
6198         aincr=1.0d-7
6199         xxsave=xx
6200         xx=xx+aincr
6201         write (2,*) xx,yy,zz
6202         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6203         de_dxx_num=(sumenep-sumene)/aincr
6204         xx=xxsave
6205         write (2,*) "xx+ sumene from enesc=",sumenep
6206         yysave=yy
6207         yy=yy+aincr
6208         write (2,*) xx,yy,zz
6209         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6210         de_dyy_num=(sumenep-sumene)/aincr
6211         yy=yysave
6212         write (2,*) "yy+ sumene from enesc=",sumenep
6213         zzsave=zz
6214         zz=zz+aincr
6215         write (2,*) xx,yy,zz
6216         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6217         de_dzz_num=(sumenep-sumene)/aincr
6218         zz=zzsave
6219         write (2,*) "zz+ sumene from enesc=",sumenep
6220         costsave=cost2tab(i+1)
6221         sintsave=sint2tab(i+1)
6222         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6223         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6224         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6225         de_dt_num=(sumenep-sumene)/aincr
6226         write (2,*) " t+ sumene from enesc=",sumenep
6227         cost2tab(i+1)=costsave
6228         sint2tab(i+1)=sintsave
6229 C End of diagnostics section.
6230 #endif
6231 C
6232 C Compute the gradient of esc
6233 C
6234         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6235         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6236         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6237         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6238         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6239         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6240         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6241         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6242         pom1=(sumene3*sint2tab(i+1)+sumene1)
6243      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6244         pom2=(sumene4*cost2tab(i+1)+sumene2)
6245      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6246         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6247         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6248      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6249      &  +x(40)*yy*zz
6250         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6251         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6252      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6253      &  +x(60)*yy*zz
6254         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6255      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6256      &        +(pom1+pom2)*pom_dx
6257 #ifdef DEBUG
6258         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6259 #endif
6260 C
6261         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6262         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6263      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6264      &  +x(40)*xx*zz
6265         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6266         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6267      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6268      &  +x(59)*zz**2 +x(60)*xx*zz
6269         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6270      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6271      &        +(pom1-pom2)*pom_dy
6272 #ifdef DEBUG
6273         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6274 #endif
6275 C
6276         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6277      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6278      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6279      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6280      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6281      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6282      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6283      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6284 #ifdef DEBUG
6285         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6286 #endif
6287 C
6288         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6289      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6290      &  +pom1*pom_dt1+pom2*pom_dt2
6291 #ifdef DEBUG
6292         write(2,*), "de_dt = ", de_dt,de_dt_num
6293 #endif
6294 c
6295 C
6296        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6297        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6298        cosfac2xx=cosfac2*xx
6299        sinfac2yy=sinfac2*yy
6300        do k = 1,3
6301          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6302      &      vbld_inv(i+1)
6303          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6304      &      vbld_inv(i)
6305          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6306          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6307 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6308 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6309 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6310 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6311          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6312          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6313          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6314          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6315          dZZ_Ci1(k)=0.0d0
6316          dZZ_Ci(k)=0.0d0
6317          do j=1,3
6318            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6319      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6320            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6321      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6322          enddo
6323
6324          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6325          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6326          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6327 c
6328          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6329          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6330        enddo
6331
6332        do k=1,3
6333          dXX_Ctab(k,i)=dXX_Ci(k)
6334          dXX_C1tab(k,i)=dXX_Ci1(k)
6335          dYY_Ctab(k,i)=dYY_Ci(k)
6336          dYY_C1tab(k,i)=dYY_Ci1(k)
6337          dZZ_Ctab(k,i)=dZZ_Ci(k)
6338          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6339          dXX_XYZtab(k,i)=dXX_XYZ(k)
6340          dYY_XYZtab(k,i)=dYY_XYZ(k)
6341          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6342        enddo
6343
6344        do k = 1,3
6345 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6346 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6347 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6348 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6349 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6350 c     &    dt_dci(k)
6351 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6352 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6353          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6354      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6355          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6356      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6357          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6358      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6359        enddo
6360 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6361 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6362
6363 C to check gradient call subroutine check_grad
6364
6365     1 continue
6366       enddo
6367       return
6368       end
6369 #endif
6370 c------------------------------------------------------------------------------
6371       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6372 C
6373 C This procedure calculates two-body contact function g(rij) and its derivative:
6374 C
6375 C           eps0ij                                     !       x < -1
6376 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6377 C            0                                         !       x > 1
6378 C
6379 C where x=(rij-r0ij)/delta
6380 C
6381 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6382 C
6383       implicit none
6384       double precision rij,r0ij,eps0ij,fcont,fprimcont
6385       double precision x,x2,x4,delta
6386 c     delta=0.02D0*r0ij
6387 c      delta=0.2D0*r0ij
6388       x=(rij-r0ij)/delta
6389       if (x.lt.-1.0D0) then
6390         fcont=eps0ij
6391         fprimcont=0.0D0
6392       else if (x.le.1.0D0) then
6393         x2=x*x
6394         x4=x2*x2
6395         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6396         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6397       else
6398         fcont=0.0D0
6399         fprimcont=0.0D0
6400       endif
6401       return
6402       end
6403 c------------------------------------------------------------------------------
6404       subroutine splinthet(theti,delta,ss,ssder)
6405       implicit real*8 (a-h,o-z)
6406       include 'DIMENSIONS'
6407       include 'DIMENSIONS.ZSCOPT'
6408       include 'COMMON.VAR'
6409       include 'COMMON.GEO'
6410       thetup=pi-delta
6411       thetlow=delta
6412       if (theti.gt.pipol) then
6413         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6414       else
6415         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6416         ssder=-ssder
6417       endif
6418       return
6419       end
6420 c------------------------------------------------------------------------------
6421       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6422       implicit none
6423       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6424       double precision ksi,ksi2,ksi3,a1,a2,a3
6425       a1=fprim0*delta/(f1-f0)
6426       a2=3.0d0-2.0d0*a1
6427       a3=a1-2.0d0
6428       ksi=(x-x0)/delta
6429       ksi2=ksi*ksi
6430       ksi3=ksi2*ksi
6431       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6432       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6433       return
6434       end
6435 c------------------------------------------------------------------------------
6436       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6437       implicit none
6438       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6439       double precision ksi,ksi2,ksi3,a1,a2,a3
6440       ksi=(x-x0)/delta
6441       ksi2=ksi*ksi
6442       ksi3=ksi2*ksi
6443       a1=fprim0x*delta
6444       a2=3*(f1x-f0x)-2*fprim0x*delta
6445       a3=fprim0x*delta-2*(f1x-f0x)
6446       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6447       return
6448       end
6449 C-----------------------------------------------------------------------------
6450 #ifdef CRYST_TOR
6451 C-----------------------------------------------------------------------------
6452       subroutine etor(etors,fact)
6453       implicit real*8 (a-h,o-z)
6454       include 'DIMENSIONS'
6455       include 'DIMENSIONS.ZSCOPT'
6456       include 'COMMON.VAR'
6457       include 'COMMON.GEO'
6458       include 'COMMON.LOCAL'
6459       include 'COMMON.TORSION'
6460       include 'COMMON.INTERACT'
6461       include 'COMMON.DERIV'
6462       include 'COMMON.CHAIN'
6463       include 'COMMON.NAMES'
6464       include 'COMMON.IOUNITS'
6465       include 'COMMON.FFIELD'
6466       include 'COMMON.TORCNSTR'
6467       logical lprn
6468 C Set lprn=.true. for debugging
6469       lprn=.false.
6470 c      lprn=.true.
6471       etors=0.0D0
6472       do i=iphi_start,iphi_end
6473         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6474      &      .or. itype(i).eq.ntyp1) cycle
6475         itori=itortyp(itype(i-2))
6476         itori1=itortyp(itype(i-1))
6477         phii=phi(i)
6478         gloci=0.0D0
6479 C Proline-Proline pair is a special case...
6480         if (itori.eq.3 .and. itori1.eq.3) then
6481           if (phii.gt.-dwapi3) then
6482             cosphi=dcos(3*phii)
6483             fac=1.0D0/(1.0D0-cosphi)
6484             etorsi=v1(1,3,3)*fac
6485             etorsi=etorsi+etorsi
6486             etors=etors+etorsi-v1(1,3,3)
6487             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6488           endif
6489           do j=1,3
6490             v1ij=v1(j+1,itori,itori1)
6491             v2ij=v2(j+1,itori,itori1)
6492             cosphi=dcos(j*phii)
6493             sinphi=dsin(j*phii)
6494             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6495             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6496           enddo
6497         else
6498           do j=1,nterm_old
6499             v1ij=v1(j,itori,itori1)
6500             v2ij=v2(j,itori,itori1)
6501             cosphi=dcos(j*phii)
6502             sinphi=dsin(j*phii)
6503             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6504             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6505           enddo
6506         endif
6507         if (lprn)
6508      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6509      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6510      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6511         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6512 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6513       enddo
6514       return
6515       end
6516 c------------------------------------------------------------------------------
6517 #else
6518       subroutine etor(etors,fact)
6519       implicit real*8 (a-h,o-z)
6520       include 'DIMENSIONS'
6521       include 'DIMENSIONS.ZSCOPT'
6522       include 'COMMON.VAR'
6523       include 'COMMON.GEO'
6524       include 'COMMON.LOCAL'
6525       include 'COMMON.TORSION'
6526       include 'COMMON.INTERACT'
6527       include 'COMMON.DERIV'
6528       include 'COMMON.CHAIN'
6529       include 'COMMON.NAMES'
6530       include 'COMMON.IOUNITS'
6531       include 'COMMON.FFIELD'
6532       include 'COMMON.TORCNSTR'
6533       logical lprn
6534 C Set lprn=.true. for debugging
6535       lprn=.false.
6536 c      lprn=.true.
6537       etors=0.0D0
6538       do i=iphi_start,iphi_end
6539         if (i.le.2) cycle
6540         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6541      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6542 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6543 C     &       .or. itype(i).eq.ntyp1) cycle
6544         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6545          if (iabs(itype(i)).eq.20) then
6546          iblock=2
6547          else
6548          iblock=1
6549          endif
6550         itori=itortyp(itype(i-2))
6551         itori1=itortyp(itype(i-1))
6552         phii=phi(i)
6553         gloci=0.0D0
6554 C Regular cosine and sine terms
6555         do j=1,nterm(itori,itori1,iblock)
6556           v1ij=v1(j,itori,itori1,iblock)
6557           v2ij=v2(j,itori,itori1,iblock)
6558           cosphi=dcos(j*phii)
6559           sinphi=dsin(j*phii)
6560           etors=etors+v1ij*cosphi+v2ij*sinphi
6561           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6562         enddo
6563 C Lorentz terms
6564 C                         v1
6565 C  E = SUM ----------------------------------- - v1
6566 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6567 C
6568         cosphi=dcos(0.5d0*phii)
6569         sinphi=dsin(0.5d0*phii)
6570         do j=1,nlor(itori,itori1,iblock)
6571           vl1ij=vlor1(j,itori,itori1)
6572           vl2ij=vlor2(j,itori,itori1)
6573           vl3ij=vlor3(j,itori,itori1)
6574           pom=vl2ij*cosphi+vl3ij*sinphi
6575           pom1=1.0d0/(pom*pom+1.0d0)
6576           etors=etors+vl1ij*pom1
6577 c          if (energy_dec) etors_ii=etors_ii+
6578 c     &                vl1ij*pom1
6579           pom=-pom*pom1*pom1
6580           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6581         enddo
6582 C Subtract the constant term
6583         etors=etors-v0(itori,itori1,iblock)
6584         if (lprn)
6585      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6586      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6587      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6588         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6589 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6590  1215   continue
6591       enddo
6592       return
6593       end
6594 c----------------------------------------------------------------------------
6595       subroutine etor_d(etors_d,fact2)
6596 C 6/23/01 Compute double torsional energy
6597       implicit real*8 (a-h,o-z)
6598       include 'DIMENSIONS'
6599       include 'DIMENSIONS.ZSCOPT'
6600       include 'COMMON.VAR'
6601       include 'COMMON.GEO'
6602       include 'COMMON.LOCAL'
6603       include 'COMMON.TORSION'
6604       include 'COMMON.INTERACT'
6605       include 'COMMON.DERIV'
6606       include 'COMMON.CHAIN'
6607       include 'COMMON.NAMES'
6608       include 'COMMON.IOUNITS'
6609       include 'COMMON.FFIELD'
6610       include 'COMMON.TORCNSTR'
6611       logical lprn
6612 C Set lprn=.true. for debugging
6613       lprn=.false.
6614 c     lprn=.true.
6615       etors_d=0.0D0
6616       do i=iphi_start,iphi_end-1
6617         if (i.le.3) cycle
6618 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6619 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6620          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6621      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6622      &  (itype(i+1).eq.ntyp1)) cycle
6623         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6624      &     goto 1215
6625         itori=itortyp(itype(i-2))
6626         itori1=itortyp(itype(i-1))
6627         itori2=itortyp(itype(i))
6628         phii=phi(i)
6629         phii1=phi(i+1)
6630         gloci1=0.0D0
6631         gloci2=0.0D0
6632         iblock=1
6633         if (iabs(itype(i+1)).eq.20) iblock=2
6634 C Regular cosine and sine terms
6635         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6636           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6637           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6638           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6639           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6640           cosphi1=dcos(j*phii)
6641           sinphi1=dsin(j*phii)
6642           cosphi2=dcos(j*phii1)
6643           sinphi2=dsin(j*phii1)
6644           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6645      &     v2cij*cosphi2+v2sij*sinphi2
6646           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6647           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6648         enddo
6649         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6650           do l=1,k-1
6651             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6652             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6653             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6654             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6655             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6656             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6657             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6658             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6659             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6660      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6661             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6662      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6663             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6664      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6665           enddo
6666         enddo
6667         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6668         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6669  1215   continue
6670       enddo
6671       return
6672       end
6673 #endif
6674 c---------------------------------------------------------------------------
6675 C The rigorous attempt to derive energy function
6676       subroutine etor_kcc(etors,fact)
6677       implicit real*8 (a-h,o-z)
6678       include 'DIMENSIONS'
6679       include 'DIMENSIONS.ZSCOPT'
6680       include 'COMMON.VAR'
6681       include 'COMMON.GEO'
6682       include 'COMMON.LOCAL'
6683       include 'COMMON.TORSION'
6684       include 'COMMON.INTERACT'
6685       include 'COMMON.DERIV'
6686       include 'COMMON.CHAIN'
6687       include 'COMMON.NAMES'
6688       include 'COMMON.IOUNITS'
6689       include 'COMMON.FFIELD'
6690       include 'COMMON.TORCNSTR'
6691       include 'COMMON.CONTROL'
6692       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6693       logical lprn
6694 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6695 C Set lprn=.true. for debugging
6696       lprn=energy_dec
6697 c     lprn=.true.
6698 C      print *,"wchodze kcc"
6699       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6700       etors=0.0D0
6701       do i=iphi_start,iphi_end
6702 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6703 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6704 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6705 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6706         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6707      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6708         itori=itortyp(itype(i-2))
6709         itori1=itortyp(itype(i-1))
6710         phii=phi(i)
6711         glocig=0.0D0
6712         glocit1=0.0d0
6713         glocit2=0.0d0
6714 C to avoid multiple devision by 2
6715 c        theti22=0.5d0*theta(i)
6716 C theta 12 is the theta_1 /2
6717 C theta 22 is theta_2 /2
6718 c        theti12=0.5d0*theta(i-1)
6719 C and appropriate sinus function
6720         sinthet1=dsin(theta(i-1))
6721         sinthet2=dsin(theta(i))
6722         costhet1=dcos(theta(i-1))
6723         costhet2=dcos(theta(i))
6724 C to speed up lets store its mutliplication
6725         sint1t2=sinthet2*sinthet1
6726         sint1t2n=1.0d0
6727 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6728 C +d_n*sin(n*gamma)) *
6729 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6730 C we have two sum 1) Non-Chebyshev which is with n and gamma
6731         nval=nterm_kcc_Tb(itori,itori1)
6732         c1(0)=0.0d0
6733         c2(0)=0.0d0
6734         c1(1)=1.0d0
6735         c2(1)=1.0d0
6736         do j=2,nval
6737           c1(j)=c1(j-1)*costhet1
6738           c2(j)=c2(j-1)*costhet2
6739         enddo
6740         etori=0.0d0
6741         do j=1,nterm_kcc(itori,itori1)
6742           cosphi=dcos(j*phii)
6743           sinphi=dsin(j*phii)
6744           sint1t2n1=sint1t2n
6745           sint1t2n=sint1t2n*sint1t2
6746           sumvalc=0.0d0
6747           gradvalct1=0.0d0
6748           gradvalct2=0.0d0
6749           do k=1,nval
6750             do l=1,nval
6751               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6752               gradvalct1=gradvalct1+
6753      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6754               gradvalct2=gradvalct2+
6755      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6756             enddo
6757           enddo
6758           gradvalct1=-gradvalct1*sinthet1
6759           gradvalct2=-gradvalct2*sinthet2
6760           sumvals=0.0d0
6761           gradvalst1=0.0d0
6762           gradvalst2=0.0d0
6763           do k=1,nval
6764             do l=1,nval
6765               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6766               gradvalst1=gradvalst1+
6767      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6768               gradvalst2=gradvalst2+
6769      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6770             enddo
6771           enddo
6772           gradvalst1=-gradvalst1*sinthet1
6773           gradvalst2=-gradvalst2*sinthet2
6774           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6775 C glocig is the gradient local i site in gamma
6776           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6777 C now gradient over theta_1
6778           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6779      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6780           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6781      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6782         enddo ! j
6783         etors=etors+etori
6784 C derivative over gamma
6785         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6786 C derivative over theta1
6787         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6788 C now derivative over theta2
6789         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6790         if (lprn) then
6791           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6792      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6793           write (iout,*) "c1",(c1(k),k=0,nval),
6794      &    " c2",(c2(k),k=0,nval)
6795           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6796         endif
6797       enddo
6798       return
6799       end
6800 c---------------------------------------------------------------------------------------------
6801       subroutine etor_constr(edihcnstr)
6802       implicit real*8 (a-h,o-z)
6803       include 'DIMENSIONS'
6804       include 'DIMENSIONS.ZSCOPT'
6805       include 'COMMON.VAR'
6806       include 'COMMON.GEO'
6807       include 'COMMON.LOCAL'
6808       include 'COMMON.TORSION'
6809       include 'COMMON.INTERACT'
6810       include 'COMMON.DERIV'
6811       include 'COMMON.CHAIN'
6812       include 'COMMON.NAMES'
6813       include 'COMMON.IOUNITS'
6814       include 'COMMON.FFIELD'
6815       include 'COMMON.TORCNSTR'
6816       include 'COMMON.CONTROL'
6817 ! 6/20/98 - dihedral angle constraints
6818       edihcnstr=0.0d0
6819 c      do i=1,ndih_constr
6820 c      write (iout,*) "idihconstr_start",idihconstr_start,
6821 c     &  " idihconstr_end",idihconstr_end
6822
6823       if (raw_psipred) then
6824         do i=idihconstr_start,idihconstr_end
6825           itori=idih_constr(i)
6826           phii=phi(itori)
6827           gaudih_i=vpsipred(1,i)
6828           gauder_i=0.0d0
6829           do j=1,2
6830             s = sdihed(j,i)
6831             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6832             dexpcos_i=dexp(-cos_i*cos_i)
6833             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6834             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6835      &            *cos_i*dexpcos_i/s**2
6836           enddo
6837           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6838           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6839           if (energy_dec)
6840      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6841      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6842      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6843      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6844      &     -wdihc*dlog(gaudih_i)
6845         enddo
6846       else
6847
6848       do i=idihconstr_start,idihconstr_end
6849         itori=idih_constr(i)
6850         phii=phi(itori)
6851         difi=pinorm(phii-phi0(i))
6852         if (difi.gt.drange(i)) then
6853           difi=difi-drange(i)
6854           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6855           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6856         else if (difi.lt.-drange(i)) then
6857           difi=difi+drange(i)
6858           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6859           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6860         else
6861           difi=0.0
6862         endif
6863       enddo
6864
6865       endif
6866
6867 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6868       return
6869       end
6870 c----------------------------------------------------------------------------
6871 C The rigorous attempt to derive energy function
6872       subroutine ebend_kcc(etheta)
6873
6874       implicit real*8 (a-h,o-z)
6875       include 'DIMENSIONS'
6876       include 'DIMENSIONS.ZSCOPT'
6877       include 'COMMON.VAR'
6878       include 'COMMON.GEO'
6879       include 'COMMON.LOCAL'
6880       include 'COMMON.TORSION'
6881       include 'COMMON.INTERACT'
6882       include 'COMMON.DERIV'
6883       include 'COMMON.CHAIN'
6884       include 'COMMON.NAMES'
6885       include 'COMMON.IOUNITS'
6886       include 'COMMON.FFIELD'
6887       include 'COMMON.TORCNSTR'
6888       include 'COMMON.CONTROL'
6889       logical lprn
6890       double precision thybt1(maxang_kcc)
6891 C Set lprn=.true. for debugging
6892       lprn=energy_dec
6893 c     lprn=.true.
6894 C      print *,"wchodze kcc"
6895       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6896       etheta=0.0D0
6897       do i=ithet_start,ithet_end
6898 c        print *,i,itype(i-1),itype(i),itype(i-2)
6899         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6900      &  .or.itype(i).eq.ntyp1) cycle
6901         iti=iabs(itortyp(itype(i-1)))
6902         sinthet=dsin(theta(i))
6903         costhet=dcos(theta(i))
6904         do j=1,nbend_kcc_Tb(iti)
6905           thybt1(j)=v1bend_chyb(j,iti)
6906         enddo
6907         sumth1thyb=v1bend_chyb(0,iti)+
6908      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6909         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6910      &    sumth1thyb
6911         ihelp=nbend_kcc_Tb(iti)-1
6912         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6913         etheta=etheta+sumth1thyb
6914 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6915         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6916       enddo
6917       return
6918       end
6919 c-------------------------------------------------------------------------------------
6920       subroutine etheta_constr(ethetacnstr)
6921
6922       implicit real*8 (a-h,o-z)
6923       include 'DIMENSIONS'
6924       include 'DIMENSIONS.ZSCOPT'
6925       include 'COMMON.VAR'
6926       include 'COMMON.GEO'
6927       include 'COMMON.LOCAL'
6928       include 'COMMON.TORSION'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.DERIV'
6931       include 'COMMON.CHAIN'
6932       include 'COMMON.NAMES'
6933       include 'COMMON.IOUNITS'
6934       include 'COMMON.FFIELD'
6935       include 'COMMON.TORCNSTR'
6936       include 'COMMON.CONTROL'
6937       ethetacnstr=0.0d0
6938 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6939       do i=ithetaconstr_start,ithetaconstr_end
6940         itheta=itheta_constr(i)
6941         thetiii=theta(itheta)
6942         difi=pinorm(thetiii-theta_constr0(i))
6943         if (difi.gt.theta_drange(i)) then
6944           difi=difi-theta_drange(i)
6945           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6946           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6947      &    +for_thet_constr(i)*difi**3
6948         else if (difi.lt.-drange(i)) then
6949           difi=difi+drange(i)
6950           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6951           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6952      &    +for_thet_constr(i)*difi**3
6953         else
6954           difi=0.0
6955         endif
6956        if (energy_dec) then
6957         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6958      &    i,itheta,rad2deg*thetiii,
6959      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6960      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6961      &    gloc(itheta+nphi-2,icg)
6962         endif
6963       enddo
6964       return
6965       end
6966 c------------------------------------------------------------------------------
6967 c------------------------------------------------------------------------------
6968       subroutine eback_sc_corr(esccor)
6969 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6970 c        conformational states; temporarily implemented as differences
6971 c        between UNRES torsional potentials (dependent on three types of
6972 c        residues) and the torsional potentials dependent on all 20 types
6973 c        of residues computed from AM1 energy surfaces of terminally-blocked
6974 c        amino-acid residues.
6975       implicit real*8 (a-h,o-z)
6976       include 'DIMENSIONS'
6977       include 'DIMENSIONS.ZSCOPT'
6978       include 'COMMON.VAR'
6979       include 'COMMON.GEO'
6980       include 'COMMON.LOCAL'
6981       include 'COMMON.TORSION'
6982       include 'COMMON.SCCOR'
6983       include 'COMMON.INTERACT'
6984       include 'COMMON.DERIV'
6985       include 'COMMON.CHAIN'
6986       include 'COMMON.NAMES'
6987       include 'COMMON.IOUNITS'
6988       include 'COMMON.FFIELD'
6989       include 'COMMON.CONTROL'
6990       logical lprn
6991 C Set lprn=.true. for debugging
6992       lprn=.false.
6993 c      lprn=.true.
6994 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6995       esccor=0.0D0
6996       do i=itau_start,itau_end
6997         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6998         esccor_ii=0.0D0
6999         isccori=isccortyp(itype(i-2))
7000         isccori1=isccortyp(itype(i-1))
7001         phii=phi(i)
7002         do intertyp=1,3 !intertyp
7003 cc Added 09 May 2012 (Adasko)
7004 cc  Intertyp means interaction type of backbone mainchain correlation:
7005 c   1 = SC...Ca...Ca...Ca
7006 c   2 = Ca...Ca...Ca...SC
7007 c   3 = SC...Ca...Ca...SCi
7008         gloci=0.0D0
7009         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7010      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7011      &      (itype(i-1).eq.ntyp1)))
7012      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7013      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7014      &     .or.(itype(i).eq.ntyp1)))
7015      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7016      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7017      &      (itype(i-3).eq.ntyp1)))) cycle
7018         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7019         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7020      & cycle
7021        do j=1,nterm_sccor(isccori,isccori1)
7022           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7023           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7024           cosphi=dcos(j*tauangle(intertyp,i))
7025           sinphi=dsin(j*tauangle(intertyp,i))
7026            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7027            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7028          enddo
7029 C      write (iout,*)"EBACK_SC_COR",esccor,i
7030 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7031 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7032 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7033         if (lprn)
7034      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7035      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7036      &  (v1sccor(j,1,itori,itori1),j=1,6)
7037      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7038 c        gsccor_loc(i-3)=gloci
7039        enddo !intertyp
7040       enddo
7041       return
7042       end
7043 #ifdef FOURBODY
7044 c------------------------------------------------------------------------------
7045       subroutine multibody(ecorr)
7046 C This subroutine calculates multi-body contributions to energy following
7047 C the idea of Skolnick et al. If side chains I and J make a contact and
7048 C at the same time side chains I+1 and J+1 make a contact, an extra
7049 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7050       implicit real*8 (a-h,o-z)
7051       include 'DIMENSIONS'
7052       include 'COMMON.IOUNITS'
7053       include 'COMMON.DERIV'
7054       include 'COMMON.INTERACT'
7055       include 'COMMON.CONTACTS'
7056       include 'COMMON.CONTMAT'
7057       include 'COMMON.CORRMAT'
7058       double precision gx(3),gx1(3)
7059       logical lprn
7060
7061 C Set lprn=.true. for debugging
7062       lprn=.false.
7063
7064       if (lprn) then
7065         write (iout,'(a)') 'Contact function values:'
7066         do i=nnt,nct-2
7067           write (iout,'(i2,20(1x,i2,f10.5))')
7068      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7069         enddo
7070       endif
7071       ecorr=0.0D0
7072       do i=nnt,nct
7073         do j=1,3
7074           gradcorr(j,i)=0.0D0
7075           gradxorr(j,i)=0.0D0
7076         enddo
7077       enddo
7078       do i=nnt,nct-2
7079
7080         DO ISHIFT = 3,4
7081
7082         i1=i+ishift
7083         num_conti=num_cont(i)
7084         num_conti1=num_cont(i1)
7085         do jj=1,num_conti
7086           j=jcont(jj,i)
7087           do kk=1,num_conti1
7088             j1=jcont(kk,i1)
7089             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7090 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7091 cd   &                   ' ishift=',ishift
7092 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7093 C The system gains extra energy.
7094               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7095             endif   ! j1==j+-ishift
7096           enddo     ! kk
7097         enddo       ! jj
7098
7099         ENDDO ! ISHIFT
7100
7101       enddo         ! i
7102       return
7103       end
7104 c------------------------------------------------------------------------------
7105       double precision function esccorr(i,j,k,l,jj,kk)
7106       implicit real*8 (a-h,o-z)
7107       include 'DIMENSIONS'
7108       include 'COMMON.IOUNITS'
7109       include 'COMMON.DERIV'
7110       include 'COMMON.INTERACT'
7111       include 'COMMON.CONTACTS'
7112       include 'COMMON.CONTMAT'
7113       include 'COMMON.CORRMAT'
7114       double precision gx(3),gx1(3)
7115       logical lprn
7116       lprn=.false.
7117       eij=facont(jj,i)
7118       ekl=facont(kk,k)
7119 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7120 C Calculate the multi-body contribution to energy.
7121 C Calculate multi-body contributions to the gradient.
7122 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7123 cd   & k,l,(gacont(m,kk,k),m=1,3)
7124       do m=1,3
7125         gx(m) =ekl*gacont(m,jj,i)
7126         gx1(m)=eij*gacont(m,kk,k)
7127         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7128         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7129         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7130         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7131       enddo
7132       do m=i,j-1
7133         do ll=1,3
7134           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7135         enddo
7136       enddo
7137       do m=k,l-1
7138         do ll=1,3
7139           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7140         enddo
7141       enddo
7142       esccorr=-eij*ekl
7143       return
7144       end
7145 c------------------------------------------------------------------------------
7146       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7147 C This subroutine calculates multi-body contributions to hydrogen-bonding
7148       implicit real*8 (a-h,o-z)
7149       include 'DIMENSIONS'
7150       include 'DIMENSIONS.ZSCOPT'
7151       include 'COMMON.IOUNITS'
7152       include 'COMMON.FFIELD'
7153       include 'COMMON.DERIV'
7154       include 'COMMON.INTERACT'
7155       include 'COMMON.CONTACTS'
7156       include 'COMMON.CONTMAT'
7157       include 'COMMON.CORRMAT'
7158       double precision gx(3),gx1(3)
7159       logical lprn,ldone
7160
7161 C Set lprn=.true. for debugging
7162       lprn=.false.
7163       if (lprn) then
7164         write (iout,'(a)') 'Contact function values:'
7165         do i=nnt,nct-2
7166           write (iout,'(2i3,50(1x,i2,f5.2))')
7167      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7168      &    j=1,num_cont_hb(i))
7169         enddo
7170       endif
7171       ecorr=0.0D0
7172 C Remove the loop below after debugging !!!
7173       do i=nnt,nct
7174         do j=1,3
7175           gradcorr(j,i)=0.0D0
7176           gradxorr(j,i)=0.0D0
7177         enddo
7178       enddo
7179 C Calculate the local-electrostatic correlation terms
7180       do i=iatel_s,iatel_e+1
7181         i1=i+1
7182         num_conti=num_cont_hb(i)
7183         num_conti1=num_cont_hb(i+1)
7184         do jj=1,num_conti
7185           j=jcont_hb(jj,i)
7186           do kk=1,num_conti1
7187             j1=jcont_hb(kk,i1)
7188 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7189 c     &         ' jj=',jj,' kk=',kk
7190             if (j1.eq.j+1 .or. j1.eq.j-1) then
7191 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7192 C The system gains extra energy.
7193               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7194               n_corr=n_corr+1
7195             else if (j1.eq.j) then
7196 C Contacts I-J and I-(J+1) occur simultaneously.
7197 C The system loses extra energy.
7198 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7199             endif
7200           enddo ! kk
7201           do kk=1,num_conti
7202             j1=jcont_hb(kk,i)
7203 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7204 c    &         ' jj=',jj,' kk=',kk
7205             if (j1.eq.j+1) then
7206 C Contacts I-J and (I+1)-J occur simultaneously.
7207 C The system loses extra energy.
7208 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7209             endif ! j1==j+1
7210           enddo ! kk
7211         enddo ! jj
7212       enddo ! i
7213       return
7214       end
7215 c------------------------------------------------------------------------------
7216       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7217      &  n_corr1)
7218 C This subroutine calculates multi-body contributions to hydrogen-bonding
7219       implicit real*8 (a-h,o-z)
7220       include 'DIMENSIONS'
7221       include 'DIMENSIONS.ZSCOPT'
7222       include 'COMMON.IOUNITS'
7223 #ifdef MPI
7224       include "mpif.h"
7225 #endif
7226       include 'COMMON.FFIELD'
7227       include 'COMMON.DERIV'
7228       include 'COMMON.LOCAL'
7229       include 'COMMON.INTERACT'
7230       include 'COMMON.CONTACTS'
7231       include 'COMMON.CONTMAT'
7232       include 'COMMON.CORRMAT'
7233       include 'COMMON.CHAIN'
7234       include 'COMMON.CONTROL'
7235       include 'COMMON.SHIELD'
7236       double precision gx(3),gx1(3)
7237       integer num_cont_hb_old(maxres)
7238       logical lprn,ldone
7239       double precision eello4,eello5,eelo6,eello_turn6
7240       external eello4,eello5,eello6,eello_turn6
7241 C Set lprn=.true. for debugging
7242       lprn=.false.
7243       eturn6=0.0d0
7244       if (lprn) then
7245         write (iout,'(a)') 'Contact function values:'
7246         do i=nnt,nct-2
7247           write (iout,'(2i3,50(1x,i2,5f6.3))')
7248      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7249      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7250         enddo
7251       endif
7252       ecorr=0.0D0
7253       ecorr5=0.0d0
7254       ecorr6=0.0d0
7255 C Remove the loop below after debugging !!!
7256       do i=nnt,nct
7257         do j=1,3
7258           gradcorr(j,i)=0.0D0
7259           gradxorr(j,i)=0.0D0
7260         enddo
7261       enddo
7262 C Calculate the dipole-dipole interaction energies
7263       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7264       do i=iatel_s,iatel_e+1
7265         num_conti=num_cont_hb(i)
7266         do jj=1,num_conti
7267           j=jcont_hb(jj,i)
7268 #ifdef MOMENT
7269           call dipole(i,j,jj)
7270 #endif
7271         enddo
7272       enddo
7273       endif
7274 C Calculate the local-electrostatic correlation terms
7275 c                write (iout,*) "gradcorr5 in eello5 before loop"
7276 c                do iii=1,nres
7277 c                  write (iout,'(i5,3f10.5)')
7278 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7279 c                enddo
7280       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7281 c        write (iout,*) "corr loop i",i
7282         i1=i+1
7283         num_conti=num_cont_hb(i)
7284         num_conti1=num_cont_hb(i+1)
7285         do jj=1,num_conti
7286           j=jcont_hb(jj,i)
7287           jp=iabs(j)
7288           do kk=1,num_conti1
7289             j1=jcont_hb(kk,i1)
7290             jp1=iabs(j1)
7291 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7292 c     &         ' jj=',jj,' kk=',kk
7293 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7294             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7295      &          .or. j.lt.0 .and. j1.gt.0) .and.
7296      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7297 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7298 C The system gains extra energy.
7299               n_corr=n_corr+1
7300               sqd1=dsqrt(d_cont(jj,i))
7301               sqd2=dsqrt(d_cont(kk,i1))
7302               sred_geom = sqd1*sqd2
7303               IF (sred_geom.lt.cutoff_corr) THEN
7304                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7305      &            ekont,fprimcont)
7306 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7307 cd     &         ' jj=',jj,' kk=',kk
7308                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7309                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7310                 do l=1,3
7311                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7312                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7313                 enddo
7314                 n_corr1=n_corr1+1
7315 cd               write (iout,*) 'sred_geom=',sred_geom,
7316 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7317 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7318 cd               write (iout,*) "g_contij",g_contij
7319 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7320 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7321                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7322                 if (wcorr4.gt.0.0d0)
7323      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7324 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7325                   if (energy_dec.and.wcorr4.gt.0.0d0)
7326      1                 write (iout,'(a6,4i5,0pf7.3)')
7327      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7328 c                write (iout,*) "gradcorr5 before eello5"
7329 c                do iii=1,nres
7330 c                  write (iout,'(i5,3f10.5)')
7331 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7332 c                enddo
7333                 if (wcorr5.gt.0.0d0)
7334      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7335 c                write (iout,*) "gradcorr5 after eello5"
7336 c                do iii=1,nres
7337 c                  write (iout,'(i5,3f10.5)')
7338 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7339 c                enddo
7340                   if (energy_dec.and.wcorr5.gt.0.0d0)
7341      1                 write (iout,'(a6,4i5,0pf7.3)')
7342      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7343 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7344 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7345                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7346      &               .or. wturn6.eq.0.0d0))then
7347 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7348                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7349                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7350      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7351 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7352 cd     &            'ecorr6=',ecorr6
7353 cd                write (iout,'(4e15.5)') sred_geom,
7354 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7355 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7356 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7357                 else if (wturn6.gt.0.0d0
7358      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7359 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7360                   eturn6=eturn6+eello_turn6(i,jj,kk)
7361                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7362      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7363 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7364                 endif
7365               ENDIF
7366 1111          continue
7367             endif
7368           enddo ! kk
7369         enddo ! jj
7370       enddo ! i
7371       do i=1,nres
7372         num_cont_hb(i)=num_cont_hb_old(i)
7373       enddo
7374 c                write (iout,*) "gradcorr5 in eello5"
7375 c                do iii=1,nres
7376 c                  write (iout,'(i5,3f10.5)')
7377 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7378 c                enddo
7379       return
7380       end
7381 c------------------------------------------------------------------------------
7382       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7383       implicit real*8 (a-h,o-z)
7384       include 'DIMENSIONS'
7385       include 'DIMENSIONS.ZSCOPT'
7386       include 'COMMON.IOUNITS'
7387       include 'COMMON.DERIV'
7388       include 'COMMON.INTERACT'
7389       include 'COMMON.CONTACTS'
7390       include 'COMMON.CONTMAT'
7391       include 'COMMON.CORRMAT'
7392       include 'COMMON.SHIELD'
7393       include 'COMMON.CONTROL'
7394       double precision gx(3),gx1(3)
7395       logical lprn
7396       lprn=.false.
7397 C      print *,"wchodze",fac_shield(i),shield_mode
7398       eij=facont_hb(jj,i)
7399       ekl=facont_hb(kk,k)
7400       ees0pij=ees0p(jj,i)
7401       ees0pkl=ees0p(kk,k)
7402       ees0mij=ees0m(jj,i)
7403       ees0mkl=ees0m(kk,k)
7404       ekont=eij*ekl
7405       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7406 C*
7407 C     & fac_shield(i)**2*fac_shield(j)**2
7408 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7409 C Following 4 lines for diagnostics.
7410 cd    ees0pkl=0.0D0
7411 cd    ees0pij=1.0D0
7412 cd    ees0mkl=0.0D0
7413 cd    ees0mij=1.0D0
7414 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7415 c     & 'Contacts ',i,j,
7416 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7417 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7418 c     & 'gradcorr_long'
7419 C Calculate the multi-body contribution to energy.
7420 C      ecorr=ecorr+ekont*ees
7421 C Calculate multi-body contributions to the gradient.
7422       coeffpees0pij=coeffp*ees0pij
7423       coeffmees0mij=coeffm*ees0mij
7424       coeffpees0pkl=coeffp*ees0pkl
7425       coeffmees0mkl=coeffm*ees0mkl
7426       do ll=1,3
7427 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7428         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7429      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7430      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7431         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7432      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7433      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7434 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7435         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7436      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7437      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7438         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7439      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7440      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7441         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7442      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7443      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7444         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7445         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7446         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7447      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7448      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7449         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7450         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7451 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7452       enddo
7453 c      write (iout,*)
7454 cgrad      do m=i+1,j-1
7455 cgrad        do ll=1,3
7456 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7457 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7458 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7459 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7460 cgrad        enddo
7461 cgrad      enddo
7462 cgrad      do m=k+1,l-1
7463 cgrad        do ll=1,3
7464 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7465 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7466 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7467 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7468 cgrad        enddo
7469 cgrad      enddo
7470 c      write (iout,*) "ehbcorr",ekont*ees
7471 C      print *,ekont,ees,i,k
7472       ehbcorr=ekont*ees
7473 C now gradient over shielding
7474 C      return
7475       if (shield_mode.gt.0) then
7476        j=ees0plist(jj,i)
7477        l=ees0plist(kk,k)
7478 C        print *,i,j,fac_shield(i),fac_shield(j),
7479 C     &fac_shield(k),fac_shield(l)
7480         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7481      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7482           do ilist=1,ishield_list(i)
7483            iresshield=shield_list(ilist,i)
7484            do m=1,3
7485            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7486 C     &      *2.0
7487            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7488      &              rlocshield
7489      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7490             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7491      &+rlocshield
7492            enddo
7493           enddo
7494           do ilist=1,ishield_list(j)
7495            iresshield=shield_list(ilist,j)
7496            do m=1,3
7497            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7498 C     &     *2.0
7499            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7500      &              rlocshield
7501      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7502            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7503      &     +rlocshield
7504            enddo
7505           enddo
7506
7507           do ilist=1,ishield_list(k)
7508            iresshield=shield_list(ilist,k)
7509            do m=1,3
7510            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7511 C     &     *2.0
7512            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7513      &              rlocshield
7514      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7515            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7516      &     +rlocshield
7517            enddo
7518           enddo
7519           do ilist=1,ishield_list(l)
7520            iresshield=shield_list(ilist,l)
7521            do m=1,3
7522            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7523 C     &     *2.0
7524            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7525      &              rlocshield
7526      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7527            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7528      &     +rlocshield
7529            enddo
7530           enddo
7531 C          print *,gshieldx(m,iresshield)
7532           do m=1,3
7533             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7534      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7535             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7536      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7537             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7538      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7539             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7540      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7541
7542             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7543      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7544             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7545      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7546             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7547      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7548             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7549      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7550
7551            enddo
7552       endif
7553       endif
7554       return
7555       end
7556 #ifdef MOMENT
7557 C---------------------------------------------------------------------------
7558       subroutine dipole(i,j,jj)
7559       implicit real*8 (a-h,o-z)
7560       include 'DIMENSIONS'
7561       include 'DIMENSIONS.ZSCOPT'
7562       include 'COMMON.IOUNITS'
7563       include 'COMMON.CHAIN'
7564       include 'COMMON.FFIELD'
7565       include 'COMMON.DERIV'
7566       include 'COMMON.INTERACT'
7567       include 'COMMON.CONTACTS'
7568       include 'COMMON.CONTMAT'
7569       include 'COMMON.CORRMAT'
7570       include 'COMMON.TORSION'
7571       include 'COMMON.VAR'
7572       include 'COMMON.GEO'
7573       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7574      &  auxmat(2,2)
7575       iti1 = itortyp(itype(i+1))
7576       if (j.lt.nres-1) then
7577         itj1 = itype2loc(itype(j+1))
7578       else
7579         itj1=nloctyp
7580       endif
7581       do iii=1,2
7582         dipi(iii,1)=Ub2(iii,i)
7583         dipderi(iii)=Ub2der(iii,i)
7584         dipi(iii,2)=b1(iii,i+1)
7585         dipj(iii,1)=Ub2(iii,j)
7586         dipderj(iii)=Ub2der(iii,j)
7587         dipj(iii,2)=b1(iii,j+1)
7588       enddo
7589       kkk=0
7590       do iii=1,2
7591         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7592         do jjj=1,2
7593           kkk=kkk+1
7594           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7595         enddo
7596       enddo
7597       do kkk=1,5
7598         do lll=1,3
7599           mmm=0
7600           do iii=1,2
7601             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7602      &        auxvec(1))
7603             do jjj=1,2
7604               mmm=mmm+1
7605               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7606             enddo
7607           enddo
7608         enddo
7609       enddo
7610       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7611       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7612       do iii=1,2
7613         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7614       enddo
7615       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7616       do iii=1,2
7617         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7618       enddo
7619       return
7620       end
7621 #endif
7622 C---------------------------------------------------------------------------
7623       subroutine calc_eello(i,j,k,l,jj,kk)
7624 C
7625 C This subroutine computes matrices and vectors needed to calculate
7626 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7627 C
7628       implicit real*8 (a-h,o-z)
7629       include 'DIMENSIONS'
7630       include 'DIMENSIONS.ZSCOPT'
7631       include 'COMMON.IOUNITS'
7632       include 'COMMON.CHAIN'
7633       include 'COMMON.DERIV'
7634       include 'COMMON.INTERACT'
7635       include 'COMMON.CONTACTS'
7636       include 'COMMON.CONTMAT'
7637       include 'COMMON.CORRMAT'
7638       include 'COMMON.TORSION'
7639       include 'COMMON.VAR'
7640       include 'COMMON.GEO'
7641       include 'COMMON.FFIELD'
7642       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7643      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7644       logical lprn
7645       common /kutas/ lprn
7646 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7647 cd     & ' jj=',jj,' kk=',kk
7648 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7649 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7650 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7651       do iii=1,2
7652         do jjj=1,2
7653           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7654           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7655         enddo
7656       enddo
7657       call transpose2(aa1(1,1),aa1t(1,1))
7658       call transpose2(aa2(1,1),aa2t(1,1))
7659       do kkk=1,5
7660         do lll=1,3
7661           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7662      &      aa1tder(1,1,lll,kkk))
7663           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7664      &      aa2tder(1,1,lll,kkk))
7665         enddo
7666       enddo
7667       if (l.eq.j+1) then
7668 C parallel orientation of the two CA-CA-CA frames.
7669         if (i.gt.1) then
7670           iti=itype2loc(itype(i))
7671         else
7672           iti=nloctyp
7673         endif
7674         itk1=itype2loc(itype(k+1))
7675         itj=itype2loc(itype(j))
7676         if (l.lt.nres-1) then
7677           itl1=itype2loc(itype(l+1))
7678         else
7679           itl1=nloctyp
7680         endif
7681 C A1 kernel(j+1) A2T
7682 cd        do iii=1,2
7683 cd          write (iout,'(3f10.5,5x,3f10.5)')
7684 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7685 cd        enddo
7686         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7687      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7688      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7689 C Following matrices are needed only for 6-th order cumulants
7690         IF (wcorr6.gt.0.0d0) THEN
7691         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7692      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7693      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7694         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7695      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7696      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7697      &   ADtEAderx(1,1,1,1,1,1))
7698         lprn=.false.
7699         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7700      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7701      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7702      &   ADtEA1derx(1,1,1,1,1,1))
7703         ENDIF
7704 C End 6-th order cumulants
7705 cd        lprn=.false.
7706 cd        if (lprn) then
7707 cd        write (2,*) 'In calc_eello6'
7708 cd        do iii=1,2
7709 cd          write (2,*) 'iii=',iii
7710 cd          do kkk=1,5
7711 cd            write (2,*) 'kkk=',kkk
7712 cd            do jjj=1,2
7713 cd              write (2,'(3(2f10.5),5x)')
7714 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7715 cd            enddo
7716 cd          enddo
7717 cd        enddo
7718 cd        endif
7719         call transpose2(EUgder(1,1,k),auxmat(1,1))
7720         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7721         call transpose2(EUg(1,1,k),auxmat(1,1))
7722         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7723         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7724         do iii=1,2
7725           do kkk=1,5
7726             do lll=1,3
7727               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7728      &          EAEAderx(1,1,lll,kkk,iii,1))
7729             enddo
7730           enddo
7731         enddo
7732 C A1T kernel(i+1) A2
7733         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7734      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7735      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7736 C Following matrices are needed only for 6-th order cumulants
7737         IF (wcorr6.gt.0.0d0) THEN
7738         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7739      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7740      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7741         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7742      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7743      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7744      &   ADtEAderx(1,1,1,1,1,2))
7745         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7746      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7747      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7748      &   ADtEA1derx(1,1,1,1,1,2))
7749         ENDIF
7750 C End 6-th order cumulants
7751         call transpose2(EUgder(1,1,l),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7753         call transpose2(EUg(1,1,l),auxmat(1,1))
7754         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7755         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7756         do iii=1,2
7757           do kkk=1,5
7758             do lll=1,3
7759               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7760      &          EAEAderx(1,1,lll,kkk,iii,2))
7761             enddo
7762           enddo
7763         enddo
7764 C AEAb1 and AEAb2
7765 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7766 C They are needed only when the fifth- or the sixth-order cumulants are
7767 C indluded.
7768         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7769         call transpose2(AEA(1,1,1),auxmat(1,1))
7770         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7771         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7772         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7773         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7774         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7775         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7776         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7777         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7778         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7779         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7780         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7781         call transpose2(AEA(1,1,2),auxmat(1,1))
7782         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7783         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7784         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7785         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7786         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7787         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7788         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7789         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7790         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7791         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7792         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7793 C Calculate the Cartesian derivatives of the vectors.
7794         do iii=1,2
7795           do kkk=1,5
7796             do lll=1,3
7797               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7798               call matvec2(auxmat(1,1),b1(1,i),
7799      &          AEAb1derx(1,lll,kkk,iii,1,1))
7800               call matvec2(auxmat(1,1),Ub2(1,i),
7801      &          AEAb2derx(1,lll,kkk,iii,1,1))
7802               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7803      &          AEAb1derx(1,lll,kkk,iii,2,1))
7804               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7805      &          AEAb2derx(1,lll,kkk,iii,2,1))
7806               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7807               call matvec2(auxmat(1,1),b1(1,j),
7808      &          AEAb1derx(1,lll,kkk,iii,1,2))
7809               call matvec2(auxmat(1,1),Ub2(1,j),
7810      &          AEAb2derx(1,lll,kkk,iii,1,2))
7811               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7812      &          AEAb1derx(1,lll,kkk,iii,2,2))
7813               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7814      &          AEAb2derx(1,lll,kkk,iii,2,2))
7815             enddo
7816           enddo
7817         enddo
7818         ENDIF
7819 C End vectors
7820       else
7821 C Antiparallel orientation of the two CA-CA-CA frames.
7822         if (i.gt.1) then
7823           iti=itype2loc(itype(i))
7824         else
7825           iti=nloctyp
7826         endif
7827         itk1=itype2loc(itype(k+1))
7828         itl=itype2loc(itype(l))
7829         itj=itype2loc(itype(j))
7830         if (j.lt.nres-1) then
7831           itj1=itype2loc(itype(j+1))
7832         else
7833           itj1=nloctyp
7834         endif
7835 C A2 kernel(j-1)T A1T
7836         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7837      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7838      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7839 C Following matrices are needed only for 6-th order cumulants
7840         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7841      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7842         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7843      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7844      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7845         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7846      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7847      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7848      &   ADtEAderx(1,1,1,1,1,1))
7849         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7850      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7851      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7852      &   ADtEA1derx(1,1,1,1,1,1))
7853         ENDIF
7854 C End 6-th order cumulants
7855         call transpose2(EUgder(1,1,k),auxmat(1,1))
7856         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7857         call transpose2(EUg(1,1,k),auxmat(1,1))
7858         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7859         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7860         do iii=1,2
7861           do kkk=1,5
7862             do lll=1,3
7863               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7864      &          EAEAderx(1,1,lll,kkk,iii,1))
7865             enddo
7866           enddo
7867         enddo
7868 C A2T kernel(i+1)T A1
7869         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7870      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7871      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7872 C Following matrices are needed only for 6-th order cumulants
7873         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7874      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7875         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7876      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7877      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7878         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7879      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7880      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7881      &   ADtEAderx(1,1,1,1,1,2))
7882         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7883      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7884      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7885      &   ADtEA1derx(1,1,1,1,1,2))
7886         ENDIF
7887 C End 6-th order cumulants
7888         call transpose2(EUgder(1,1,j),auxmat(1,1))
7889         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7890         call transpose2(EUg(1,1,j),auxmat(1,1))
7891         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7892         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7893         do iii=1,2
7894           do kkk=1,5
7895             do lll=1,3
7896               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7897      &          EAEAderx(1,1,lll,kkk,iii,2))
7898             enddo
7899           enddo
7900         enddo
7901 C AEAb1 and AEAb2
7902 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7903 C They are needed only when the fifth- or the sixth-order cumulants are
7904 C indluded.
7905         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7906      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7907         call transpose2(AEA(1,1,1),auxmat(1,1))
7908         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7909         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7910         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7911         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7912         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7913         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7914         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7915         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7916         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7917         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7918         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7919         call transpose2(AEA(1,1,2),auxmat(1,1))
7920         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7921         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7922         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7923         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7924         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7925         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7926         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7927         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7928         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7929         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7930         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7931 C Calculate the Cartesian derivatives of the vectors.
7932         do iii=1,2
7933           do kkk=1,5
7934             do lll=1,3
7935               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7936               call matvec2(auxmat(1,1),b1(1,i),
7937      &          AEAb1derx(1,lll,kkk,iii,1,1))
7938               call matvec2(auxmat(1,1),Ub2(1,i),
7939      &          AEAb2derx(1,lll,kkk,iii,1,1))
7940               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7941      &          AEAb1derx(1,lll,kkk,iii,2,1))
7942               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7943      &          AEAb2derx(1,lll,kkk,iii,2,1))
7944               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7945               call matvec2(auxmat(1,1),b1(1,l),
7946      &          AEAb1derx(1,lll,kkk,iii,1,2))
7947               call matvec2(auxmat(1,1),Ub2(1,l),
7948      &          AEAb2derx(1,lll,kkk,iii,1,2))
7949               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7950      &          AEAb1derx(1,lll,kkk,iii,2,2))
7951               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7952      &          AEAb2derx(1,lll,kkk,iii,2,2))
7953             enddo
7954           enddo
7955         enddo
7956         ENDIF
7957 C End vectors
7958       endif
7959       return
7960       end
7961 C---------------------------------------------------------------------------
7962       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7963      &  KK,KKderg,AKA,AKAderg,AKAderx)
7964       implicit none
7965       integer nderg
7966       logical transp
7967       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7968      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7969      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7970       integer iii,kkk,lll
7971       integer jjj,mmm
7972       logical lprn
7973       common /kutas/ lprn
7974       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7975       do iii=1,nderg
7976         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7977      &    AKAderg(1,1,iii))
7978       enddo
7979 cd      if (lprn) write (2,*) 'In kernel'
7980       do kkk=1,5
7981 cd        if (lprn) write (2,*) 'kkk=',kkk
7982         do lll=1,3
7983           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7984      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7985 cd          if (lprn) then
7986 cd            write (2,*) 'lll=',lll
7987 cd            write (2,*) 'iii=1'
7988 cd            do jjj=1,2
7989 cd              write (2,'(3(2f10.5),5x)')
7990 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7991 cd            enddo
7992 cd          endif
7993           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7994      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7995 cd          if (lprn) then
7996 cd            write (2,*) 'lll=',lll
7997 cd            write (2,*) 'iii=2'
7998 cd            do jjj=1,2
7999 cd              write (2,'(3(2f10.5),5x)')
8000 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8001 cd            enddo
8002 cd          endif
8003         enddo
8004       enddo
8005       return
8006       end
8007 C---------------------------------------------------------------------------
8008       double precision function eello4(i,j,k,l,jj,kk)
8009       implicit real*8 (a-h,o-z)
8010       include 'DIMENSIONS'
8011       include 'DIMENSIONS.ZSCOPT'
8012       include 'COMMON.IOUNITS'
8013       include 'COMMON.CHAIN'
8014       include 'COMMON.DERIV'
8015       include 'COMMON.INTERACT'
8016       include 'COMMON.CONTACTS'
8017       include 'COMMON.CONTMAT'
8018       include 'COMMON.CORRMAT'
8019       include 'COMMON.TORSION'
8020       include 'COMMON.VAR'
8021       include 'COMMON.GEO'
8022       double precision pizda(2,2),ggg1(3),ggg2(3)
8023 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8024 cd        eello4=0.0d0
8025 cd        return
8026 cd      endif
8027 cd      print *,'eello4:',i,j,k,l,jj,kk
8028 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8029 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8030 cold      eij=facont_hb(jj,i)
8031 cold      ekl=facont_hb(kk,k)
8032 cold      ekont=eij*ekl
8033       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8034       if (calc_grad) then
8035 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8036       gcorr_loc(k-1)=gcorr_loc(k-1)
8037      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8038       if (l.eq.j+1) then
8039         gcorr_loc(l-1)=gcorr_loc(l-1)
8040      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8041       else
8042         gcorr_loc(j-1)=gcorr_loc(j-1)
8043      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8044       endif
8045       do iii=1,2
8046         do kkk=1,5
8047           do lll=1,3
8048             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8049      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8050 cd            derx(lll,kkk,iii)=0.0d0
8051           enddo
8052         enddo
8053       enddo
8054 cd      gcorr_loc(l-1)=0.0d0
8055 cd      gcorr_loc(j-1)=0.0d0
8056 cd      gcorr_loc(k-1)=0.0d0
8057 cd      eel4=1.0d0
8058 cd      write (iout,*)'Contacts have occurred for peptide groups',
8059 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8060 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8061       if (j.lt.nres-1) then
8062         j1=j+1
8063         j2=j-1
8064       else
8065         j1=j-1
8066         j2=j-2
8067       endif
8068       if (l.lt.nres-1) then
8069         l1=l+1
8070         l2=l-1
8071       else
8072         l1=l-1
8073         l2=l-2
8074       endif
8075       do ll=1,3
8076 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8077 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8078         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8079         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8080 cgrad        ghalf=0.5d0*ggg1(ll)
8081         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8082         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8083         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8084         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8085         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8086         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8087 cgrad        ghalf=0.5d0*ggg2(ll)
8088         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8089         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8090         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8091         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8092         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8093         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8094       enddo
8095 cgrad      do m=i+1,j-1
8096 cgrad        do ll=1,3
8097 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8098 cgrad        enddo
8099 cgrad      enddo
8100 cgrad      do m=k+1,l-1
8101 cgrad        do ll=1,3
8102 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8103 cgrad        enddo
8104 cgrad      enddo
8105 cgrad      do m=i+2,j2
8106 cgrad        do ll=1,3
8107 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cgrad      do m=k+2,l2
8111 cgrad        do ll=1,3
8112 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8113 cgrad        enddo
8114 cgrad      enddo
8115 cd      do iii=1,nres-3
8116 cd        write (2,*) iii,gcorr_loc(iii)
8117 cd      enddo
8118       endif ! calc_grad
8119       eello4=ekont*eel4
8120 cd      write (2,*) 'ekont',ekont
8121 cd      write (iout,*) 'eello4',ekont*eel4
8122       return
8123       end
8124 C---------------------------------------------------------------------------
8125       double precision function eello5(i,j,k,l,jj,kk)
8126       implicit real*8 (a-h,o-z)
8127       include 'DIMENSIONS'
8128       include 'DIMENSIONS.ZSCOPT'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.CONTMAT'
8135       include 'COMMON.CORRMAT'
8136       include 'COMMON.TORSION'
8137       include 'COMMON.VAR'
8138       include 'COMMON.GEO'
8139       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8140       double precision ggg1(3),ggg2(3)
8141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8142 C                                                                              C
8143 C                            Parallel chains                                   C
8144 C                                                                              C
8145 C          o             o                   o             o                   C
8146 C         /l\           / \             \   / \           / \   /              C
8147 C        /   \         /   \             \ /   \         /   \ /               C
8148 C       j| o |l1       | o |              o| o |         | o |o                C
8149 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8150 C      \i/   \         /   \ /             /   \         /   \                 C
8151 C       o    k1             o                                                  C
8152 C         (I)          (II)                (III)          (IV)                 C
8153 C                                                                              C
8154 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8155 C                                                                              C
8156 C                            Antiparallel chains                               C
8157 C                                                                              C
8158 C          o             o                   o             o                   C
8159 C         /j\           / \             \   / \           / \   /              C
8160 C        /   \         /   \             \ /   \         /   \ /               C
8161 C      j1| o |l        | o |              o| o |         | o |o                C
8162 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8163 C      \i/   \         /   \ /             /   \         /   \                 C
8164 C       o     k1            o                                                  C
8165 C         (I)          (II)                (III)          (IV)                 C
8166 C                                                                              C
8167 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8168 C                                                                              C
8169 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8170 C                                                                              C
8171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8172 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8173 cd        eello5=0.0d0
8174 cd        return
8175 cd      endif
8176 cd      write (iout,*)
8177 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8178 cd     &   ' and',k,l
8179       itk=itype2loc(itype(k))
8180       itl=itype2loc(itype(l))
8181       itj=itype2loc(itype(j))
8182       eello5_1=0.0d0
8183       eello5_2=0.0d0
8184       eello5_3=0.0d0
8185       eello5_4=0.0d0
8186 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8187 cd     &   eel5_3_num,eel5_4_num)
8188       do iii=1,2
8189         do kkk=1,5
8190           do lll=1,3
8191             derx(lll,kkk,iii)=0.0d0
8192           enddo
8193         enddo
8194       enddo
8195 cd      eij=facont_hb(jj,i)
8196 cd      ekl=facont_hb(kk,k)
8197 cd      ekont=eij*ekl
8198 cd      write (iout,*)'Contacts have occurred for peptide groups',
8199 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8200 cd      goto 1111
8201 C Contribution from the graph I.
8202 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8203 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8204       call transpose2(EUg(1,1,k),auxmat(1,1))
8205       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8206       vv(1)=pizda(1,1)-pizda(2,2)
8207       vv(2)=pizda(1,2)+pizda(2,1)
8208       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8209      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8210       if (calc_grad) then
8211 C Explicit gradient in virtual-dihedral angles.
8212       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8213      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8214      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8215       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8216       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8217       vv(1)=pizda(1,1)-pizda(2,2)
8218       vv(2)=pizda(1,2)+pizda(2,1)
8219       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8220      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8221      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8222       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8223       vv(1)=pizda(1,1)-pizda(2,2)
8224       vv(2)=pizda(1,2)+pizda(2,1)
8225       if (l.eq.j+1) then
8226         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8227      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8228      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8229       else
8230         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8231      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8232      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8233       endif
8234 C Cartesian gradient
8235       do iii=1,2
8236         do kkk=1,5
8237           do lll=1,3
8238             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8239      &        pizda(1,1))
8240             vv(1)=pizda(1,1)-pizda(2,2)
8241             vv(2)=pizda(1,2)+pizda(2,1)
8242             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8243      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8244      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8245           enddo
8246         enddo
8247       enddo
8248       endif ! calc_grad
8249 c      goto 1112
8250 c1111  continue
8251 C Contribution from graph II
8252       call transpose2(EE(1,1,k),auxmat(1,1))
8253       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8254       vv(1)=pizda(1,1)+pizda(2,2)
8255       vv(2)=pizda(2,1)-pizda(1,2)
8256       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8257      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8258       if (calc_grad) then
8259 C Explicit gradient in virtual-dihedral angles.
8260       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8261      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8262       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8263       vv(1)=pizda(1,1)+pizda(2,2)
8264       vv(2)=pizda(2,1)-pizda(1,2)
8265       if (l.eq.j+1) then
8266         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8267      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8268      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8269       else
8270         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8271      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8272      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8273       endif
8274 C Cartesian gradient
8275       do iii=1,2
8276         do kkk=1,5
8277           do lll=1,3
8278             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8279      &        pizda(1,1))
8280             vv(1)=pizda(1,1)+pizda(2,2)
8281             vv(2)=pizda(2,1)-pizda(1,2)
8282             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8283      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8284      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8285           enddo
8286         enddo
8287       enddo
8288       endif ! calc_grad
8289 cd      goto 1112
8290 cd1111  continue
8291       if (l.eq.j+1) then
8292 cd        goto 1110
8293 C Parallel orientation
8294 C Contribution from graph III
8295         call transpose2(EUg(1,1,l),auxmat(1,1))
8296         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8297         vv(1)=pizda(1,1)-pizda(2,2)
8298         vv(2)=pizda(1,2)+pizda(2,1)
8299         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8300      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8301         if (calc_grad) then
8302 C Explicit gradient in virtual-dihedral angles.
8303         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8304      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8305      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8306         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8307         vv(1)=pizda(1,1)-pizda(2,2)
8308         vv(2)=pizda(1,2)+pizda(2,1)
8309         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8310      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8311      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8312         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8313         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8314         vv(1)=pizda(1,1)-pizda(2,2)
8315         vv(2)=pizda(1,2)+pizda(2,1)
8316         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8317      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8318      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8319 C Cartesian gradient
8320         do iii=1,2
8321           do kkk=1,5
8322             do lll=1,3
8323               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8324      &          pizda(1,1))
8325               vv(1)=pizda(1,1)-pizda(2,2)
8326               vv(2)=pizda(1,2)+pizda(2,1)
8327               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8328      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8329      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8330             enddo
8331           enddo
8332         enddo
8333 cd        goto 1112
8334 C Contribution from graph IV
8335 cd1110    continue
8336         call transpose2(EE(1,1,l),auxmat(1,1))
8337         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8338         vv(1)=pizda(1,1)+pizda(2,2)
8339         vv(2)=pizda(2,1)-pizda(1,2)
8340         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8341      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8342 C Explicit gradient in virtual-dihedral angles.
8343         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8344      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8345         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8346         vv(1)=pizda(1,1)+pizda(2,2)
8347         vv(2)=pizda(2,1)-pizda(1,2)
8348         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8349      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8350      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8351 C Cartesian gradient
8352         do iii=1,2
8353           do kkk=1,5
8354             do lll=1,3
8355               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8356      &          pizda(1,1))
8357               vv(1)=pizda(1,1)+pizda(2,2)
8358               vv(2)=pizda(2,1)-pizda(1,2)
8359               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8360      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8361      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8362             enddo
8363           enddo
8364         enddo
8365         endif ! calc_grad
8366       else
8367 C Antiparallel orientation
8368 C Contribution from graph III
8369 c        goto 1110
8370         call transpose2(EUg(1,1,j),auxmat(1,1))
8371         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8372         vv(1)=pizda(1,1)-pizda(2,2)
8373         vv(2)=pizda(1,2)+pizda(2,1)
8374         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8375      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8376         if (calc_grad) then
8377 C Explicit gradient in virtual-dihedral angles.
8378         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8379      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8380      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8381         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8382         vv(1)=pizda(1,1)-pizda(2,2)
8383         vv(2)=pizda(1,2)+pizda(2,1)
8384         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8385      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8386      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8387         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8388         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8389         vv(1)=pizda(1,1)-pizda(2,2)
8390         vv(2)=pizda(1,2)+pizda(2,1)
8391         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8392      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8393      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8394 C Cartesian gradient
8395         do iii=1,2
8396           do kkk=1,5
8397             do lll=1,3
8398               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8399      &          pizda(1,1))
8400               vv(1)=pizda(1,1)-pizda(2,2)
8401               vv(2)=pizda(1,2)+pizda(2,1)
8402               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8403      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8404      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8405             enddo
8406           enddo
8407         enddo
8408         endif ! calc_grad
8409 cd        goto 1112
8410 C Contribution from graph IV
8411 1110    continue
8412         call transpose2(EE(1,1,j),auxmat(1,1))
8413         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8414         vv(1)=pizda(1,1)+pizda(2,2)
8415         vv(2)=pizda(2,1)-pizda(1,2)
8416         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8417      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8418         if (calc_grad) then
8419 C Explicit gradient in virtual-dihedral angles.
8420         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8421      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8422         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8423         vv(1)=pizda(1,1)+pizda(2,2)
8424         vv(2)=pizda(2,1)-pizda(1,2)
8425         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8426      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8427      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8428 C Cartesian gradient
8429         do iii=1,2
8430           do kkk=1,5
8431             do lll=1,3
8432               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8433      &          pizda(1,1))
8434               vv(1)=pizda(1,1)+pizda(2,2)
8435               vv(2)=pizda(2,1)-pizda(1,2)
8436               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8437      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8438      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8439             enddo
8440           enddo
8441         enddo
8442         endif ! calc_grad
8443       endif
8444 1112  continue
8445       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8446 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8447 cd        write (2,*) 'ijkl',i,j,k,l
8448 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8449 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8450 cd      endif
8451 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8452 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8453 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8454 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8455       if (calc_grad) then
8456       if (j.lt.nres-1) then
8457         j1=j+1
8458         j2=j-1
8459       else
8460         j1=j-1
8461         j2=j-2
8462       endif
8463       if (l.lt.nres-1) then
8464         l1=l+1
8465         l2=l-1
8466       else
8467         l1=l-1
8468         l2=l-2
8469       endif
8470 cd      eij=1.0d0
8471 cd      ekl=1.0d0
8472 cd      ekont=1.0d0
8473 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8474 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8475 C        summed up outside the subrouine as for the other subroutines
8476 C        handling long-range interactions. The old code is commented out
8477 C        with "cgrad" to keep track of changes.
8478       do ll=1,3
8479 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8480 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8481         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8482         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8483 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8484 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8485 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8486 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8487 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8488 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8489 c     &   gradcorr5ij,
8490 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8491 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8492 cgrad        ghalf=0.5d0*ggg1(ll)
8493 cd        ghalf=0.0d0
8494         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8495         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8496         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8497         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8498         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8499         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8500 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8501 cgrad        ghalf=0.5d0*ggg2(ll)
8502 cd        ghalf=0.0d0
8503         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8504         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8505         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8506         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8507         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8508         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8509       enddo
8510       endif ! calc_grad
8511 cd      goto 1112
8512 cgrad      do m=i+1,j-1
8513 cgrad        do ll=1,3
8514 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8515 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8516 cgrad        enddo
8517 cgrad      enddo
8518 cgrad      do m=k+1,l-1
8519 cgrad        do ll=1,3
8520 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8521 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8522 cgrad        enddo
8523 cgrad      enddo
8524 c1112  continue
8525 cgrad      do m=i+2,j2
8526 cgrad        do ll=1,3
8527 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8528 cgrad        enddo
8529 cgrad      enddo
8530 cgrad      do m=k+2,l2
8531 cgrad        do ll=1,3
8532 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8533 cgrad        enddo
8534 cgrad      enddo
8535 cd      do iii=1,nres-3
8536 cd        write (2,*) iii,g_corr5_loc(iii)
8537 cd      enddo
8538       eello5=ekont*eel5
8539 cd      write (2,*) 'ekont',ekont
8540 cd      write (iout,*) 'eello5',ekont*eel5
8541       return
8542       end
8543 c--------------------------------------------------------------------------
8544       double precision function eello6(i,j,k,l,jj,kk)
8545       implicit real*8 (a-h,o-z)
8546       include 'DIMENSIONS'
8547       include 'DIMENSIONS.ZSCOPT'
8548       include 'COMMON.IOUNITS'
8549       include 'COMMON.CHAIN'
8550       include 'COMMON.DERIV'
8551       include 'COMMON.INTERACT'
8552       include 'COMMON.CONTACTS'
8553       include 'COMMON.CONTMAT'
8554       include 'COMMON.CORRMAT'
8555       include 'COMMON.TORSION'
8556       include 'COMMON.VAR'
8557       include 'COMMON.GEO'
8558       include 'COMMON.FFIELD'
8559       double precision ggg1(3),ggg2(3)
8560 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8561 cd        eello6=0.0d0
8562 cd        return
8563 cd      endif
8564 cd      write (iout,*)
8565 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8566 cd     &   ' and',k,l
8567       eello6_1=0.0d0
8568       eello6_2=0.0d0
8569       eello6_3=0.0d0
8570       eello6_4=0.0d0
8571       eello6_5=0.0d0
8572       eello6_6=0.0d0
8573 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8574 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8575       do iii=1,2
8576         do kkk=1,5
8577           do lll=1,3
8578             derx(lll,kkk,iii)=0.0d0
8579           enddo
8580         enddo
8581       enddo
8582 cd      eij=facont_hb(jj,i)
8583 cd      ekl=facont_hb(kk,k)
8584 cd      ekont=eij*ekl
8585 cd      eij=1.0d0
8586 cd      ekl=1.0d0
8587 cd      ekont=1.0d0
8588       if (l.eq.j+1) then
8589         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8590         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8591         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8592         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8593         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8594         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8595       else
8596         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8597         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8598         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8599         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8600         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8601           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8602         else
8603           eello6_5=0.0d0
8604         endif
8605         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8606       endif
8607 C If turn contributions are considered, they will be handled separately.
8608       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8609 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8610 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8611 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8612 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8613 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8614 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8615 cd      goto 1112
8616       if (calc_grad) then
8617       if (j.lt.nres-1) then
8618         j1=j+1
8619         j2=j-1
8620       else
8621         j1=j-1
8622         j2=j-2
8623       endif
8624       if (l.lt.nres-1) then
8625         l1=l+1
8626         l2=l-1
8627       else
8628         l1=l-1
8629         l2=l-2
8630       endif
8631       do ll=1,3
8632 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8633 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8634 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8635 cgrad        ghalf=0.5d0*ggg1(ll)
8636 cd        ghalf=0.0d0
8637         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8638         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8639         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8640         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8641         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8642         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8643         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8644         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8645 cgrad        ghalf=0.5d0*ggg2(ll)
8646 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8647 cd        ghalf=0.0d0
8648         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8649         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8650         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8651         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8652         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8653         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8654       enddo
8655       endif ! calc_grad
8656 cd      goto 1112
8657 cgrad      do m=i+1,j-1
8658 cgrad        do ll=1,3
8659 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8660 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8661 cgrad        enddo
8662 cgrad      enddo
8663 cgrad      do m=k+1,l-1
8664 cgrad        do ll=1,3
8665 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8666 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8667 cgrad        enddo
8668 cgrad      enddo
8669 cgrad1112  continue
8670 cgrad      do m=i+2,j2
8671 cgrad        do ll=1,3
8672 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8673 cgrad        enddo
8674 cgrad      enddo
8675 cgrad      do m=k+2,l2
8676 cgrad        do ll=1,3
8677 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8678 cgrad        enddo
8679 cgrad      enddo
8680 cd      do iii=1,nres-3
8681 cd        write (2,*) iii,g_corr6_loc(iii)
8682 cd      enddo
8683       eello6=ekont*eel6
8684 cd      write (2,*) 'ekont',ekont
8685 cd      write (iout,*) 'eello6',ekont*eel6
8686       return
8687       end
8688 c--------------------------------------------------------------------------
8689       double precision function eello6_graph1(i,j,k,l,imat,swap)
8690       implicit real*8 (a-h,o-z)
8691       include 'DIMENSIONS'
8692       include 'DIMENSIONS.ZSCOPT'
8693       include 'COMMON.IOUNITS'
8694       include 'COMMON.CHAIN'
8695       include 'COMMON.DERIV'
8696       include 'COMMON.INTERACT'
8697       include 'COMMON.CONTACTS'
8698       include 'COMMON.CONTMAT'
8699       include 'COMMON.CORRMAT'
8700       include 'COMMON.TORSION'
8701       include 'COMMON.VAR'
8702       include 'COMMON.GEO'
8703       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8704       logical swap
8705       logical lprn
8706       common /kutas/ lprn
8707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8708 C                                                                              C
8709 C      Parallel       Antiparallel                                             C
8710 C                                                                              C
8711 C          o             o                                                     C
8712 C         /l\           /j\                                                    C
8713 C        /   \         /   \                                                   C
8714 C       /| o |         | o |\                                                  C
8715 C     \ j|/k\|  /   \  |/k\|l /                                                C
8716 C      \ /   \ /     \ /   \ /                                                 C
8717 C       o     o       o     o                                                  C
8718 C       i             i                                                        C
8719 C                                                                              C
8720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8721       itk=itype2loc(itype(k))
8722       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8723       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8724       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8725       call transpose2(EUgC(1,1,k),auxmat(1,1))
8726       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8727       vv1(1)=pizda1(1,1)-pizda1(2,2)
8728       vv1(2)=pizda1(1,2)+pizda1(2,1)
8729       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8730       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8731       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8732       s5=scalar2(vv(1),Dtobr2(1,i))
8733 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8734       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8735       if (calc_grad) then
8736       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8737      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8738      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8739      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8740      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8741      & +scalar2(vv(1),Dtobr2der(1,i)))
8742       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8743       vv1(1)=pizda1(1,1)-pizda1(2,2)
8744       vv1(2)=pizda1(1,2)+pizda1(2,1)
8745       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8746       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8747       if (l.eq.j+1) then
8748         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8749      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8750      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8751      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8752      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8753       else
8754         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8755      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8756      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8757      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8758      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8759       endif
8760       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8761       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8762       vv1(1)=pizda1(1,1)-pizda1(2,2)
8763       vv1(2)=pizda1(1,2)+pizda1(2,1)
8764       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8765      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8766      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8767      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8768       do iii=1,2
8769         if (swap) then
8770           ind=3-iii
8771         else
8772           ind=iii
8773         endif
8774         do kkk=1,5
8775           do lll=1,3
8776             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8777             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8778             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8779             call transpose2(EUgC(1,1,k),auxmat(1,1))
8780             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8781      &        pizda1(1,1))
8782             vv1(1)=pizda1(1,1)-pizda1(2,2)
8783             vv1(2)=pizda1(1,2)+pizda1(2,1)
8784             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8785             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8786      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8787             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8788      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8789             s5=scalar2(vv(1),Dtobr2(1,i))
8790             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8791           enddo
8792         enddo
8793       enddo
8794       endif ! calc_grad
8795       return
8796       end
8797 c----------------------------------------------------------------------------
8798       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8799       implicit real*8 (a-h,o-z)
8800       include 'DIMENSIONS'
8801       include 'DIMENSIONS.ZSCOPT'
8802       include 'COMMON.IOUNITS'
8803       include 'COMMON.CHAIN'
8804       include 'COMMON.DERIV'
8805       include 'COMMON.INTERACT'
8806       include 'COMMON.CONTACTS'
8807       include 'COMMON.CONTMAT'
8808       include 'COMMON.CORRMAT'
8809       include 'COMMON.TORSION'
8810       include 'COMMON.VAR'
8811       include 'COMMON.GEO'
8812       logical swap
8813       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8814      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8815       logical lprn
8816       common /kutas/ lprn
8817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8818 C                                                                              C
8819 C      Parallel       Antiparallel                                             C
8820 C                                                                              C
8821 C          o             o                                                     C
8822 C     \   /l\           /j\   /                                                C
8823 C      \ /   \         /   \ /                                                 C
8824 C       o| o |         | o |o                                                  C
8825 C     \ j|/k\|      \  |/k\|l                                                  C
8826 C      \ /   \       \ /   \                                                   C
8827 C       o             o                                                        C
8828 C       i             i                                                        C
8829 C                                                                              C
8830 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8831 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8832 C AL 7/4/01 s1 would occur in the sixth-order moment,
8833 C           but not in a cluster cumulant
8834 #ifdef MOMENT
8835       s1=dip(1,jj,i)*dip(1,kk,k)
8836 #endif
8837       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8838       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8839       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8840       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8841       call transpose2(EUg(1,1,k),auxmat(1,1))
8842       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8843       vv(1)=pizda(1,1)-pizda(2,2)
8844       vv(2)=pizda(1,2)+pizda(2,1)
8845       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8846 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8847 #ifdef MOMENT
8848       eello6_graph2=-(s1+s2+s3+s4)
8849 #else
8850       eello6_graph2=-(s2+s3+s4)
8851 #endif
8852 c      eello6_graph2=-s3
8853 C Derivatives in gamma(i-1)
8854       if (calc_grad) then
8855       if (i.gt.1) then
8856 #ifdef MOMENT
8857         s1=dipderg(1,jj,i)*dip(1,kk,k)
8858 #endif
8859         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8860         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8861         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8862         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8863 #ifdef MOMENT
8864         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8865 #else
8866         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8867 #endif
8868 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8869       endif
8870 C Derivatives in gamma(k-1)
8871 #ifdef MOMENT
8872       s1=dip(1,jj,i)*dipderg(1,kk,k)
8873 #endif
8874       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8875       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8876       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8877       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8878       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8879       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8880       vv(1)=pizda(1,1)-pizda(2,2)
8881       vv(2)=pizda(1,2)+pizda(2,1)
8882       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8883 #ifdef MOMENT
8884       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8885 #else
8886       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8887 #endif
8888 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8889 C Derivatives in gamma(j-1) or gamma(l-1)
8890       if (j.gt.1) then
8891 #ifdef MOMENT
8892         s1=dipderg(3,jj,i)*dip(1,kk,k)
8893 #endif
8894         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8895         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8896         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8897         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8898         vv(1)=pizda(1,1)-pizda(2,2)
8899         vv(2)=pizda(1,2)+pizda(2,1)
8900         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8901 #ifdef MOMENT
8902         if (swap) then
8903           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8904         else
8905           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8906         endif
8907 #endif
8908         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8909 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8910       endif
8911 C Derivatives in gamma(l-1) or gamma(j-1)
8912       if (l.gt.1) then
8913 #ifdef MOMENT
8914         s1=dip(1,jj,i)*dipderg(3,kk,k)
8915 #endif
8916         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8917         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8918         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8919         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8920         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8921         vv(1)=pizda(1,1)-pizda(2,2)
8922         vv(2)=pizda(1,2)+pizda(2,1)
8923         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8924 #ifdef MOMENT
8925         if (swap) then
8926           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8927         else
8928           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8929         endif
8930 #endif
8931         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8932 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8933       endif
8934 C Cartesian derivatives.
8935       if (lprn) then
8936         write (2,*) 'In eello6_graph2'
8937         do iii=1,2
8938           write (2,*) 'iii=',iii
8939           do kkk=1,5
8940             write (2,*) 'kkk=',kkk
8941             do jjj=1,2
8942               write (2,'(3(2f10.5),5x)')
8943      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8944             enddo
8945           enddo
8946         enddo
8947       endif
8948       do iii=1,2
8949         do kkk=1,5
8950           do lll=1,3
8951 #ifdef MOMENT
8952             if (iii.eq.1) then
8953               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8954             else
8955               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8956             endif
8957 #endif
8958             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8959      &        auxvec(1))
8960             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8961             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8962      &        auxvec(1))
8963             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8964             call transpose2(EUg(1,1,k),auxmat(1,1))
8965             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8966      &        pizda(1,1))
8967             vv(1)=pizda(1,1)-pizda(2,2)
8968             vv(2)=pizda(1,2)+pizda(2,1)
8969             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8970 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8971 #ifdef MOMENT
8972             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8973 #else
8974             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8975 #endif
8976             if (swap) then
8977               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8978             else
8979               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8980             endif
8981           enddo
8982         enddo
8983       enddo
8984       endif ! calc_grad
8985       return
8986       end
8987 c----------------------------------------------------------------------------
8988       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8989       implicit real*8 (a-h,o-z)
8990       include 'DIMENSIONS'
8991       include 'DIMENSIONS.ZSCOPT'
8992       include 'COMMON.IOUNITS'
8993       include 'COMMON.CHAIN'
8994       include 'COMMON.DERIV'
8995       include 'COMMON.INTERACT'
8996       include 'COMMON.CONTACTS'
8997       include 'COMMON.CONTMAT'
8998       include 'COMMON.CORRMAT'
8999       include 'COMMON.TORSION'
9000       include 'COMMON.VAR'
9001       include 'COMMON.GEO'
9002       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9003       logical swap
9004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9005 C                                                                              C
9006 C      Parallel       Antiparallel                                             C
9007 C                                                                              C
9008 C          o             o                                                     C
9009 C         /l\   /   \   /j\                                                    C
9010 C        /   \ /     \ /   \                                                   C
9011 C       /| o |o       o| o |\                                                  C
9012 C       j|/k\|  /      |/k\|l /                                                C
9013 C        /   \ /       /   \ /                                                 C
9014 C       /     o       /     o                                                  C
9015 C       i             i                                                        C
9016 C                                                                              C
9017 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9018 C
9019 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9020 C           energy moment and not to the cluster cumulant.
9021       iti=itortyp(itype(i))
9022       if (j.lt.nres-1) then
9023         itj1=itype2loc(itype(j+1))
9024       else
9025         itj1=nloctyp
9026       endif
9027       itk=itype2loc(itype(k))
9028       itk1=itype2loc(itype(k+1))
9029       if (l.lt.nres-1) then
9030         itl1=itype2loc(itype(l+1))
9031       else
9032         itl1=nloctyp
9033       endif
9034 #ifdef MOMENT
9035       s1=dip(4,jj,i)*dip(4,kk,k)
9036 #endif
9037       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9038       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9039       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9040       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9041       call transpose2(EE(1,1,k),auxmat(1,1))
9042       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9043       vv(1)=pizda(1,1)+pizda(2,2)
9044       vv(2)=pizda(2,1)-pizda(1,2)
9045       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9046 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9047 cd     & "sum",-(s2+s3+s4)
9048 #ifdef MOMENT
9049       eello6_graph3=-(s1+s2+s3+s4)
9050 #else
9051       eello6_graph3=-(s2+s3+s4)
9052 #endif
9053 c      eello6_graph3=-s4
9054 C Derivatives in gamma(k-1)
9055       if (calc_grad) then
9056       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9057       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9058       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9059       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9060 C Derivatives in gamma(l-1)
9061       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9062       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9063       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9064       vv(1)=pizda(1,1)+pizda(2,2)
9065       vv(2)=pizda(2,1)-pizda(1,2)
9066       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9067       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9068 C Cartesian derivatives.
9069       do iii=1,2
9070         do kkk=1,5
9071           do lll=1,3
9072 #ifdef MOMENT
9073             if (iii.eq.1) then
9074               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9075             else
9076               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9077             endif
9078 #endif
9079             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9080      &        auxvec(1))
9081             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9082             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9083      &        auxvec(1))
9084             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9085             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9086      &        pizda(1,1))
9087             vv(1)=pizda(1,1)+pizda(2,2)
9088             vv(2)=pizda(2,1)-pizda(1,2)
9089             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9090 #ifdef MOMENT
9091             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9092 #else
9093             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9094 #endif
9095             if (swap) then
9096               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9097             else
9098               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9099             endif
9100 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9101           enddo
9102         enddo
9103       enddo
9104       endif ! calc_grad
9105       return
9106       end
9107 c----------------------------------------------------------------------------
9108       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9109       implicit real*8 (a-h,o-z)
9110       include 'DIMENSIONS'
9111       include 'DIMENSIONS.ZSCOPT'
9112       include 'COMMON.IOUNITS'
9113       include 'COMMON.CHAIN'
9114       include 'COMMON.DERIV'
9115       include 'COMMON.INTERACT'
9116       include 'COMMON.CONTACTS'
9117       include 'COMMON.CONTMAT'
9118       include 'COMMON.CORRMAT'
9119       include 'COMMON.TORSION'
9120       include 'COMMON.VAR'
9121       include 'COMMON.GEO'
9122       include 'COMMON.FFIELD'
9123       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9124      & auxvec1(2),auxmat1(2,2)
9125       logical swap
9126 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9127 C                                                                              C
9128 C      Parallel       Antiparallel                                             C
9129 C                                                                              C
9130 C          o             o                                                     C
9131 C         /l\   /   \   /j\                                                    C
9132 C        /   \ /     \ /   \                                                   C
9133 C       /| o |o       o| o |\                                                  C
9134 C     \ j|/k\|      \  |/k\|l                                                  C
9135 C      \ /   \       \ /   \                                                   C
9136 C       o     \       o     \                                                  C
9137 C       i             i                                                        C
9138 C                                                                              C
9139 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9140 C
9141 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9142 C           energy moment and not to the cluster cumulant.
9143 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9144       iti=itype2loc(itype(i))
9145       itj=itype2loc(itype(j))
9146       if (j.lt.nres-1) then
9147         itj1=itype2loc(itype(j+1))
9148       else
9149         itj1=nloctyp
9150       endif
9151       itk=itype2loc(itype(k))
9152       if (k.lt.nres-1) then
9153         itk1=itype2loc(itype(k+1))
9154       else
9155         itk1=nloctyp
9156       endif
9157       itl=itype2loc(itype(l))
9158       if (l.lt.nres-1) then
9159         itl1=itype2loc(itype(l+1))
9160       else
9161         itl1=nloctyp
9162       endif
9163 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9164 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9165 cd     & ' itl',itl,' itl1',itl1
9166 #ifdef MOMENT
9167       if (imat.eq.1) then
9168         s1=dip(3,jj,i)*dip(3,kk,k)
9169       else
9170         s1=dip(2,jj,j)*dip(2,kk,l)
9171       endif
9172 #endif
9173       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9174       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9175       if (j.eq.l+1) then
9176         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9177         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9178       else
9179         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9180         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9181       endif
9182       call transpose2(EUg(1,1,k),auxmat(1,1))
9183       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9184       vv(1)=pizda(1,1)-pizda(2,2)
9185       vv(2)=pizda(2,1)+pizda(1,2)
9186       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9187 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9188 #ifdef MOMENT
9189       eello6_graph4=-(s1+s2+s3+s4)
9190 #else
9191       eello6_graph4=-(s2+s3+s4)
9192 #endif
9193 C Derivatives in gamma(i-1)
9194       if (calc_grad) then
9195       if (i.gt.1) then
9196 #ifdef MOMENT
9197         if (imat.eq.1) then
9198           s1=dipderg(2,jj,i)*dip(3,kk,k)
9199         else
9200           s1=dipderg(4,jj,j)*dip(2,kk,l)
9201         endif
9202 #endif
9203         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9204         if (j.eq.l+1) then
9205           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9206           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9207         else
9208           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9209           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9210         endif
9211         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9212         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9213 cd          write (2,*) 'turn6 derivatives'
9214 #ifdef MOMENT
9215           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9216 #else
9217           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9218 #endif
9219         else
9220 #ifdef MOMENT
9221           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9222 #else
9223           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9224 #endif
9225         endif
9226       endif
9227 C Derivatives in gamma(k-1)
9228 #ifdef MOMENT
9229       if (imat.eq.1) then
9230         s1=dip(3,jj,i)*dipderg(2,kk,k)
9231       else
9232         s1=dip(2,jj,j)*dipderg(4,kk,l)
9233       endif
9234 #endif
9235       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9236       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9237       if (j.eq.l+1) then
9238         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9239         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9240       else
9241         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9242         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9243       endif
9244       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9245       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9246       vv(1)=pizda(1,1)-pizda(2,2)
9247       vv(2)=pizda(2,1)+pizda(1,2)
9248       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9249       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9250 #ifdef MOMENT
9251         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9252 #else
9253         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9254 #endif
9255       else
9256 #ifdef MOMENT
9257         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9258 #else
9259         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9260 #endif
9261       endif
9262 C Derivatives in gamma(j-1) or gamma(l-1)
9263       if (l.eq.j+1 .and. l.gt.1) then
9264         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9265         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9266         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9267         vv(1)=pizda(1,1)-pizda(2,2)
9268         vv(2)=pizda(2,1)+pizda(1,2)
9269         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9270         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9271       else if (j.gt.1) then
9272         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9273         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9274         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9275         vv(1)=pizda(1,1)-pizda(2,2)
9276         vv(2)=pizda(2,1)+pizda(1,2)
9277         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9278         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9279           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9280         else
9281           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9282         endif
9283       endif
9284 C Cartesian derivatives.
9285       do iii=1,2
9286         do kkk=1,5
9287           do lll=1,3
9288 #ifdef MOMENT
9289             if (iii.eq.1) then
9290               if (imat.eq.1) then
9291                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9292               else
9293                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9294               endif
9295             else
9296               if (imat.eq.1) then
9297                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9298               else
9299                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9300               endif
9301             endif
9302 #endif
9303             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9304      &        auxvec(1))
9305             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9306             if (j.eq.l+1) then
9307               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9308      &          b1(1,j+1),auxvec(1))
9309               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9310             else
9311               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9312      &          b1(1,l+1),auxvec(1))
9313               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9314             endif
9315             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9316      &        pizda(1,1))
9317             vv(1)=pizda(1,1)-pizda(2,2)
9318             vv(2)=pizda(2,1)+pizda(1,2)
9319             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9320             if (swap) then
9321               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9322 #ifdef MOMENT
9323                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9324      &             -(s1+s2+s4)
9325 #else
9326                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9327      &             -(s2+s4)
9328 #endif
9329                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9330               else
9331 #ifdef MOMENT
9332                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9333 #else
9334                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9335 #endif
9336                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9337               endif
9338             else
9339 #ifdef MOMENT
9340               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9341 #else
9342               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9343 #endif
9344               if (l.eq.j+1) then
9345                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9346               else
9347                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9348               endif
9349             endif
9350           enddo
9351         enddo
9352       enddo
9353       endif ! calc_grad
9354       return
9355       end
9356 c----------------------------------------------------------------------------
9357       double precision function eello_turn6(i,jj,kk)
9358       implicit real*8 (a-h,o-z)
9359       include 'DIMENSIONS'
9360       include 'DIMENSIONS.ZSCOPT'
9361       include 'COMMON.IOUNITS'
9362       include 'COMMON.CHAIN'
9363       include 'COMMON.DERIV'
9364       include 'COMMON.INTERACT'
9365       include 'COMMON.CONTACTS'
9366       include 'COMMON.CONTMAT'
9367       include 'COMMON.CORRMAT'
9368       include 'COMMON.TORSION'
9369       include 'COMMON.VAR'
9370       include 'COMMON.GEO'
9371       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9372      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9373      &  ggg1(3),ggg2(3)
9374       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9375      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9376 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9377 C           the respective energy moment and not to the cluster cumulant.
9378       s1=0.0d0
9379       s8=0.0d0
9380       s13=0.0d0
9381 c
9382       eello_turn6=0.0d0
9383       j=i+4
9384       k=i+1
9385       l=i+3
9386       iti=itype2loc(itype(i))
9387       itk=itype2loc(itype(k))
9388       itk1=itype2loc(itype(k+1))
9389       itl=itype2loc(itype(l))
9390       itj=itype2loc(itype(j))
9391 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9392 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9393 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9394 cd        eello6=0.0d0
9395 cd        return
9396 cd      endif
9397 cd      write (iout,*)
9398 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9399 cd     &   ' and',k,l
9400 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9401       do iii=1,2
9402         do kkk=1,5
9403           do lll=1,3
9404             derx_turn(lll,kkk,iii)=0.0d0
9405           enddo
9406         enddo
9407       enddo
9408 cd      eij=1.0d0
9409 cd      ekl=1.0d0
9410 cd      ekont=1.0d0
9411       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9412 cd      eello6_5=0.0d0
9413 cd      write (2,*) 'eello6_5',eello6_5
9414 #ifdef MOMENT
9415       call transpose2(AEA(1,1,1),auxmat(1,1))
9416       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9417       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9418       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9419 #endif
9420       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9421       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9422       s2 = scalar2(b1(1,k),vtemp1(1))
9423 #ifdef MOMENT
9424       call transpose2(AEA(1,1,2),atemp(1,1))
9425       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9426       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9427       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9428 #endif
9429       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9430       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9431       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9432 #ifdef MOMENT
9433       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9434       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9435       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9436       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9437       ss13 = scalar2(b1(1,k),vtemp4(1))
9438       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9439 #endif
9440 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9441 c      s1=0.0d0
9442 c      s2=0.0d0
9443 c      s8=0.0d0
9444 c      s12=0.0d0
9445 c      s13=0.0d0
9446       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9447 C Derivatives in gamma(i+2)
9448       if (calc_grad) then
9449       s1d =0.0d0
9450       s8d =0.0d0
9451 #ifdef MOMENT
9452       call transpose2(AEA(1,1,1),auxmatd(1,1))
9453       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9454       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9455       call transpose2(AEAderg(1,1,2),atempd(1,1))
9456       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9457       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9458 #endif
9459       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9460       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9461       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9462 c      s1d=0.0d0
9463 c      s2d=0.0d0
9464 c      s8d=0.0d0
9465 c      s12d=0.0d0
9466 c      s13d=0.0d0
9467       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9468 C Derivatives in gamma(i+3)
9469 #ifdef MOMENT
9470       call transpose2(AEA(1,1,1),auxmatd(1,1))
9471       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9472       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9473       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9474 #endif
9475       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9476       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9477       s2d = scalar2(b1(1,k),vtemp1d(1))
9478 #ifdef MOMENT
9479       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9480       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9481 #endif
9482       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9483 #ifdef MOMENT
9484       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9485       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9486       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9487 #endif
9488 c      s1d=0.0d0
9489 c      s2d=0.0d0
9490 c      s8d=0.0d0
9491 c      s12d=0.0d0
9492 c      s13d=0.0d0
9493 #ifdef MOMENT
9494       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9495      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9496 #else
9497       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9498      &               -0.5d0*ekont*(s2d+s12d)
9499 #endif
9500 C Derivatives in gamma(i+4)
9501       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9502       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9503       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9504 #ifdef MOMENT
9505       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9506       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9507       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9508 #endif
9509 c      s1d=0.0d0
9510 c      s2d=0.0d0
9511 c      s8d=0.0d0
9512 C      s12d=0.0d0
9513 c      s13d=0.0d0
9514 #ifdef MOMENT
9515       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9516 #else
9517       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9518 #endif
9519 C Derivatives in gamma(i+5)
9520 #ifdef MOMENT
9521       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9522       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9523       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9524 #endif
9525       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9526       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9527       s2d = scalar2(b1(1,k),vtemp1d(1))
9528 #ifdef MOMENT
9529       call transpose2(AEA(1,1,2),atempd(1,1))
9530       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9531       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9532 #endif
9533       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9534       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9535 #ifdef MOMENT
9536       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9537       ss13d = scalar2(b1(1,k),vtemp4d(1))
9538       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9539 #endif
9540 c      s1d=0.0d0
9541 c      s2d=0.0d0
9542 c      s8d=0.0d0
9543 c      s12d=0.0d0
9544 c      s13d=0.0d0
9545 #ifdef MOMENT
9546       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9547      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9548 #else
9549       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9550      &               -0.5d0*ekont*(s2d+s12d)
9551 #endif
9552 C Cartesian derivatives
9553       do iii=1,2
9554         do kkk=1,5
9555           do lll=1,3
9556 #ifdef MOMENT
9557             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9558             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9559             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9560 #endif
9561             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9562             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9563      &          vtemp1d(1))
9564             s2d = scalar2(b1(1,k),vtemp1d(1))
9565 #ifdef MOMENT
9566             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9567             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9568             s8d = -(atempd(1,1)+atempd(2,2))*
9569      &           scalar2(cc(1,1,l),vtemp2(1))
9570 #endif
9571             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9572      &           auxmatd(1,1))
9573             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9574             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9575 c      s1d=0.0d0
9576 c      s2d=0.0d0
9577 c      s8d=0.0d0
9578 c      s12d=0.0d0
9579 c      s13d=0.0d0
9580 #ifdef MOMENT
9581             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9582      &        - 0.5d0*(s1d+s2d)
9583 #else
9584             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9585      &        - 0.5d0*s2d
9586 #endif
9587 #ifdef MOMENT
9588             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9589      &        - 0.5d0*(s8d+s12d)
9590 #else
9591             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9592      &        - 0.5d0*s12d
9593 #endif
9594           enddo
9595         enddo
9596       enddo
9597 #ifdef MOMENT
9598       do kkk=1,5
9599         do lll=1,3
9600           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9601      &      achuj_tempd(1,1))
9602           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9603           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9604           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9605           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9606           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9607      &      vtemp4d(1))
9608           ss13d = scalar2(b1(1,k),vtemp4d(1))
9609           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9610           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9611         enddo
9612       enddo
9613 #endif
9614 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9615 cd     &  16*eel_turn6_num
9616 cd      goto 1112
9617       if (j.lt.nres-1) then
9618         j1=j+1
9619         j2=j-1
9620       else
9621         j1=j-1
9622         j2=j-2
9623       endif
9624       if (l.lt.nres-1) then
9625         l1=l+1
9626         l2=l-1
9627       else
9628         l1=l-1
9629         l2=l-2
9630       endif
9631       do ll=1,3
9632 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9633 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9634 cgrad        ghalf=0.5d0*ggg1(ll)
9635 cd        ghalf=0.0d0
9636         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9637         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9638         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9639      &    +ekont*derx_turn(ll,2,1)
9640         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9641         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9642      &    +ekont*derx_turn(ll,4,1)
9643         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9644         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9645         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9646 cgrad        ghalf=0.5d0*ggg2(ll)
9647 cd        ghalf=0.0d0
9648         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9649      &    +ekont*derx_turn(ll,2,2)
9650         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9651         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9652      &    +ekont*derx_turn(ll,4,2)
9653         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9654         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9655         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9656       enddo
9657 cd      goto 1112
9658 cgrad      do m=i+1,j-1
9659 cgrad        do ll=1,3
9660 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9661 cgrad        enddo
9662 cgrad      enddo
9663 cgrad      do m=k+1,l-1
9664 cgrad        do ll=1,3
9665 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9666 cgrad        enddo
9667 cgrad      enddo
9668 cgrad1112  continue
9669 cgrad      do m=i+2,j2
9670 cgrad        do ll=1,3
9671 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9672 cgrad        enddo
9673 cgrad      enddo
9674 cgrad      do m=k+2,l2
9675 cgrad        do ll=1,3
9676 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9677 cgrad        enddo
9678 cgrad      enddo
9679 cd      do iii=1,nres-3
9680 cd        write (2,*) iii,g_corr6_loc(iii)
9681 cd      enddo
9682       endif ! calc_grad
9683       eello_turn6=ekont*eel_turn6
9684 cd      write (2,*) 'ekont',ekont
9685 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9686       return
9687       end
9688 #endif
9689 crc-------------------------------------------------
9690 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9691       subroutine Eliptransfer(eliptran)
9692       implicit real*8 (a-h,o-z)
9693       include 'DIMENSIONS'
9694       include 'DIMENSIONS.ZSCOPT'
9695       include 'COMMON.GEO'
9696       include 'COMMON.VAR'
9697       include 'COMMON.LOCAL'
9698       include 'COMMON.CHAIN'
9699       include 'COMMON.DERIV'
9700       include 'COMMON.INTERACT'
9701       include 'COMMON.IOUNITS'
9702       include 'COMMON.CALC'
9703       include 'COMMON.CONTROL'
9704       include 'COMMON.SPLITELE'
9705       include 'COMMON.SBRIDGE'
9706 C this is done by Adasko
9707 C      print *,"wchodze"
9708 C structure of box:
9709 C      water
9710 C--bordliptop-- buffore starts
9711 C--bufliptop--- here true lipid starts
9712 C      lipid
9713 C--buflipbot--- lipid ends buffore starts
9714 C--bordlipbot--buffore ends
9715       eliptran=0.0
9716       do i=1,nres
9717 C       do i=1,1
9718         if (itype(i).eq.ntyp1) cycle
9719
9720         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9721         if (positi.le.0) positi=positi+boxzsize
9722 C        print *,i
9723 C first for peptide groups
9724 c for each residue check if it is in lipid or lipid water border area
9725        if ((positi.gt.bordlipbot)
9726      &.and.(positi.lt.bordliptop)) then
9727 C the energy transfer exist
9728         if (positi.lt.buflipbot) then
9729 C what fraction I am in
9730          fracinbuf=1.0d0-
9731      &        ((positi-bordlipbot)/lipbufthick)
9732 C lipbufthick is thickenes of lipid buffore
9733          sslip=sscalelip(fracinbuf)
9734          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9735          eliptran=eliptran+sslip*pepliptran
9736          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9737          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9738 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9739         elseif (positi.gt.bufliptop) then
9740          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9741          sslip=sscalelip(fracinbuf)
9742          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9743          eliptran=eliptran+sslip*pepliptran
9744          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9745          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9746 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9747 C          print *, "doing sscalefor top part"
9748 C         print *,i,sslip,fracinbuf,ssgradlip
9749         else
9750          eliptran=eliptran+pepliptran
9751 C         print *,"I am in true lipid"
9752         endif
9753 C       else
9754 C       eliptran=elpitran+0.0 ! I am in water
9755        endif
9756        enddo
9757 C       print *, "nic nie bylo w lipidzie?"
9758 C now multiply all by the peptide group transfer factor
9759 C       eliptran=eliptran*pepliptran
9760 C now the same for side chains
9761 CV       do i=1,1
9762        do i=1,nres
9763         if (itype(i).eq.ntyp1) cycle
9764         positi=(mod(c(3,i+nres),boxzsize))
9765         if (positi.le.0) positi=positi+boxzsize
9766 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9767 c for each residue check if it is in lipid or lipid water border area
9768 C       respos=mod(c(3,i+nres),boxzsize)
9769 C       print *,positi,bordlipbot,buflipbot
9770        if ((positi.gt.bordlipbot)
9771      & .and.(positi.lt.bordliptop)) then
9772 C the energy transfer exist
9773         if (positi.lt.buflipbot) then
9774          fracinbuf=1.0d0-
9775      &     ((positi-bordlipbot)/lipbufthick)
9776 C lipbufthick is thickenes of lipid buffore
9777          sslip=sscalelip(fracinbuf)
9778          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9779          eliptran=eliptran+sslip*liptranene(itype(i))
9780          gliptranx(3,i)=gliptranx(3,i)
9781      &+ssgradlip*liptranene(itype(i))
9782          gliptranc(3,i-1)= gliptranc(3,i-1)
9783      &+ssgradlip*liptranene(itype(i))
9784 C         print *,"doing sccale for lower part"
9785         elseif (positi.gt.bufliptop) then
9786          fracinbuf=1.0d0-
9787      &((bordliptop-positi)/lipbufthick)
9788          sslip=sscalelip(fracinbuf)
9789          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9790          eliptran=eliptran+sslip*liptranene(itype(i))
9791          gliptranx(3,i)=gliptranx(3,i)
9792      &+ssgradlip*liptranene(itype(i))
9793          gliptranc(3,i-1)= gliptranc(3,i-1)
9794      &+ssgradlip*liptranene(itype(i))
9795 C          print *, "doing sscalefor top part",sslip,fracinbuf
9796         else
9797          eliptran=eliptran+liptranene(itype(i))
9798 C         print *,"I am in true lipid"
9799         endif
9800         endif ! if in lipid or buffor
9801 C       else
9802 C       eliptran=elpitran+0.0 ! I am in water
9803        enddo
9804        return
9805        end
9806
9807
9808 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9809
9810       SUBROUTINE MATVEC2(A1,V1,V2)
9811       implicit real*8 (a-h,o-z)
9812       include 'DIMENSIONS'
9813       DIMENSION A1(2,2),V1(2),V2(2)
9814 c      DO 1 I=1,2
9815 c        VI=0.0
9816 c        DO 3 K=1,2
9817 c    3     VI=VI+A1(I,K)*V1(K)
9818 c        Vaux(I)=VI
9819 c    1 CONTINUE
9820
9821       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9822       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9823
9824       v2(1)=vaux1
9825       v2(2)=vaux2
9826       END
9827 C---------------------------------------
9828       SUBROUTINE MATMAT2(A1,A2,A3)
9829       implicit real*8 (a-h,o-z)
9830       include 'DIMENSIONS'
9831       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9832 c      DIMENSION AI3(2,2)
9833 c        DO  J=1,2
9834 c          A3IJ=0.0
9835 c          DO K=1,2
9836 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9837 c          enddo
9838 c          A3(I,J)=A3IJ
9839 c       enddo
9840 c      enddo
9841
9842       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9843       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9844       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9845       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9846
9847       A3(1,1)=AI3_11
9848       A3(2,1)=AI3_21
9849       A3(1,2)=AI3_12
9850       A3(2,2)=AI3_22
9851       END
9852
9853 c-------------------------------------------------------------------------
9854       double precision function scalar2(u,v)
9855       implicit none
9856       double precision u(2),v(2)
9857       double precision sc
9858       integer i
9859       scalar2=u(1)*v(1)+u(2)*v(2)
9860       return
9861       end
9862
9863 C-----------------------------------------------------------------------------
9864
9865       subroutine transpose2(a,at)
9866       implicit none
9867       double precision a(2,2),at(2,2)
9868       at(1,1)=a(1,1)
9869       at(1,2)=a(2,1)
9870       at(2,1)=a(1,2)
9871       at(2,2)=a(2,2)
9872       return
9873       end
9874 c--------------------------------------------------------------------------
9875       subroutine transpose(n,a,at)
9876       implicit none
9877       integer n,i,j
9878       double precision a(n,n),at(n,n)
9879       do i=1,n
9880         do j=1,n
9881           at(j,i)=a(i,j)
9882         enddo
9883       enddo
9884       return
9885       end
9886 C---------------------------------------------------------------------------
9887       subroutine prodmat3(a1,a2,kk,transp,prod)
9888       implicit none
9889       integer i,j
9890       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9891       logical transp
9892 crc      double precision auxmat(2,2),prod_(2,2)
9893
9894       if (transp) then
9895 crc        call transpose2(kk(1,1),auxmat(1,1))
9896 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9897 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9898
9899            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9900      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9901            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9902      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9903            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9904      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9905            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9906      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9907
9908       else
9909 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9910 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9911
9912            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9913      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9914            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9915      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9916            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9917      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9918            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9919      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9920
9921       endif
9922 c      call transpose2(a2(1,1),a2t(1,1))
9923
9924 crc      print *,transp
9925 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9926 crc      print *,((prod(i,j),i=1,2),j=1,2)
9927
9928       return
9929       end
9930 C-----------------------------------------------------------------------------
9931       double precision function scalar(u,v)
9932       implicit none
9933       double precision u(3),v(3)
9934       double precision sc
9935       integer i
9936       sc=0.0d0
9937       do i=1,3
9938         sc=sc+u(i)*v(i)
9939       enddo
9940       scalar=sc
9941       return
9942       end
9943 C-----------------------------------------------------------------------
9944       double precision function sscale(r)
9945       double precision r,gamm
9946       include "COMMON.SPLITELE"
9947       if(r.lt.r_cut-rlamb) then
9948         sscale=1.0d0
9949       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9950         gamm=(r-(r_cut-rlamb))/rlamb
9951         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9952       else
9953         sscale=0d0
9954       endif
9955       return
9956       end
9957 C-----------------------------------------------------------------------
9958 C-----------------------------------------------------------------------
9959       double precision function sscagrad(r)
9960       double precision r,gamm
9961       include "COMMON.SPLITELE"
9962       if(r.lt.r_cut-rlamb) then
9963         sscagrad=0.0d0
9964       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9965         gamm=(r-(r_cut-rlamb))/rlamb
9966         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9967       else
9968         sscagrad=0.0d0
9969       endif
9970       return
9971       end
9972 C-----------------------------------------------------------------------
9973 C-----------------------------------------------------------------------
9974       double precision function sscalelip(r)
9975       double precision r,gamm
9976       include "COMMON.SPLITELE"
9977 C      if(r.lt.r_cut-rlamb) then
9978 C        sscale=1.0d0
9979 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9980 C        gamm=(r-(r_cut-rlamb))/rlamb
9981         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9982 C      else
9983 C        sscale=0d0
9984 C      endif
9985       return
9986       end
9987 C-----------------------------------------------------------------------
9988       double precision function sscagradlip(r)
9989       double precision r,gamm
9990       include "COMMON.SPLITELE"
9991 C     if(r.lt.r_cut-rlamb) then
9992 C        sscagrad=0.0d0
9993 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9994 C        gamm=(r-(r_cut-rlamb))/rlamb
9995         sscagradlip=r*(6*r-6.0d0)
9996 C      else
9997 C        sscagrad=0.0d0
9998 C      endif
9999       return
10000       end
10001
10002 C-----------------------------------------------------------------------
10003        subroutine set_shield_fac
10004       implicit real*8 (a-h,o-z)
10005       include 'DIMENSIONS'
10006       include 'DIMENSIONS.ZSCOPT'
10007       include 'COMMON.CHAIN'
10008       include 'COMMON.DERIV'
10009       include 'COMMON.IOUNITS'
10010       include 'COMMON.SHIELD'
10011       include 'COMMON.INTERACT'
10012 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10013       double precision div77_81/0.974996043d0/,
10014      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10015
10016 C the vector between center of side_chain and peptide group
10017        double precision pep_side(3),long,side_calf(3),
10018      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10019      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10020 C the line belowe needs to be changed for FGPROC>1
10021       do i=1,nres-1
10022       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10023       ishield_list(i)=0
10024 Cif there two consequtive dummy atoms there is no peptide group between them
10025 C the line below has to be changed for FGPROC>1
10026       VolumeTotal=0.0
10027       do k=1,nres
10028        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10029        dist_pep_side=0.0
10030        dist_side_calf=0.0
10031        do j=1,3
10032 C first lets set vector conecting the ithe side-chain with kth side-chain
10033       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10034 C      pep_side(j)=2.0d0
10035 C and vector conecting the side-chain with its proper calfa
10036       side_calf(j)=c(j,k+nres)-c(j,k)
10037 C      side_calf(j)=2.0d0
10038       pept_group(j)=c(j,i)-c(j,i+1)
10039 C lets have their lenght
10040       dist_pep_side=pep_side(j)**2+dist_pep_side
10041       dist_side_calf=dist_side_calf+side_calf(j)**2
10042       dist_pept_group=dist_pept_group+pept_group(j)**2
10043       enddo
10044        dist_pep_side=dsqrt(dist_pep_side)
10045        dist_pept_group=dsqrt(dist_pept_group)
10046        dist_side_calf=dsqrt(dist_side_calf)
10047       do j=1,3
10048         pep_side_norm(j)=pep_side(j)/dist_pep_side
10049         side_calf_norm(j)=dist_side_calf
10050       enddo
10051 C now sscale fraction
10052        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10053 C       print *,buff_shield,"buff"
10054 C now sscale
10055         if (sh_frac_dist.le.0.0) cycle
10056 C If we reach here it means that this side chain reaches the shielding sphere
10057 C Lets add him to the list for gradient
10058         ishield_list(i)=ishield_list(i)+1
10059 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10060 C this list is essential otherwise problem would be O3
10061         shield_list(ishield_list(i),i)=k
10062 C Lets have the sscale value
10063         if (sh_frac_dist.gt.1.0) then
10064          scale_fac_dist=1.0d0
10065          do j=1,3
10066          sh_frac_dist_grad(j)=0.0d0
10067          enddo
10068         else
10069          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10070      &                   *(2.0*sh_frac_dist-3.0d0)
10071          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10072      &                  /dist_pep_side/buff_shield*0.5
10073 C remember for the final gradient multiply sh_frac_dist_grad(j)
10074 C for side_chain by factor -2 !
10075          do j=1,3
10076          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10077 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10078 C     &                    sh_frac_dist_grad(j)
10079          enddo
10080         endif
10081 C        if ((i.eq.3).and.(k.eq.2)) then
10082 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10083 C     & ,"TU"
10084 C        endif
10085
10086 C this is what is now we have the distance scaling now volume...
10087       short=short_r_sidechain(itype(k))
10088       long=long_r_sidechain(itype(k))
10089       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10090 C now costhet_grad
10091 C       costhet=0.0d0
10092        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10093 C       costhet_fac=0.0d0
10094        do j=1,3
10095          costhet_grad(j)=costhet_fac*pep_side(j)
10096        enddo
10097 C remember for the final gradient multiply costhet_grad(j)
10098 C for side_chain by factor -2 !
10099 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10100 C pep_side0pept_group is vector multiplication
10101       pep_side0pept_group=0.0
10102       do j=1,3
10103       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10104       enddo
10105       cosalfa=(pep_side0pept_group/
10106      & (dist_pep_side*dist_side_calf))
10107       fac_alfa_sin=1.0-cosalfa**2
10108       fac_alfa_sin=dsqrt(fac_alfa_sin)
10109       rkprim=fac_alfa_sin*(long-short)+short
10110 C now costhet_grad
10111        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10112        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10113
10114        do j=1,3
10115          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10116      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10117      &*(long-short)/fac_alfa_sin*cosalfa/
10118      &((dist_pep_side*dist_side_calf))*
10119      &((side_calf(j))-cosalfa*
10120      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10121
10122         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10123      &*(long-short)/fac_alfa_sin*cosalfa
10124      &/((dist_pep_side*dist_side_calf))*
10125      &(pep_side(j)-
10126      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10127        enddo
10128
10129       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10130      &                    /VSolvSphere_div
10131      &                    *wshield
10132 C now the gradient...
10133 C grad_shield is gradient of Calfa for peptide groups
10134 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10135 C     &               costhet,cosphi
10136 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10137 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10138       do j=1,3
10139       grad_shield(j,i)=grad_shield(j,i)
10140 C gradient po skalowaniu
10141      &                +(sh_frac_dist_grad(j)
10142 C  gradient po costhet
10143      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10144      &-scale_fac_dist*(cosphi_grad_long(j))
10145      &/(1.0-cosphi) )*div77_81
10146      &*VofOverlap
10147 C grad_shield_side is Cbeta sidechain gradient
10148       grad_shield_side(j,ishield_list(i),i)=
10149      &        (sh_frac_dist_grad(j)*(-2.0d0)
10150      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10151      &       +scale_fac_dist*(cosphi_grad_long(j))
10152      &        *2.0d0/(1.0-cosphi))
10153      &        *div77_81*VofOverlap
10154
10155        grad_shield_loc(j,ishield_list(i),i)=
10156      &   scale_fac_dist*cosphi_grad_loc(j)
10157      &        *2.0d0/(1.0-cosphi)
10158      &        *div77_81*VofOverlap
10159       enddo
10160       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10161       enddo
10162       fac_shield(i)=VolumeTotal*div77_81+div4_81
10163 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10164       enddo
10165       return
10166       end
10167 C--------------------------------------------------------------------------
10168 C first for shielding is setting of function of side-chains
10169        subroutine set_shield_fac2
10170       implicit real*8 (a-h,o-z)
10171       include 'DIMENSIONS'
10172       include 'DIMENSIONS.ZSCOPT'
10173       include 'COMMON.CHAIN'
10174       include 'COMMON.DERIV'
10175       include 'COMMON.IOUNITS'
10176       include 'COMMON.SHIELD'
10177       include 'COMMON.INTERACT'
10178 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10179       double precision div77_81/0.974996043d0/,
10180      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10181
10182 C the vector between center of side_chain and peptide group
10183        double precision pep_side(3),long,side_calf(3),
10184      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10185      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10186 C the line belowe needs to be changed for FGPROC>1
10187       do i=1,nres-1
10188       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10189       ishield_list(i)=0
10190 Cif there two consequtive dummy atoms there is no peptide group between them
10191 C the line below has to be changed for FGPROC>1
10192       VolumeTotal=0.0
10193       do k=1,nres
10194        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10195        dist_pep_side=0.0
10196        dist_side_calf=0.0
10197        do j=1,3
10198 C first lets set vector conecting the ithe side-chain with kth side-chain
10199       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10200 C      pep_side(j)=2.0d0
10201 C and vector conecting the side-chain with its proper calfa
10202       side_calf(j)=c(j,k+nres)-c(j,k)
10203 C      side_calf(j)=2.0d0
10204       pept_group(j)=c(j,i)-c(j,i+1)
10205 C lets have their lenght
10206       dist_pep_side=pep_side(j)**2+dist_pep_side
10207       dist_side_calf=dist_side_calf+side_calf(j)**2
10208       dist_pept_group=dist_pept_group+pept_group(j)**2
10209       enddo
10210        dist_pep_side=dsqrt(dist_pep_side)
10211        dist_pept_group=dsqrt(dist_pept_group)
10212        dist_side_calf=dsqrt(dist_side_calf)
10213       do j=1,3
10214         pep_side_norm(j)=pep_side(j)/dist_pep_side
10215         side_calf_norm(j)=dist_side_calf
10216       enddo
10217 C now sscale fraction
10218        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10219 C       print *,buff_shield,"buff"
10220 C now sscale
10221         if (sh_frac_dist.le.0.0) cycle
10222 C If we reach here it means that this side chain reaches the shielding sphere
10223 C Lets add him to the list for gradient
10224         ishield_list(i)=ishield_list(i)+1
10225 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10226 C this list is essential otherwise problem would be O3
10227         shield_list(ishield_list(i),i)=k
10228 C Lets have the sscale value
10229         if (sh_frac_dist.gt.1.0) then
10230          scale_fac_dist=1.0d0
10231          do j=1,3
10232          sh_frac_dist_grad(j)=0.0d0
10233          enddo
10234         else
10235          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10236      &                   *(2.0d0*sh_frac_dist-3.0d0)
10237          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10238      &                  /dist_pep_side/buff_shield*0.5d0
10239 C remember for the final gradient multiply sh_frac_dist_grad(j)
10240 C for side_chain by factor -2 !
10241          do j=1,3
10242          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10243 C         sh_frac_dist_grad(j)=0.0d0
10244 C         scale_fac_dist=1.0d0
10245 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10246 C     &                    sh_frac_dist_grad(j)
10247          enddo
10248         endif
10249 C this is what is now we have the distance scaling now volume...
10250       short=short_r_sidechain(itype(k))
10251       long=long_r_sidechain(itype(k))
10252       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10253       sinthet=short/dist_pep_side*costhet
10254 C now costhet_grad
10255 C       costhet=0.6d0
10256 C       sinthet=0.8
10257        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10258 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10259 C     &             -short/dist_pep_side**2/costhet)
10260 C       costhet_fac=0.0d0
10261        do j=1,3
10262          costhet_grad(j)=costhet_fac*pep_side(j)
10263        enddo
10264 C remember for the final gradient multiply costhet_grad(j)
10265 C for side_chain by factor -2 !
10266 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10267 C pep_side0pept_group is vector multiplication
10268       pep_side0pept_group=0.0d0
10269       do j=1,3
10270       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10271       enddo
10272       cosalfa=(pep_side0pept_group/
10273      & (dist_pep_side*dist_side_calf))
10274       fac_alfa_sin=1.0d0-cosalfa**2
10275       fac_alfa_sin=dsqrt(fac_alfa_sin)
10276       rkprim=fac_alfa_sin*(long-short)+short
10277 C      rkprim=short
10278
10279 C now costhet_grad
10280        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10281 C       cosphi=0.6
10282        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10283        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10284      &      dist_pep_side**2)
10285 C       sinphi=0.8
10286        do j=1,3
10287          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10288      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10289      &*(long-short)/fac_alfa_sin*cosalfa/
10290      &((dist_pep_side*dist_side_calf))*
10291      &((side_calf(j))-cosalfa*
10292      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10293 C       cosphi_grad_long(j)=0.0d0
10294         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10295      &*(long-short)/fac_alfa_sin*cosalfa
10296      &/((dist_pep_side*dist_side_calf))*
10297      &(pep_side(j)-
10298      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10299 C       cosphi_grad_loc(j)=0.0d0
10300        enddo
10301 C      print *,sinphi,sinthet
10302       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10303      &                    /VSolvSphere_div
10304 C     &                    *wshield
10305 C now the gradient...
10306       do j=1,3
10307       grad_shield(j,i)=grad_shield(j,i)
10308 C gradient po skalowaniu
10309      &                +(sh_frac_dist_grad(j)*VofOverlap
10310 C  gradient po costhet
10311      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10312      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10313      &       sinphi/sinthet*costhet*costhet_grad(j)
10314      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10315      & )*wshield
10316 C grad_shield_side is Cbeta sidechain gradient
10317       grad_shield_side(j,ishield_list(i),i)=
10318      &        (sh_frac_dist_grad(j)*(-2.0d0)
10319      &        *VofOverlap
10320      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10321      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10322      &       sinphi/sinthet*costhet*costhet_grad(j)
10323      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10324      &       )*wshield
10325
10326        grad_shield_loc(j,ishield_list(i),i)=
10327      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10328      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10329      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10330      &        ))
10331      &        *wshield
10332       enddo
10333       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10334       enddo
10335       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10336 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10337 c     &  " wshield",wshield
10338 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10339       enddo
10340       return
10341       end
10342 C--------------------------------------------------------------------------
10343       double precision function tschebyshev(m,n,x,y)
10344       implicit none
10345       include "DIMENSIONS"
10346       integer i,m,n
10347       double precision x(n),y,yy(0:maxvar),aux
10348 c Tschebyshev polynomial. Note that the first term is omitted
10349 c m=0: the constant term is included
10350 c m=1: the constant term is not included
10351       yy(0)=1.0d0
10352       yy(1)=y
10353       do i=2,n
10354         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10355       enddo
10356       aux=0.0d0
10357       do i=m,n
10358         aux=aux+x(i)*yy(i)
10359       enddo
10360       tschebyshev=aux
10361       return
10362       end
10363 C--------------------------------------------------------------------------
10364       double precision function gradtschebyshev(m,n,x,y)
10365       implicit none
10366       include "DIMENSIONS"
10367       integer i,m,n
10368       double precision x(n+1),y,yy(0:maxvar),aux
10369 c Tschebyshev polynomial. Note that the first term is omitted
10370 c m=0: the constant term is included
10371 c m=1: the constant term is not included
10372       yy(0)=1.0d0
10373       yy(1)=2.0d0*y
10374       do i=2,n
10375         yy(i)=2*y*yy(i-1)-yy(i-2)
10376       enddo
10377       aux=0.0d0
10378       do i=m,n
10379         aux=aux+x(i+1)*yy(i)*(i+1)
10380 C        print *, x(i+1),yy(i),i
10381       enddo
10382       gradtschebyshev=aux
10383       return
10384       end
10385 c----------------------------------------------------------------------------
10386       double precision function sscale2(r,r_cut,r0,rlamb)
10387       implicit none
10388       double precision r,gamm,r_cut,r0,rlamb,rr
10389       rr = dabs(r-r0)
10390 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10391 c      write (2,*) "rr",rr
10392       if(rr.lt.r_cut-rlamb) then
10393         sscale2=1.0d0
10394       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10395         gamm=(rr-(r_cut-rlamb))/rlamb
10396         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10397       else
10398         sscale2=0d0
10399       endif
10400       return
10401       end
10402 C-----------------------------------------------------------------------
10403       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10404       implicit none
10405       double precision r,gamm,r_cut,r0,rlamb,rr
10406       rr = dabs(r-r0)
10407       if(rr.lt.r_cut-rlamb) then
10408         sscalgrad2=0.0d0
10409       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10410         gamm=(rr-(r_cut-rlamb))/rlamb
10411         if (r.ge.r0) then
10412           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10413         else
10414           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10415         endif
10416       else
10417         sscalgrad2=0.0d0
10418       endif
10419       return
10420       end
10421 c----------------------------------------------------------------------------
10422       subroutine e_saxs(Esaxs_constr)
10423       implicit none
10424       include 'DIMENSIONS'
10425       include 'DIMENSIONS.ZSCOPT'
10426       include 'DIMENSIONS.FREE'
10427 #ifdef MPI
10428       include "mpif.h"
10429       include "COMMON.SETUP"
10430       integer IERR
10431 #endif
10432       include 'COMMON.SBRIDGE'
10433       include 'COMMON.CHAIN'
10434       include 'COMMON.GEO'
10435       include 'COMMON.LOCAL'
10436       include 'COMMON.INTERACT'
10437       include 'COMMON.VAR'
10438       include 'COMMON.IOUNITS'
10439       include 'COMMON.DERIV'
10440       include 'COMMON.CONTROL'
10441       include 'COMMON.NAMES'
10442       include 'COMMON.FFIELD'
10443       include 'COMMON.LANGEVIN'
10444       include 'COMMON.SAXS'
10445 c
10446       double precision Esaxs_constr
10447       integer i,iint,j,k,l
10448       double precision PgradC(maxSAXS,3,maxres),
10449      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10450 #ifdef MPI
10451       double precision PgradC_(maxSAXS,3,maxres),
10452      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10453 #endif
10454       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10455      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10456      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10457      & auxX,auxX1,CACAgrad,Cnorm
10458       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10459       double precision dist
10460       external dist
10461 c  SAXS restraint penalty function
10462 #ifdef DEBUG
10463       write(iout,*) "------- SAXS penalty function start -------"
10464       write (iout,*) "nsaxs",nsaxs
10465       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10466       write (iout,*) "Psaxs"
10467       do i=1,nsaxs
10468         write (iout,'(i5,e15.5)') i, Psaxs(i)
10469       enddo
10470 #endif
10471       Esaxs_constr = 0.0d0
10472       do k=1,nsaxs
10473         Pcalc(k)=0.0d0
10474         do j=1,nres
10475           do l=1,3
10476             PgradC(k,l,j)=0.0d0
10477             PgradX(k,l,j)=0.0d0
10478           enddo
10479         enddo
10480       enddo
10481       do i=iatsc_s,iatsc_e
10482        if (itype(i).eq.ntyp1) cycle
10483        do iint=1,nint_gr(i)
10484          do j=istart(i,iint),iend(i,iint)
10485            if (itype(j).eq.ntyp1) cycle
10486 #ifdef ALLSAXS
10487            dijCACA=dist(i,j)
10488            dijCASC=dist(i,j+nres)
10489            dijSCCA=dist(i+nres,j)
10490            dijSCSC=dist(i+nres,j+nres)
10491            sigma2CACA=2.0d0/(pstok**2)
10492            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10493            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10494            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10495            do k=1,nsaxs
10496              dk = distsaxs(k)
10497              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10498              if (itype(j).ne.10) then
10499              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10500              else
10501              endif
10502              expCASC = 0.0d0
10503              if (itype(i).ne.10) then
10504              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10505              else
10506              expSCCA = 0.0d0
10507              endif
10508              if (itype(i).ne.10 .and. itype(j).ne.10) then
10509              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10510              else
10511              expSCSC = 0.0d0
10512              endif
10513              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10514 #ifdef DEBUG
10515              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10516 #endif
10517              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10518              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10519              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10520              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10521              do l=1,3
10522 c CA CA
10523                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10524                PgradC(k,l,i) = PgradC(k,l,i)-aux
10525                PgradC(k,l,j) = PgradC(k,l,j)+aux
10526 c CA SC
10527                if (itype(j).ne.10) then
10528                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10529                PgradC(k,l,i) = PgradC(k,l,i)-aux
10530                PgradC(k,l,j) = PgradC(k,l,j)+aux
10531                PgradX(k,l,j) = PgradX(k,l,j)+aux
10532                endif
10533 c SC CA
10534                if (itype(i).ne.10) then
10535                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10536                PgradX(k,l,i) = PgradX(k,l,i)-aux
10537                PgradC(k,l,i) = PgradC(k,l,i)-aux
10538                PgradC(k,l,j) = PgradC(k,l,j)+aux
10539                endif
10540 c SC SC
10541                if (itype(i).ne.10 .and. itype(j).ne.10) then
10542                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10543                PgradC(k,l,i) = PgradC(k,l,i)-aux
10544                PgradC(k,l,j) = PgradC(k,l,j)+aux
10545                PgradX(k,l,i) = PgradX(k,l,i)-aux
10546                PgradX(k,l,j) = PgradX(k,l,j)+aux
10547                endif
10548              enddo ! l
10549            enddo ! k
10550 #else
10551            dijCACA=dist(i,j)
10552            sigma2CACA=scal_rad**2*0.25d0/
10553      &        (restok(itype(j))**2+restok(itype(i))**2)
10554
10555            IF (saxs_cutoff.eq.0) THEN
10556            do k=1,nsaxs
10557              dk = distsaxs(k)
10558              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10559              Pcalc(k) = Pcalc(k)+expCACA
10560              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10561              do l=1,3
10562                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10563                PgradC(k,l,i) = PgradC(k,l,i)-aux
10564                PgradC(k,l,j) = PgradC(k,l,j)+aux
10565              enddo ! l
10566            enddo ! k
10567            ELSE
10568            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10569            do k=1,nsaxs
10570              dk = distsaxs(k)
10571 c             write (2,*) "ijk",i,j,k
10572              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10573              if (sss2.eq.0.0d0) cycle
10574              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10575              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10576              Pcalc(k) = Pcalc(k)+expCACA
10577 #ifdef DEBUG
10578              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10579 #endif
10580              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10581      &             ssgrad2*expCACA/sss2
10582              do l=1,3
10583 c CA CA
10584                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10585                PgradC(k,l,i) = PgradC(k,l,i)+aux
10586                PgradC(k,l,j) = PgradC(k,l,j)-aux
10587              enddo ! l
10588            enddo ! k
10589            ENDIF
10590 #endif
10591          enddo ! j
10592        enddo ! iint
10593       enddo ! i
10594 #ifdef MPI
10595       if (nfgtasks.gt.1) then
10596         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10597      &    MPI_SUM,king,FG_COMM,IERR)
10598         if (fg_rank.eq.king) then
10599           do k=1,nsaxs
10600             Pcalc(k) = Pcalc_(k)
10601           enddo
10602         endif
10603         call MPI_Reduce(PgradC(k,1,1),PgradC_(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                 PgradC(k,l,i) = PgradC_(k,l,i)
10610               enddo
10611             enddo
10612           enddo
10613         endif
10614 #ifdef ALLSAXS
10615         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10616      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10617         if (fg_rank.eq.king) then
10618           do i=1,nres
10619             do l=1,3
10620               do k=1,nsaxs
10621                 PgradX(k,l,i) = PgradX_(k,l,i)
10622               enddo
10623             enddo
10624           enddo
10625         endif
10626 #endif
10627       endif
10628 #endif
10629 #ifdef MPI
10630       if (fg_rank.eq.king) then
10631 #endif
10632       Cnorm = 0.0d0
10633       do k=1,nsaxs
10634         Cnorm = Cnorm + Pcalc(k)
10635       enddo
10636       Esaxs_constr = dlog(Cnorm)-wsaxs0
10637       do k=1,nsaxs
10638         if (Pcalc(k).gt.0.0d0)
10639      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10640 #ifdef DEBUG
10641         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10642 #endif
10643       enddo
10644 #ifdef DEBUG
10645       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10646 #endif
10647       do i=nnt,nct
10648         do l=1,3
10649           auxC=0.0d0
10650           auxC1=0.0d0
10651           auxX=0.0d0
10652           auxX1=0.d0
10653           do k=1,nsaxs
10654             if (Pcalc(k).gt.0)
10655      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10656             auxC1 = auxC1+PgradC(k,l,i)
10657 #ifdef ALLSAXS
10658             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10659             auxX1 = auxX1+PgradX(k,l,i)
10660 #endif
10661           enddo
10662           gsaxsC(l,i) = auxC - auxC1/Cnorm
10663 #ifdef ALLSAXS
10664           gsaxsX(l,i) = auxX - auxX1/Cnorm
10665 #endif
10666 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10667 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10668         enddo
10669       enddo
10670 #ifdef MPI
10671       endif
10672 #endif
10673       return
10674       end
10675 c----------------------------------------------------------------------------
10676       subroutine e_saxsC(Esaxs_constr)
10677       implicit none
10678       include 'DIMENSIONS'
10679       include 'DIMENSIONS.ZSCOPT'
10680       include 'DIMENSIONS.FREE'
10681 #ifdef MPI
10682       include "mpif.h"
10683       include "COMMON.SETUP"
10684       integer IERR
10685 #endif
10686       include 'COMMON.SBRIDGE'
10687       include 'COMMON.CHAIN'
10688       include 'COMMON.GEO'
10689       include 'COMMON.LOCAL'
10690       include 'COMMON.INTERACT'
10691       include 'COMMON.VAR'
10692       include 'COMMON.IOUNITS'
10693       include 'COMMON.DERIV'
10694       include 'COMMON.CONTROL'
10695       include 'COMMON.NAMES'
10696       include 'COMMON.FFIELD'
10697       include 'COMMON.LANGEVIN'
10698       include 'COMMON.SAXS'
10699 c
10700       double precision Esaxs_constr
10701       integer i,iint,j,k,l
10702       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10703 #ifdef MPI
10704       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10705 #endif
10706       double precision dk,dijCASPH,dijSCSPH,
10707      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10708      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10709      & auxX,auxX1,Cnorm
10710 c  SAXS restraint penalty function
10711 #ifdef DEBUG
10712       write(iout,*) "------- SAXS penalty function start -------"
10713       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10714      & " isaxs_end",isaxs_end
10715       write (iout,*) "nnt",nnt," ntc",nct
10716       do i=nnt,nct
10717         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10718      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10719       enddo
10720       do i=nnt,nct
10721         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10722       enddo
10723 #endif
10724       Esaxs_constr = 0.0d0
10725       logPtot=0.0d0
10726       do j=isaxs_start,isaxs_end
10727         Pcalc=0.0d0
10728         do i=1,nres
10729           do l=1,3
10730             PgradC(l,i)=0.0d0
10731             PgradX(l,i)=0.0d0
10732           enddo
10733         enddo
10734         do i=nnt,nct
10735           dijCASPH=0.0d0
10736           dijSCSPH=0.0d0
10737           do l=1,3
10738             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10739           enddo
10740           if (itype(i).ne.10) then
10741           do l=1,3
10742             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10743           enddo
10744           endif
10745           sigma2CA=2.0d0/pstok**2
10746           sigma2SC=4.0d0/restok(itype(i))**2
10747           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10748           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10749           Pcalc = Pcalc+expCASPH+expSCSPH
10750 #ifdef DEBUG
10751           write(*,*) "processor i j Pcalc",
10752      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10753 #endif
10754           CASPHgrad = sigma2CA*expCASPH
10755           SCSPHgrad = sigma2SC*expSCSPH
10756           do l=1,3
10757             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10758             PgradX(l,i) = PgradX(l,i) + aux
10759             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10760           enddo ! l
10761         enddo ! i
10762         do i=nnt,nct
10763           do l=1,3
10764             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10765             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10766           enddo
10767         enddo
10768         logPtot = logPtot - dlog(Pcalc)
10769 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10770 c     &    " logPtot",logPtot
10771       enddo ! j
10772 #ifdef MPI
10773       if (nfgtasks.gt.1) then
10774 c        write (iout,*) "logPtot before reduction",logPtot
10775         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10776      &    MPI_SUM,king,FG_COMM,IERR)
10777         logPtot = logPtot_
10778 c        write (iout,*) "logPtot after reduction",logPtot
10779         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10780      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10781         if (fg_rank.eq.king) then
10782           do i=1,nres
10783             do l=1,3
10784               gsaxsC(l,i) = gsaxsC_(l,i)
10785             enddo
10786           enddo
10787         endif
10788         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10789      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10790         if (fg_rank.eq.king) then
10791           do i=1,nres
10792             do l=1,3
10793               gsaxsX(l,i) = gsaxsX_(l,i)
10794             enddo
10795           enddo
10796         endif
10797       endif
10798 #endif
10799       Esaxs_constr = logPtot
10800       return
10801       end
10802