source/wham/src-HCD/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       include 'COMMON.SAXS'
  24       double precision fact(6)
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C      write(iout,*) 'po elektostatyce'
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106 continue
  52       call vec_and_deriv
  53       if (shield_mode.eq.1) then
  54        call set_shield_fac
  55       else if  (shield_mode.eq.2) then
  56        call set_shield_fac2
  57       endif
  58       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  59 C            write(iout,*) 'po eelec'
  60
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68
  69       call ebond(estr)
  70 C       write (iout,*) "estr",estr
  71 C
  72 C Calculate the disulfide-bridge and other energy and the contributions
  73 C from other distance constraints.
  74 cd    print *,'Calling EHPB'
  75       call edis(ehpb)
  76 cd    print *,'EHPB exitted succesfully.'
  77 C
  78 C Calculate the virtual-bond-angle energy.
  79 C
  80 C      print *,'Bend energy finished.'
  81       if (wang.gt.0d0) then
  82        if (tor_mode.eq.0) then
  83          call ebend(ebe)
  84        else
  85 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  86 C energy function
  87          call ebend_kcc(ebe)
  88        endif
  89       else
  90         ebe=0.0d0
  91       endif
  92       ethetacnstr=0.0d0
  93       if (with_theta_constr) call etheta_constr(ethetacnstr)
  94 c      call ebend(ebe,ethetacnstr)
  95 cd    print *,'Bend energy finished.'
  96 C
  97 C Calculate the SC local energy.
  98 C
  99       call esc(escloc)
 100 C       print *,'SCLOC energy finished.'
 101 C
 102 C Calculate the virtual-bond torsional energy.
 103 C
 104       if (wtor.gt.0.0d0) then
 105          if (tor_mode.eq.0) then
 106            call etor(etors,fact(1))
 107          else
 108 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 109 C energy function
 110            call etor_kcc(etors,fact(1))
 111          endif
 112       else
 113         etors=0.0d0
 114       endif
 115       edihcnstr=0.0d0
 116       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 117 c      print *,"Processor",myrank," computed Utor"
 118 C
 119 C 6/23/01 Calculate double-torsional energy
 120 C
 121       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 122         call etor_d(etors_d,fact(2))
 123       else
 124         etors_d=0
 125       endif
 126 c      print *,"Processor",myrank," computed Utord"
 127 C
 128       if (wsccor.gt.0.0d0) then
 129         call eback_sc_corr(esccor)
 130       else
 131         esccor=0.0d0
 132       endif
 133
 134       if (wliptran.gt.0) then
 135         call Eliptransfer(eliptran)
 136       else
 137         eliptran=0.0d0
 138       endif
 139 #ifdef FOURBODY
 140 C
 141 C 12/1/95 Multi-body terms
 142 C
 143       n_corr=0
 144       n_corr1=0
 145       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 146      &    .or. wturn6.gt.0.0d0) then
 147 c         write(iout,*)"calling multibody_eello"
 148          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 149 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 150 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 151       else
 152          ecorr=0.0d0
 153          ecorr5=0.0d0
 154          ecorr6=0.0d0
 155          eturn6=0.0d0
 156       endif
 157       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 158 c         write (iout,*) "Calling multibody_hbond"
 159          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 160       endif
 161 #endif
 162 c      write (iout,*) "nsaxs",nsaxs
 163 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 164       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 165         call e_saxs(Esaxs_constr)
 166 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 167       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 168         call e_saxsC(Esaxs_constr)
 169 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 170       else
 171         Esaxs_constr = 0.0d0
 172       endif
 173
 174 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 175       if (constr_homology.ge.1) then
 176         call e_modeller(ehomology_constr)
 177       else
 178         ehomology_constr=0.0d0
 179       endif
 180
 181 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 182 #ifdef DFA
 183 C     BARTEK for dfa test!
 184       edfadis=0.0d0
 185       if (wdfa_dist.gt.0) call edfad(edfadis)
 186 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 187       edfator=0.0d0
 188       if (wdfa_tor.gt.0) call edfat(edfator)
 189 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 190       edfanei=0.0d0
 191       if (wdfa_nei.gt.0) call edfan(edfanei)
 192 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 193       edfabet=0.0d0
 194       if (wdfa_beta.gt.0) call edfab(edfabet)
 195 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 196 #endif
 197
 198 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 199 #ifdef SPLITELE
 200       if (shield_mode.gt.0) then
 201       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 202      & +welec*fact(1)*ees
 203      & +fact(1)*wvdwpp*evdw1
 204      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 205      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 206      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 207      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 208      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 209      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 210      & +wliptran*eliptran*esaxs_constr
 211      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 212      & +wdfa_beta*edfabet
 213       else
 214       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 215      & +wvdwpp*evdw1
 216      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 217      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 218      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 219      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 220      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 221      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 222      & +wliptran*eliptran+wsaxs*esaxs_constr
 223      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 224      & +wdfa_beta*edfabet
 225       endif
 226 #else
 227       if (shield_mode.gt.0) then
 228       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 229      & +welec*fact(1)*(ees+evdw1)
 230      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 231      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 232      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 233      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 234      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 235      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 236      & +wliptran*eliptran+wsaxs*esaxs_constr
 237      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 238      & +wdfa_beta*edfabet
 239       else
 240       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 241      & +welec*fact(1)*(ees+evdw1)
 242      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 243      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 244      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 245      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 246      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 247      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 248      & +wliptran*eliptran+wsaxs*esaxs_constr
 249      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 250      & +wdfa_beta*edfabet
 251       endif
 252 #endif
 253       energia(0)=etot
 254       energia(1)=evdw
 255 #ifdef SCP14
 256       energia(2)=evdw2-evdw2_14
 257       energia(17)=evdw2_14
 258 #else
 259       energia(2)=evdw2
 260       energia(17)=0.0d0
 261 #endif
 262 #ifdef SPLITELE
 263       energia(3)=ees
 264       energia(16)=evdw1
 265 #else
 266       energia(3)=ees+evdw1
 267       energia(16)=0.0d0
 268 #endif
 269       energia(4)=ecorr
 270       energia(5)=ecorr5
 271       energia(6)=ecorr6
 272       energia(7)=eel_loc
 273       energia(8)=eello_turn3
 274       energia(9)=eello_turn4
 275       energia(10)=eturn6
 276       energia(11)=ebe
 277       energia(12)=escloc
 278       energia(13)=etors
 279       energia(14)=etors_d
 280       energia(15)=ehpb
 281       energia(18)=estr
 282       energia(19)=esccor
 283       energia(20)=edihcnstr
 284       energia(21)=evdw_t
 285       energia(22)=eliptran
 286       energia(24)=ethetacnstr
 287       energia(26)=esaxs_constr
 288       energia(27)=ehomology_constr
 289       energia(28)=edfadis
 290       energia(29)=edfator
 291       energia(30)=edfanei
 292       energia(31)=edfabet
 293 c detecting NaNQ
 294 #ifdef ISNAN
 295 #ifdef AIX
 296       if (isnan(etot).ne.0) energia(0)=1.0d+99
 297 #else
 298       if (isnan(etot)) energia(0)=1.0d+99
 299 #endif
 300 #else
 301       i=0
 302 #ifdef WINPGI
 303       idumm=proc_proc(etot,i)
 304 #else
 305       call proc_proc(etot,i)
 306 #endif
 307       if(i.eq.1)energia(0)=1.0d+99
 308 #endif
 309 #ifdef MPL
 310 c     endif
 311 #endif
 312 #ifdef DEBUG
 313       call enerprint(energia,fact)
 314 #endif
 315       if (calc_grad) then
 316 C
 317 C Sum up the components of the Cartesian gradient.
 318 C
 319 #ifdef SPLITELE
 320       do i=1,nct
 321         do j=1,3
 322       if (shield_mode.eq.0) then
 323           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 324      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 325      &                wbond*gradb(j,i)+
 326      &                wstrain*ghpbc(j,i)+
 327      &                wcorr*fact(3)*gradcorr(j,i)+
 328      &                wel_loc*fact(2)*gel_loc(j,i)+
 329      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 330      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 331      &                wcorr5*fact(4)*gradcorr5(j,i)+
 332      &                wcorr6*fact(5)*gradcorr6(j,i)+
 333      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 334      &                wsccor*fact(2)*gsccorc(j,i)+
 335      &                wliptran*gliptranc(j,i)+
 336      &                wdfa_dist*gdfad(j,i)+
 337      &                wdfa_tor*gdfat(j,i)+
 338      &                wdfa_nei*gdfan(j,i)+
 339      &                wdfa_beta*gdfab(j,i)
 340           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 341      &                  wbond*gradbx(j,i)+
 342      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 343      &                  wsccor*fact(2)*gsccorx(j,i)
 344      &                 +wliptran*gliptranx(j,i)
 345         else
 346           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 347      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 348      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 349      &                wbond*gradb(j,i)+
 350      &                wstrain*ghpbc(j,i)+
 351      &                wcorr*fact(3)*gradcorr(j,i)+
 352      &                wel_loc*fact(2)*gel_loc(j,i)+
 353      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 354      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 355      &                wcorr5*fact(4)*gradcorr5(j,i)+
 356      &                wcorr6*fact(5)*gradcorr6(j,i)+
 357      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 358      &                wsccor*fact(2)*gsccorc(j,i)
 359      &               +wliptran*gliptranc(j,i)
 360      &                 +welec*gshieldc(j,i)
 361      &                 +welec*gshieldc_loc(j,i)
 362      &                 +wcorr*gshieldc_ec(j,i)
 363      &                 +wcorr*gshieldc_loc_ec(j,i)
 364      &                 +wturn3*gshieldc_t3(j,i)
 365      &                 +wturn3*gshieldc_loc_t3(j,i)
 366      &                 +wturn4*gshieldc_t4(j,i)
 367      &                 +wturn4*gshieldc_loc_t4(j,i)
 368      &                 +wel_loc*gshieldc_ll(j,i)
 369      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 370      &                wdfa_dist*gdfad(j,i)+
 371      &                wdfa_tor*gdfat(j,i)+
 372      &                wdfa_nei*gdfan(j,i)+
 373      &                wdfa_beta*gdfab(j,i)
 374           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 375      &                 +fact(1)*wscp*gradx_scp(j,i)+
 376      &                  wbond*gradbx(j,i)+
 377      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 378      &                  wsccor*fact(2)*gsccorx(j,i)
 379      &                 +wliptran*gliptranx(j,i)
 380      &                 +welec*gshieldx(j,i)
 381      &                 +wcorr*gshieldx_ec(j,i)
 382      &                 +wturn3*gshieldx_t3(j,i)
 383      &                 +wturn4*gshieldx_t4(j,i)
 384      &                 +wel_loc*gshieldx_ll(j,i)
 385         endif
 386         enddo
 387 #else
 388       do i=1,nct
 389         do j=1,3
 390                 if (shield_mode.eq.0) then
 391           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 392      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 393      &                wbond*gradb(j,i)+
 394      &                wcorr*fact(3)*gradcorr(j,i)+
 395      &                wel_loc*fact(2)*gel_loc(j,i)+
 396      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 397      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 398      &                wcorr5*fact(4)*gradcorr5(j,i)+
 399      &                wcorr6*fact(5)*gradcorr6(j,i)+
 400      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 401      &                wsccor*fact(2)*gsccorc(j,i)
 402      &               +wliptran*gliptranc(j,i)+
 403      &                wdfa_dist*gdfad(j,i)+
 404      &                wdfa_tor*gdfat(j,i)+
 405      &                wdfa_nei*gdfan(j,i)+
 406      &                wdfa_beta*gdfab(j,i)
 407
 408           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 409      &                  wbond*gradbx(j,i)+
 410      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 411      &                  wsccor*fact(1)*gsccorx(j,i)
 412      &                 +wliptran*gliptranx(j,i)
 413               else
 414           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 415      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 416      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 417      &                wbond*gradb(j,i)+
 418      &                wcorr*fact(3)*gradcorr(j,i)+
 419      &                wel_loc*fact(2)*gel_loc(j,i)+
 420      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 421      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 422      &                wcorr5*fact(4)*gradcorr5(j,i)+
 423      &                wcorr6*fact(5)*gradcorr6(j,i)+
 424      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 425      &                wsccor*fact(2)*gsccorc(j,i)
 426      &               +wliptran*gliptranc(j,i)
 427      &                 +welec*gshieldc(j,i)
 428      &                 +welec*gshieldc_loc(j,i)
 429      &                 +wcorr*gshieldc_ec(j,i)
 430      &                 +wcorr*gshieldc_loc_ec(j,i)
 431      &                 +wturn3*gshieldc_t3(j,i)
 432      &                 +wturn3*gshieldc_loc_t3(j,i)
 433      &                 +wturn4*gshieldc_t4(j,i)
 434      &                 +wturn4*gshieldc_loc_t4(j,i)
 435      &                 +wel_loc*gshieldc_ll(j,i)
 436      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 437      &                wdfa_dist*gdfad(j,i)+
 438      &                wdfa_tor*gdfat(j,i)+
 439      &                wdfa_nei*gdfan(j,i)+
 440      &                wdfa_beta*gdfab(j,i)
 441           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 442      &                  fact(1)*wscp*gradx_scp(j,i)+
 443      &                  wbond*gradbx(j,i)+
 444      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 445      &                  wsccor*fact(1)*gsccorx(j,i)
 446      &                 +wliptran*gliptranx(j,i)
 447      &                 +welec*gshieldx(j,i)
 448      &                 +wcorr*gshieldx_ec(j,i)
 449      &                 +wturn3*gshieldx_t3(j,i)
 450      &                 +wturn4*gshieldx_t4(j,i)
 451      &                 +wel_loc*gshieldx_ll(j,i)
 452
 453          endif
 454         enddo
 455 #endif
 456       enddo
 457
 458
 459       do i=1,nres-3
 460         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 461      &   +wcorr5*fact(4)*g_corr5_loc(i)
 462      &   +wcorr6*fact(5)*g_corr6_loc(i)
 463      &   +wturn4*fact(3)*gel_loc_turn4(i)
 464      &   +wturn3*fact(2)*gel_loc_turn3(i)
 465      &   +wturn6*fact(5)*gel_loc_turn6(i)
 466      &   +wel_loc*fact(2)*gel_loc_loc(i)
 467 c     &   +wsccor*fact(1)*gsccor_loc(i)
 468 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 469       enddo
 470       endif
 471       if (dyn_ss) call dyn_set_nss
 472       return
 473       end
 474 C------------------------------------------------------------------------
 475       subroutine enerprint(energia,fact)
 476       implicit real*8 (a-h,o-z)
 477       include 'DIMENSIONS'
 478       include 'DIMENSIONS.ZSCOPT'
 479       include 'COMMON.IOUNITS'
 480       include 'COMMON.FFIELD'
 481       include 'COMMON.SBRIDGE'
 482       include 'COMMON.CONTROL'
 483       double precision energia(0:max_ene),fact(6)
 484       etot=energia(0)
 485       evdw=energia(1)+fact(6)*energia(21)
 486 #ifdef SCP14
 487       evdw2=energia(2)+energia(17)
 488 #else
 489       evdw2=energia(2)
 490 #endif
 491       ees=energia(3)
 492 #ifdef SPLITELE
 493       evdw1=energia(16)
 494 #endif
 495       ecorr=energia(4)
 496       ecorr5=energia(5)
 497       ecorr6=energia(6)
 498       eel_loc=energia(7)
 499       eello_turn3=energia(8)
 500       eello_turn4=energia(9)
 501       eello_turn6=energia(10)
 502       ebe=energia(11)
 503       escloc=energia(12)
 504       etors=energia(13)
 505       etors_d=energia(14)
 506       ehpb=energia(15)
 507       esccor=energia(19)
 508       edihcnstr=energia(20)
 509       estr=energia(18)
 510       ethetacnstr=energia(24)
 511       eliptran=energia(22)
 512       esaxs=energia(26)
 513       ehomology_constr=energia(27)
 514 C     Bartek
 515       edfadis = energia(28)
 516       edfator = energia(29)
 517       edfanei = energia(30)
 518       edfabet = energia(31)
 519 #ifdef SPLITELE
 520       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 521      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 522      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 523 #ifdef FOURBODY
 524      &  ecorr,wcorr*fact(3),
 525      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 526 #endif
 527      &  eel_loc,
 528      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 529      &  eello_turn4,wturn4*fact(3),
 530 #ifdef FOURBODY
 531      &  eello_turn6,wturn6*fact(5),
 532 #endif
 533      &  esccor,wsccor*fact(1),edihcnstr,
 534      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 535      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 536      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 537      &  edfabet,wdfa_beta,
 538      &  etot
 539    10 format (/'Virtual-chain energies:'//
 540      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 541      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 542      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 543      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 544      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 545      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 546      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 547      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 548      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 549      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 550      & ' (SS bridges & dist. cnstr.)'/
 551 #ifdef FOURBODY
 552      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 553      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 554      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 555 #endif
 556      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 557      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 558      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 559 #ifdef FOURBODY
 560      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 561 #endif
 562      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 563      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 564      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 565      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 566      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 567      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 568      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 569      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 570      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 571      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 572      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 573      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 574      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 575      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 576      & 'ETOT=  ',1pE16.6,' (total)')
 577
 578 #else
 579       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 580      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 581      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 582 #ifdef FOURBODY
 583      &  ecorr,wcorr*fact(3),
 584      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 585 #endif
 586      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 587      &  eello_turn4,wturn4*fact(3),
 588 #ifdef FOURBODY
 589      &  eello_turn6,wturn6*fact(5),
 590 #endif
 591      &  esccor,wsccor*fact(1),edihcnstr,
 592      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 593      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 594      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 595      &  edfabet,wdfa_beta,
 596      &  etot
 597    10 format (/'Virtual-chain energies:'//
 598      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 599      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 600      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 601      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 602      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 603      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 604      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 605      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 606      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 607      & ' (SS bridges & dist. restr.)'/
 608 #ifdef FOURBODY
 609      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 610      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 611      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 612 #endif
 613      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 614      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 615      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 616 #ifdef FOURBODY
 617      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 618 #endif
 619      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 620      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 621      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 622      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 623      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 624      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 625      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 626      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 627      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 628      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 629      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 630      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 631      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 632      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 633      & 'ETOT=  ',1pE16.6,' (total)')
 634 #endif
 635       return
 636       end
 637 C-----------------------------------------------------------------------
 638       subroutine elj(evdw,evdw_t)
 639 C
 640 C This subroutine calculates the interaction energy of nonbonded side chains
 641 C assuming the LJ potential of interaction.
 642 C
 643       implicit real*8 (a-h,o-z)
 644       include 'DIMENSIONS'
 645       include 'DIMENSIONS.ZSCOPT'
 646       include "DIMENSIONS.COMPAR"
 647       parameter (accur=1.0d-10)
 648       include 'COMMON.GEO'
 649       include 'COMMON.VAR'
 650       include 'COMMON.LOCAL'
 651       include 'COMMON.CHAIN'
 652       include 'COMMON.DERIV'
 653       include 'COMMON.INTERACT'
 654       include 'COMMON.TORSION'
 655       include 'COMMON.ENEPS'
 656       include 'COMMON.SBRIDGE'
 657       include 'COMMON.NAMES'
 658       include 'COMMON.IOUNITS'
 659 #ifdef FOURBODY
 660       include 'COMMON.CONTACTS'
 661       include 'COMMON.CONTMAT'
 662 #endif
 663       dimension gg(3)
 664       integer icant
 665       external icant
 666 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 667 c ROZNICA z cluster
 668       do i=1,210
 669         do j=1,2
 670           eneps_temp(j,i)=0.0d0
 671         enddo
 672       enddo
 673 cROZNICA
 674
 675       evdw=0.0D0
 676       evdw_t=0.0d0
 677       do i=iatsc_s,iatsc_e
 678         itypi=iabs(itype(i))
 679         if (itypi.eq.ntyp1) cycle
 680         itypi1=iabs(itype(i+1))
 681         xi=c(1,nres+i)
 682         yi=c(2,nres+i)
 683         zi=c(3,nres+i)
 684 C Change 12/1/95
 685         num_conti=0
 686 C
 687 C Calculate SC interaction energy.
 688 C
 689         do iint=1,nint_gr(i)
 690 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 691 cd   &                  'iend=',iend(i,iint)
 692           do j=istart(i,iint),iend(i,iint)
 693             itypj=iabs(itype(j))
 694             if (itypj.eq.ntyp1) cycle
 695             xj=c(1,nres+j)-xi
 696             yj=c(2,nres+j)-yi
 697             zj=c(3,nres+j)-zi
 698 C Change 12/1/95 to calculate four-body interactions
 699             rij=xj*xj+yj*yj+zj*zj
 700             rrij=1.0D0/rij
 701             sqrij=dsqrt(rij)
 702             sss1=sscale(sqrij)
 703             if (sss1.eq.0.0d0) cycle
 704             sssgrad1=sscagrad(sqrij)
 705 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 706             eps0ij=eps(itypi,itypj)
 707             fac=rrij**expon2
 708             e1=fac*fac*aa
 709             e2=fac*bb
 710             evdwij=e1+e2
 711             ij=icant(itypi,itypj)
 712 c ROZNICA z cluster
 713             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 714             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 715 c
 716
 717 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 718 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 719 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 720 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 721 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 722 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 723             if (bb.gt.0.0d0) then
 724               evdw=evdw+sss1*evdwij
 725             else
 726               evdw_t=evdw_t+sss1*evdwij
 727             endif
 728             if (calc_grad) then
 729 C
 730 C Calculate the components of the gradient in DC and X
 731 C
 732             fac=-rrij*(e1+evdwij)*sss1
 733      &          +evdwij*sssgrad1/sqrij/expon
 734             gg(1)=xj*fac
 735             gg(2)=yj*fac
 736             gg(3)=zj*fac
 737             do k=1,3
 738               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 739               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 740             enddo
 741             do k=i,j-1
 742               do l=1,3
 743                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 744               enddo
 745             enddo
 746             endif
 747 #ifdef FOURBODY
 748 C
 749 C 12/1/95, revised on 5/20/97
 750 C
 751 C Calculate the contact function. The ith column of the array JCONT will
 752 C contain the numbers of atoms that make contacts with the atom I (of numbers
 753 C greater than I). The arrays FACONT and GACONT will contain the values of
 754 C the contact function and its derivative.
 755 C
 756 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 757 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 758 C Uncomment next line, if the correlation interactions are contact function only
 759             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 760               rij=dsqrt(rij)
 761               sigij=sigma(itypi,itypj)
 762               r0ij=rs0(itypi,itypj)
 763 C
 764 C Check whether the SC's are not too far to make a contact.
 765 C
 766               rcut=1.5d0*r0ij
 767               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 768 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 769 C
 770               if (fcont.gt.0.0D0) then
 771 C If the SC-SC distance if close to sigma, apply spline.
 772 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 773 cAdam &             fcont1,fprimcont1)
 774 cAdam           fcont1=1.0d0-fcont1
 775 cAdam           if (fcont1.gt.0.0d0) then
 776 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 777 cAdam             fcont=fcont*fcont1
 778 cAdam           endif
 779 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 780 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 781 cga             do k=1,3
 782 cga               gg(k)=gg(k)*eps0ij
 783 cga             enddo
 784 cga             eps0ij=-evdwij*eps0ij
 785 C Uncomment for AL's type of SC correlation interactions.
 786 cadam           eps0ij=-evdwij
 787                 num_conti=num_conti+1
 788                 jcont(num_conti,i)=j
 789                 facont(num_conti,i)=fcont*eps0ij
 790                 fprimcont=eps0ij*fprimcont/rij
 791                 fcont=expon*fcont
 792 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 793 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 794 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 795 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 796                 gacont(1,num_conti,i)=-fprimcont*xj
 797                 gacont(2,num_conti,i)=-fprimcont*yj
 798                 gacont(3,num_conti,i)=-fprimcont*zj
 799 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 800 cd              write (iout,'(2i3,3f10.5)')
 801 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 802               endif
 803             endif
 804 #endif
 805           enddo      ! j
 806         enddo        ! iint
 807 #ifdef FOURBODY
 808 C Change 12/1/95
 809         num_cont(i)=num_conti
 810 #endif
 811       enddo          ! i
 812       if (calc_grad) then
 813       do i=1,nct
 814         do j=1,3
 815           gvdwc(j,i)=expon*gvdwc(j,i)
 816           gvdwx(j,i)=expon*gvdwx(j,i)
 817         enddo
 818       enddo
 819       endif
 820 C******************************************************************************
 821 C
 822 C                              N O T E !!!
 823 C
 824 C To save time, the factor of EXPON has been extracted from ALL components
 825 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 826 C use!
 827 C
 828 C******************************************************************************
 829       return
 830       end
 831 C-----------------------------------------------------------------------------
 832       subroutine eljk(evdw,evdw_t)
 833 C
 834 C This subroutine calculates the interaction energy of nonbonded side chains
 835 C assuming the LJK potential of interaction.
 836 C
 837       implicit real*8 (a-h,o-z)
 838       include 'DIMENSIONS'
 839       include 'DIMENSIONS.ZSCOPT'
 840       include "DIMENSIONS.COMPAR"
 841       include 'COMMON.GEO'
 842       include 'COMMON.VAR'
 843       include 'COMMON.LOCAL'
 844       include 'COMMON.CHAIN'
 845       include 'COMMON.DERIV'
 846       include 'COMMON.INTERACT'
 847       include 'COMMON.ENEPS'
 848       include 'COMMON.IOUNITS'
 849       include 'COMMON.NAMES'
 850       dimension gg(3)
 851       logical scheck
 852       integer icant
 853       external icant
 854 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 855       do i=1,210
 856         do j=1,2
 857           eneps_temp(j,i)=0.0d0
 858         enddo
 859       enddo
 860       evdw=0.0D0
 861       evdw_t=0.0d0
 862       do i=iatsc_s,iatsc_e
 863         itypi=iabs(itype(i))
 864         if (itypi.eq.ntyp1) cycle
 865         itypi1=iabs(itype(i+1))
 866         xi=c(1,nres+i)
 867         yi=c(2,nres+i)
 868         zi=c(3,nres+i)
 869 C
 870 C Calculate SC interaction energy.
 871 C
 872         do iint=1,nint_gr(i)
 873           do j=istart(i,iint),iend(i,iint)
 874             itypj=iabs(itype(j))
 875             if (itypj.eq.ntyp1) cycle
 876             xj=c(1,nres+j)-xi
 877             yj=c(2,nres+j)-yi
 878             zj=c(3,nres+j)-zi
 879             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 880             fac_augm=rrij**expon
 881             e_augm=augm(itypi,itypj)*fac_augm
 882             r_inv_ij=dsqrt(rrij)
 883             rij=1.0D0/r_inv_ij
 884             sss1=sscale(rij)
 885             if (sss1.eq.0.0d0) cycle
 886             sssgrad1=sscagrad(rij)
 887             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 888             fac=r_shift_inv**expon
 889             e1=fac*fac*aa
 890             e2=fac*bb
 891             evdwij=e_augm+e1+e2
 892             ij=icant(itypi,itypj)
 893             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 894      &        /dabs(eps(itypi,itypj))
 895             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 896 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 897 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 898 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 899 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 900 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 901 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 902 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 903             if (bb.gt.0.0d0) then
 904               evdw=evdw+evdwij*sss1
 905             else
 906               evdw_t=evdw_t+evdwij*sss1
 907             endif
 908             if (calc_grad) then
 909 C
 910 C Calculate the components of the gradient in DC and X
 911 C
 912            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 913      &          +evdwij*sssgrad1*r_inv_ij/expon
 914             gg(1)=xj*fac
 915             gg(2)=yj*fac
 916             gg(3)=zj*fac
 917             do k=1,3
 918               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 919               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 920             enddo
 921             do k=i,j-1
 922               do l=1,3
 923                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 924               enddo
 925             enddo
 926             endif
 927           enddo      ! j
 928         enddo        ! iint
 929       enddo          ! i
 930       if (calc_grad) then
 931       do i=1,nct
 932         do j=1,3
 933           gvdwc(j,i)=expon*gvdwc(j,i)
 934           gvdwx(j,i)=expon*gvdwx(j,i)
 935         enddo
 936       enddo
 937       endif
 938       return
 939       end
 940 C-----------------------------------------------------------------------------
 941       subroutine ebp(evdw,evdw_t)
 942 C
 943 C This subroutine calculates the interaction energy of nonbonded side chains
 944 C assuming the Berne-Pechukas potential of interaction.
 945 C
 946       implicit real*8 (a-h,o-z)
 947       include 'DIMENSIONS'
 948       include 'DIMENSIONS.ZSCOPT'
 949       include "DIMENSIONS.COMPAR"
 950       include 'COMMON.GEO'
 951       include 'COMMON.VAR'
 952       include 'COMMON.LOCAL'
 953       include 'COMMON.CHAIN'
 954       include 'COMMON.DERIV'
 955       include 'COMMON.NAMES'
 956       include 'COMMON.INTERACT'
 957       include 'COMMON.ENEPS'
 958       include 'COMMON.IOUNITS'
 959       include 'COMMON.CALC'
 960       common /srutu/ icall
 961 c     double precision rrsave(maxdim)
 962       logical lprn
 963       integer icant
 964       external icant
 965       do i=1,210
 966         do j=1,2
 967           eneps_temp(j,i)=0.0d0
 968         enddo
 969       enddo
 970       evdw=0.0D0
 971       evdw_t=0.0d0
 972 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 973 c     if (icall.eq.0) then
 974 c       lprn=.true.
 975 c     else
 976         lprn=.false.
 977 c     endif
 978       ind=0
 979       do i=iatsc_s,iatsc_e
 980         itypi=iabs(itype(i))
 981         if (itypi.eq.ntyp1) cycle
 982         itypi1=iabs(itype(i+1))
 983         xi=c(1,nres+i)
 984         yi=c(2,nres+i)
 985         zi=c(3,nres+i)
 986         dxi=dc_norm(1,nres+i)
 987         dyi=dc_norm(2,nres+i)
 988         dzi=dc_norm(3,nres+i)
 989         dsci_inv=vbld_inv(i+nres)
 990 C
 991 C Calculate SC interaction energy.
 992 C
 993         do iint=1,nint_gr(i)
 994           do j=istart(i,iint),iend(i,iint)
 995             ind=ind+1
 996             itypj=iabs(itype(j))
 997             if (itypj.eq.ntyp1) cycle
 998             dscj_inv=vbld_inv(j+nres)
 999             chi1=chi(itypi,itypj)
1000             chi2=chi(itypj,itypi)
1001             chi12=chi1*chi2
1002             chip1=chip(itypi)
1003             chip2=chip(itypj)
1004             chip12=chip1*chip2
1005             alf1=alp(itypi)
1006             alf2=alp(itypj)
1007             alf12=0.5D0*(alf1+alf2)
1008 C For diagnostics only!!!
1009 c           chi1=0.0D0
1010 c           chi2=0.0D0
1011 c           chi12=0.0D0
1012 c           chip1=0.0D0
1013 c           chip2=0.0D0
1014 c           chip12=0.0D0
1015 c           alf1=0.0D0
1016 c           alf2=0.0D0
1017 c           alf12=0.0D0
1018             xj=c(1,nres+j)-xi
1019             yj=c(2,nres+j)-yi
1020             zj=c(3,nres+j)-zi
1021             dxj=dc_norm(1,nres+j)
1022             dyj=dc_norm(2,nres+j)
1023             dzj=dc_norm(3,nres+j)
1024             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1025 cd          if (icall.eq.0) then
1026 cd            rrsave(ind)=rrij
1027 cd          else
1028 cd            rrij=rrsave(ind)
1029 cd          endif
1030             rij=dsqrt(rrij)
1031             sss1=sscale(1.0d0/rij)
1032             if (sss1.eq.0.0d0) cycle
1033             sssgrad1=sscagrad(1.0d0/rij)
1034
1035 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1036             call sc_angular
1037 C Calculate whole angle-dependent part of epsilon and contributions
1038 C to its derivatives
1039             fac=(rrij*sigsq)**expon2
1040             e1=fac*fac*aa
1041             e2=fac*bb
1042             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1043             eps2der=evdwij*eps3rt
1044             eps3der=evdwij*eps2rt
1045             evdwij=evdwij*eps2rt*eps3rt
1046             ij=icant(itypi,itypj)
1047             aux=eps1*eps2rt**2*eps3rt**2
1048             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1049      &        /dabs(eps(itypi,itypj))
1050             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1051             if (bb.gt.0.0d0) then
1052               evdw=evdw+sss1*evdwij
1053             else
1054               evdw_t=evdw_t+sss1*evdwij
1055             endif
1056             if (calc_grad) then
1057             if (lprn) then
1058             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1059             epsi=bb**2/aa
1060             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1061      &        restyp(itypi),i,restyp(itypj),j,
1062      &        epsi,sigm,chi1,chi2,chip1,chip2,
1063      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1064      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1065      &        evdwij
1066             endif
1067 C Calculate gradient components.
1068             e1=e1*eps1*eps2rt**2*eps3rt**2
1069             fac=-expon*(e1+evdwij)
1070             sigder=fac/sigsq
1071             fac=rrij*fac
1072      &           +evdwij*sssgrad1/sss1*rij
1073 C Calculate radial part of the gradient
1074             gg(1)=xj*fac
1075             gg(2)=yj*fac
1076             gg(3)=zj*fac
1077 C Calculate the angular part of the gradient and sum add the contributions
1078 C to the appropriate components of the Cartesian gradient.
1079             call sc_grad
1080             endif
1081           enddo      ! j
1082         enddo        ! iint
1083       enddo          ! i
1084 c     stop
1085       return
1086       end
1087 C-----------------------------------------------------------------------------
1088       subroutine egb(evdw,evdw_t)
1089 C
1090 C This subroutine calculates the interaction energy of nonbonded side chains
1091 C assuming the Gay-Berne potential of interaction.
1092 C
1093       implicit real*8 (a-h,o-z)
1094       include 'DIMENSIONS'
1095       include 'DIMENSIONS.ZSCOPT'
1096       include "DIMENSIONS.COMPAR"
1097       include 'COMMON.CONTROL'
1098       include 'COMMON.GEO'
1099       include 'COMMON.VAR'
1100       include 'COMMON.LOCAL'
1101       include 'COMMON.CHAIN'
1102       include 'COMMON.DERIV'
1103       include 'COMMON.NAMES'
1104       include 'COMMON.INTERACT'
1105       include 'COMMON.ENEPS'
1106       include 'COMMON.IOUNITS'
1107       include 'COMMON.CALC'
1108       include 'COMMON.SBRIDGE'
1109       logical lprn
1110       common /srutu/icall
1111       integer icant,xshift,yshift,zshift
1112       external icant
1113       do i=1,210
1114         do j=1,2
1115           eneps_temp(j,i)=0.0d0
1116         enddo
1117       enddo
1118 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1119       evdw=0.0D0
1120       evdw_t=0.0d0
1121       lprn=.false.
1122 c      if (icall.gt.0) lprn=.true.
1123       ind=0
1124       do i=iatsc_s,iatsc_e
1125         itypi=iabs(itype(i))
1126         if (itypi.eq.ntyp1) cycle
1127         itypi1=iabs(itype(i+1))
1128         xi=c(1,nres+i)
1129         yi=c(2,nres+i)
1130         zi=c(3,nres+i)
1131 C returning the ith atom to box
1132           xi=mod(xi,boxxsize)
1133           if (xi.lt.0) xi=xi+boxxsize
1134           yi=mod(yi,boxysize)
1135           if (yi.lt.0) yi=yi+boxysize
1136           zi=mod(zi,boxzsize)
1137           if (zi.lt.0) zi=zi+boxzsize
1138        if ((zi.gt.bordlipbot)
1139      &.and.(zi.lt.bordliptop)) then
1140 C the energy transfer exist
1141         if (zi.lt.buflipbot) then
1142 C what fraction I am in
1143          fracinbuf=1.0d0-
1144      &        ((zi-bordlipbot)/lipbufthick)
1145 C lipbufthick is thickenes of lipid buffore
1146          sslipi=sscalelip(fracinbuf)
1147          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1148         elseif (zi.gt.bufliptop) then
1149          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1150          sslipi=sscalelip(fracinbuf)
1151          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1152         else
1153          sslipi=1.0d0
1154          ssgradlipi=0.0
1155         endif
1156        else
1157          sslipi=0.0d0
1158          ssgradlipi=0.0
1159        endif
1160
1161         dxi=dc_norm(1,nres+i)
1162         dyi=dc_norm(2,nres+i)
1163         dzi=dc_norm(3,nres+i)
1164         dsci_inv=vbld_inv(i+nres)
1165 C
1166 C Calculate SC interaction energy.
1167 C
1168         do iint=1,nint_gr(i)
1169           do j=istart(i,iint),iend(i,iint)
1170             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1171               call dyn_ssbond_ene(i,j,evdwij)
1172               evdw=evdw+evdwij
1173 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1174 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1175 C triple bond artifac removal
1176              do k=j+1,iend(i,iint)
1177 C search over all next residues
1178               if (dyn_ss_mask(k)) then
1179 C check if they are cysteins
1180 C              write(iout,*) 'k=',k
1181               call triple_ssbond_ene(i,j,k,evdwij)
1182 C call the energy function that removes the artifical triple disulfide
1183 C bond the soubroutine is located in ssMD.F
1184               evdw=evdw+evdwij
1185 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1186 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1187               endif!dyn_ss_mask(k)
1188              enddo! k
1189             ELSE
1190             ind=ind+1
1191             itypj=iabs(itype(j))
1192             if (itypj.eq.ntyp1) cycle
1193             dscj_inv=vbld_inv(j+nres)
1194             sig0ij=sigma(itypi,itypj)
1195             chi1=chi(itypi,itypj)
1196             chi2=chi(itypj,itypi)
1197             chi12=chi1*chi2
1198             chip1=chip(itypi)
1199             chip2=chip(itypj)
1200             chip12=chip1*chip2
1201             alf1=alp(itypi)
1202             alf2=alp(itypj)
1203             alf12=0.5D0*(alf1+alf2)
1204 C For diagnostics only!!!
1205 c           chi1=0.0D0
1206 c           chi2=0.0D0
1207 c           chi12=0.0D0
1208 c           chip1=0.0D0
1209 c           chip2=0.0D0
1210 c           chip12=0.0D0
1211 c           alf1=0.0D0
1212 c           alf2=0.0D0
1213 c           alf12=0.0D0
1214             xj=c(1,nres+j)
1215             yj=c(2,nres+j)
1216             zj=c(3,nres+j)
1217 C returning jth atom to box
1218           xj=mod(xj,boxxsize)
1219           if (xj.lt.0) xj=xj+boxxsize
1220           yj=mod(yj,boxysize)
1221           if (yj.lt.0) yj=yj+boxysize
1222           zj=mod(zj,boxzsize)
1223           if (zj.lt.0) zj=zj+boxzsize
1224        if ((zj.gt.bordlipbot)
1225      &.and.(zj.lt.bordliptop)) then
1226 C the energy transfer exist
1227         if (zj.lt.buflipbot) then
1228 C what fraction I am in
1229          fracinbuf=1.0d0-
1230      &        ((zj-bordlipbot)/lipbufthick)
1231 C lipbufthick is thickenes of lipid buffore
1232          sslipj=sscalelip(fracinbuf)
1233          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1234         elseif (zj.gt.bufliptop) then
1235          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1236          sslipj=sscalelip(fracinbuf)
1237          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1238         else
1239          sslipj=1.0d0
1240          ssgradlipj=0.0
1241         endif
1242        else
1243          sslipj=0.0d0
1244          ssgradlipj=0.0
1245        endif
1246       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1247      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1248       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1249      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1250 C       if (aa.ne.aa_aq(itypi,itypj)) then
1251
1252 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1253 C     & bb_aq(itypi,itypj)-bb,
1254 C     & sslipi,sslipj
1255 C         endif
1256
1257 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1258 C checking the distance
1259       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1260       xj_safe=xj
1261       yj_safe=yj
1262       zj_safe=zj
1263       subchap=0
1264 C finding the closest
1265       do xshift=-1,1
1266       do yshift=-1,1
1267       do zshift=-1,1
1268           xj=xj_safe+xshift*boxxsize
1269           yj=yj_safe+yshift*boxysize
1270           zj=zj_safe+zshift*boxzsize
1271           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1272           if(dist_temp.lt.dist_init) then
1273             dist_init=dist_temp
1274             xj_temp=xj
1275             yj_temp=yj
1276             zj_temp=zj
1277             subchap=1
1278           endif
1279        enddo
1280        enddo
1281        enddo
1282        if (subchap.eq.1) then
1283           xj=xj_temp-xi
1284           yj=yj_temp-yi
1285           zj=zj_temp-zi
1286        else
1287           xj=xj_safe-xi
1288           yj=yj_safe-yi
1289           zj=zj_safe-zi
1290        endif
1291
1292             dxj=dc_norm(1,nres+j)
1293             dyj=dc_norm(2,nres+j)
1294             dzj=dc_norm(3,nres+j)
1295 c            write (iout,*) i,j,xj,yj,zj
1296             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1297             rij=dsqrt(rrij)
1298             sss=sscale(1.0d0/rij)
1299             sssgrad=sscagrad(1.0d0/rij)
1300             if (sss.le.0.0) cycle
1301 C Calculate angle-dependent terms of energy and contributions to their
1302 C derivatives.
1303
1304             call sc_angular
1305             sigsq=1.0D0/sigsq
1306             sig=sig0ij*dsqrt(sigsq)
1307             rij_shift=1.0D0/rij-sig+sig0ij
1308 C I hate to put IF's in the loops, but here don't have another choice!!!!
1309             if (rij_shift.le.0.0D0) then
1310               evdw=1.0D20
1311               return
1312             endif
1313             sigder=-sig*sigsq
1314 c---------------------------------------------------------------
1315             rij_shift=1.0D0/rij_shift
1316             fac=rij_shift**expon
1317             e1=fac*fac*aa
1318             e2=fac*bb
1319             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1320             eps2der=evdwij*eps3rt
1321             eps3der=evdwij*eps2rt
1322             evdwij=evdwij*eps2rt*eps3rt
1323             if (bb.gt.0) then
1324               evdw=evdw+evdwij*sss
1325             else
1326               evdw_t=evdw_t+evdwij*sss
1327             endif
1328             ij=icant(itypi,itypj)
1329             aux=eps1*eps2rt**2*eps3rt**2
1330             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1331      &        /dabs(eps(itypi,itypj))
1332             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1333 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1334 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1335 c     &         aux*e2/eps(itypi,itypj)
1336 c            if (lprn) then
1337             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1338             epsi=bb**2/aa
1339 c#define DEBUG
1340 #ifdef DEBUG
1341             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1342      &        restyp(itypi),i,restyp(itypj),j,
1343      &        epsi,sigm,chi1,chi2,chip1,chip2,
1344      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1345      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1346      &        evdwij
1347              write (iout,*) "partial sum", evdw, evdw_t
1348 #endif
1349 c#undef DEBUG
1350 c            endif
1351             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
1352      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
1353             if (calc_grad) then
1354 C Calculate gradient components.
1355             e1=e1*eps1*eps2rt**2*eps3rt**2
1356             fac=-expon*(e1+evdwij)*rij_shift
1357             sigder=fac*sigder
1358             fac=rij*fac
1359             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1360 C Calculate the radial part of the gradient
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 C Calculate angular part of the gradient.
1365             call sc_grad
1366             endif
1367 C            write(iout,*)  "partial sum", evdw, evdw_t
1368             ENDIF    ! dyn_ss
1369           enddo      ! j
1370         enddo        ! iint
1371       enddo          ! i
1372       return
1373       end
1374 C-----------------------------------------------------------------------------
1375       subroutine egbv(evdw,evdw_t)
1376 C
1377 C This subroutine calculates the interaction energy of nonbonded side chains
1378 C assuming the Gay-Berne-Vorobjev potential of interaction.
1379 C
1380       implicit real*8 (a-h,o-z)
1381       include 'DIMENSIONS'
1382       include 'DIMENSIONS.ZSCOPT'
1383       include "DIMENSIONS.COMPAR"
1384       include 'COMMON.GEO'
1385       include 'COMMON.VAR'
1386       include 'COMMON.LOCAL'
1387       include 'COMMON.CHAIN'
1388       include 'COMMON.DERIV'
1389       include 'COMMON.NAMES'
1390       include 'COMMON.INTERACT'
1391       include 'COMMON.ENEPS'
1392       include 'COMMON.IOUNITS'
1393       include 'COMMON.CALC'
1394       common /srutu/ icall
1395       logical lprn
1396       integer icant
1397       external icant
1398       do i=1,210
1399         do j=1,2
1400           eneps_temp(j,i)=0.0d0
1401         enddo
1402       enddo
1403       evdw=0.0D0
1404       evdw_t=0.0d0
1405 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1406       evdw=0.0D0
1407       lprn=.false.
1408 c      if (icall.gt.0) lprn=.true.
1409       ind=0
1410       do i=iatsc_s,iatsc_e
1411         itypi=iabs(itype(i))
1412         if (itypi.eq.ntyp1) cycle
1413         itypi1=iabs(itype(i+1))
1414         xi=c(1,nres+i)
1415         yi=c(2,nres+i)
1416         zi=c(3,nres+i)
1417         dxi=dc_norm(1,nres+i)
1418         dyi=dc_norm(2,nres+i)
1419         dzi=dc_norm(3,nres+i)
1420         dsci_inv=vbld_inv(i+nres)
1421 C
1422 C Calculate SC interaction energy.
1423 C
1424         do iint=1,nint_gr(i)
1425           do j=istart(i,iint),iend(i,iint)
1426             ind=ind+1
1427             itypj=iabs(itype(j))
1428             if (itypj.eq.ntyp1) cycle
1429             dscj_inv=vbld_inv(j+nres)
1430             sig0ij=sigma(itypi,itypj)
1431             r0ij=r0(itypi,itypj)
1432             chi1=chi(itypi,itypj)
1433             chi2=chi(itypj,itypi)
1434             chi12=chi1*chi2
1435             chip1=chip(itypi)
1436             chip2=chip(itypj)
1437             chip12=chip1*chip2
1438             alf1=alp(itypi)
1439             alf2=alp(itypj)
1440             alf12=0.5D0*(alf1+alf2)
1441 C For diagnostics only!!!
1442 c           chi1=0.0D0
1443 c           chi2=0.0D0
1444 c           chi12=0.0D0
1445 c           chip1=0.0D0
1446 c           chip2=0.0D0
1447 c           chip12=0.0D0
1448 c           alf1=0.0D0
1449 c           alf2=0.0D0
1450 c           alf12=0.0D0
1451             xj=c(1,nres+j)-xi
1452             yj=c(2,nres+j)-yi
1453             zj=c(3,nres+j)-zi
1454             dxj=dc_norm(1,nres+j)
1455             dyj=dc_norm(2,nres+j)
1456             dzj=dc_norm(3,nres+j)
1457             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1458             rij=dsqrt(rrij)
1459             sss=sscale(1.0d0/rij)
1460             if (sss.eq.0.0d0) cycle
1461             sssgrad=sscagrad(1.0d0/rij)
1462 C Calculate angle-dependent terms of energy and contributions to their
1463 C derivatives.
1464             call sc_angular
1465             sigsq=1.0D0/sigsq
1466             sig=sig0ij*dsqrt(sigsq)
1467             rij_shift=1.0D0/rij-sig+r0ij
1468 C I hate to put IF's in the loops, but here don't have another choice!!!!
1469             if (rij_shift.le.0.0D0) then
1470               evdw=1.0D20
1471               return
1472             endif
1473             sigder=-sig*sigsq
1474 c---------------------------------------------------------------
1475             rij_shift=1.0D0/rij_shift
1476             fac=rij_shift**expon
1477             e1=fac*fac*aa
1478             e2=fac*bb
1479             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1480             eps2der=evdwij*eps3rt
1481             eps3der=evdwij*eps2rt
1482             fac_augm=rrij**expon
1483             e_augm=augm(itypi,itypj)*fac_augm
1484             evdwij=evdwij*eps2rt*eps3rt
1485             if (bb.gt.0.0d0) then
1486               evdw=evdw+(evdwij+e_augm)*sss
1487             else
1488               evdw_t=evdw_t+(evdwij+e_augm)*sss
1489             endif
1490             ij=icant(itypi,itypj)
1491             aux=eps1*eps2rt**2*eps3rt**2
1492             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1493      &        /dabs(eps(itypi,itypj))
1494             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1495 c            eneps_temp(ij)=eneps_temp(ij)
1496 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1497 c            if (lprn) then
1498 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1499 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1500 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1501 c     &        restyp(itypi),i,restyp(itypj),j,
1502 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1503 c     &        chi1,chi2,chip1,chip2,
1504 c     &        eps1,eps2rt**2,eps3rt**2,
1505 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1506 c     &        evdwij+e_augm
1507 c            endif
1508             if (calc_grad) then
1509 C Calculate gradient components.
1510             e1=e1*eps1*eps2rt**2*eps3rt**2
1511             fac=-expon*(e1+evdwij)*rij_shift
1512             sigder=fac*sigder
1513             fac=rij*fac-2*expon*rrij*e_augm
1514             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1515 C Calculate the radial part of the gradient
1516             gg(1)=xj*fac
1517             gg(2)=yj*fac
1518             gg(3)=zj*fac
1519 C Calculate angular part of the gradient.
1520             call sc_grad
1521             endif
1522           enddo      ! j
1523         enddo        ! iint
1524       enddo          ! i
1525       return
1526       end
1527 C-----------------------------------------------------------------------------
1528       subroutine sc_angular
1529 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1530 C om12. Called by ebp, egb, and egbv.
1531       implicit none
1532       include 'COMMON.CALC'
1533       erij(1)=xj*rij
1534       erij(2)=yj*rij
1535       erij(3)=zj*rij
1536       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1537       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1538       om12=dxi*dxj+dyi*dyj+dzi*dzj
1539       chiom12=chi12*om12
1540 C Calculate eps1(om12) and its derivative in om12
1541       faceps1=1.0D0-om12*chiom12
1542       faceps1_inv=1.0D0/faceps1
1543       eps1=dsqrt(faceps1_inv)
1544 C Following variable is eps1*deps1/dom12
1545       eps1_om12=faceps1_inv*chiom12
1546 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1547 C and om12.
1548       om1om2=om1*om2
1549       chiom1=chi1*om1
1550       chiom2=chi2*om2
1551       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1552       sigsq=1.0D0-facsig*faceps1_inv
1553       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1554       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1555       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1556 C Calculate eps2 and its derivatives in om1, om2, and om12.
1557       chipom1=chip1*om1
1558       chipom2=chip2*om2
1559       chipom12=chip12*om12
1560       facp=1.0D0-om12*chipom12
1561       facp_inv=1.0D0/facp
1562       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1563 C Following variable is the square root of eps2
1564       eps2rt=1.0D0-facp1*facp_inv
1565 C Following three variables are the derivatives of the square root of eps
1566 C in om1, om2, and om12.
1567       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1568       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1569       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1570 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1571       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1572 C Calculate whole angle-dependent part of epsilon and contributions
1573 C to its derivatives
1574       return
1575       end
1576 C----------------------------------------------------------------------------
1577       subroutine sc_grad
1578       implicit real*8 (a-h,o-z)
1579       include 'DIMENSIONS'
1580       include 'DIMENSIONS.ZSCOPT'
1581       include 'COMMON.CHAIN'
1582       include 'COMMON.DERIV'
1583       include 'COMMON.CALC'
1584       double precision dcosom1(3),dcosom2(3)
1585       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1586       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1587       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1588      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1589       do k=1,3
1590         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1591         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1592       enddo
1593       do k=1,3
1594         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1595       enddo
1596       do k=1,3
1597         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1598      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1599      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1600         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1601      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1602      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1603       enddo
1604 C
1605 C Calculate the components of the gradient in DC and X
1606 C
1607       do k=i,j-1
1608         do l=1,3
1609           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1610         enddo
1611       enddo
1612       return
1613       end
1614 c------------------------------------------------------------------------------
1615       subroutine vec_and_deriv
1616       implicit real*8 (a-h,o-z)
1617       include 'DIMENSIONS'
1618       include 'DIMENSIONS.ZSCOPT'
1619       include 'COMMON.IOUNITS'
1620       include 'COMMON.GEO'
1621       include 'COMMON.VAR'
1622       include 'COMMON.LOCAL'
1623       include 'COMMON.CHAIN'
1624       include 'COMMON.VECTORS'
1625       include 'COMMON.DERIV'
1626       include 'COMMON.INTERACT'
1627       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1628 C Compute the local reference systems. For reference system (i), the
1629 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1630 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1631       do i=1,nres-1
1632 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1633           if (i.eq.nres-1) then
1634 C Case of the last full residue
1635 C Compute the Z-axis
1636             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1637             costh=dcos(pi-theta(nres))
1638             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1639 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1640 c     &         " uz",uz(:,i)
1641             do k=1,3
1642               uz(k,i)=fac*uz(k,i)
1643             enddo
1644             if (calc_grad) then
1645 C Compute the derivatives of uz
1646             uzder(1,1,1)= 0.0d0
1647             uzder(2,1,1)=-dc_norm(3,i-1)
1648             uzder(3,1,1)= dc_norm(2,i-1)
1649             uzder(1,2,1)= dc_norm(3,i-1)
1650             uzder(2,2,1)= 0.0d0
1651             uzder(3,2,1)=-dc_norm(1,i-1)
1652             uzder(1,3,1)=-dc_norm(2,i-1)
1653             uzder(2,3,1)= dc_norm(1,i-1)
1654             uzder(3,3,1)= 0.0d0
1655             uzder(1,1,2)= 0.0d0
1656             uzder(2,1,2)= dc_norm(3,i)
1657             uzder(3,1,2)=-dc_norm(2,i)
1658             uzder(1,2,2)=-dc_norm(3,i)
1659             uzder(2,2,2)= 0.0d0
1660             uzder(3,2,2)= dc_norm(1,i)
1661             uzder(1,3,2)= dc_norm(2,i)
1662             uzder(2,3,2)=-dc_norm(1,i)
1663             uzder(3,3,2)= 0.0d0
1664             endif ! calc_grad
1665 C Compute the Y-axis
1666             facy=fac
1667             do k=1,3
1668               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1669             enddo
1670             if (calc_grad) then
1671 C Compute the derivatives of uy
1672             do j=1,3
1673               do k=1,3
1674                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1675      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1676                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1677               enddo
1678               uyder(j,j,1)=uyder(j,j,1)-costh
1679               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1680             enddo
1681             do j=1,2
1682               do k=1,3
1683                 do l=1,3
1684                   uygrad(l,k,j,i)=uyder(l,k,j)
1685                   uzgrad(l,k,j,i)=uzder(l,k,j)
1686                 enddo
1687               enddo
1688             enddo
1689             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1690             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1691             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1692             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1693             endif
1694           else
1695 C Other residues
1696 C Compute the Z-axis
1697             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1698             costh=dcos(pi-theta(i+2))
1699             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1700             do k=1,3
1701               uz(k,i)=fac*uz(k,i)
1702             enddo
1703             if (calc_grad) then
1704 C Compute the derivatives of uz
1705             uzder(1,1,1)= 0.0d0
1706             uzder(2,1,1)=-dc_norm(3,i+1)
1707             uzder(3,1,1)= dc_norm(2,i+1)
1708             uzder(1,2,1)= dc_norm(3,i+1)
1709             uzder(2,2,1)= 0.0d0
1710             uzder(3,2,1)=-dc_norm(1,i+1)
1711             uzder(1,3,1)=-dc_norm(2,i+1)
1712             uzder(2,3,1)= dc_norm(1,i+1)
1713             uzder(3,3,1)= 0.0d0
1714             uzder(1,1,2)= 0.0d0
1715             uzder(2,1,2)= dc_norm(3,i)
1716             uzder(3,1,2)=-dc_norm(2,i)
1717             uzder(1,2,2)=-dc_norm(3,i)
1718             uzder(2,2,2)= 0.0d0
1719             uzder(3,2,2)= dc_norm(1,i)
1720             uzder(1,3,2)= dc_norm(2,i)
1721             uzder(2,3,2)=-dc_norm(1,i)
1722             uzder(3,3,2)= 0.0d0
1723             endif
1724 C Compute the Y-axis
1725             facy=fac
1726             do k=1,3
1727               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1728             enddo
1729             if (calc_grad) then
1730 C Compute the derivatives of uy
1731             do j=1,3
1732               do k=1,3
1733                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1734      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1735                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1736               enddo
1737               uyder(j,j,1)=uyder(j,j,1)-costh
1738               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1739             enddo
1740             do j=1,2
1741               do k=1,3
1742                 do l=1,3
1743                   uygrad(l,k,j,i)=uyder(l,k,j)
1744                   uzgrad(l,k,j,i)=uzder(l,k,j)
1745                 enddo
1746               enddo
1747             enddo
1748             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1749             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1750             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1751             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1752           endif
1753           endif
1754       enddo
1755       if (calc_grad) then
1756       do i=1,nres-1
1757         vbld_inv_temp(1)=vbld_inv(i+1)
1758         if (i.lt.nres-1) then
1759           vbld_inv_temp(2)=vbld_inv(i+2)
1760         else
1761           vbld_inv_temp(2)=vbld_inv(i)
1762         endif
1763         do j=1,2
1764           do k=1,3
1765             do l=1,3
1766               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1767               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1768             enddo
1769           enddo
1770         enddo
1771       enddo
1772       endif
1773       return
1774       end
1775 C--------------------------------------------------------------------------
1776       subroutine set_matrices
1777       implicit real*8 (a-h,o-z)
1778       include 'DIMENSIONS'
1779 #ifdef MPI
1780       include "mpif.h"
1781       integer IERR
1782       integer status(MPI_STATUS_SIZE)
1783 #endif
1784       include 'DIMENSIONS.ZSCOPT'
1785       include 'COMMON.IOUNITS'
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.INTERACT'
1792       include 'COMMON.CORRMAT'
1793       include 'COMMON.TORSION'
1794       include 'COMMON.VECTORS'
1795       include 'COMMON.FFIELD'
1796       double precision auxvec(2),auxmat(2,2)
1797 C
1798 C Compute the virtual-bond-torsional-angle dependent quantities needed
1799 C to calculate the el-loc multibody terms of various order.
1800 C
1801 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1802       do i=3,nres+1
1803         ii=ireschain(i-2)
1804         if (ii.eq.0) cycle
1805         innt=chain_border(1,ii)
1806         inct=chain_border(2,ii)
1807 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1808         if (i.gt. innt+2 .and. i.lt.inct+2) then
1809           iti = itype2loc(itype(i-2))
1810         else
1811           iti=nloctyp
1812         endif
1813 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1814 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1815         if (i.gt. innt+1 .and. i.lt.inct+1) then
1816           iti1 = itype2loc(itype(i-1))
1817         else
1818           iti1=nloctyp
1819         endif
1820 #ifdef NEWCORR
1821         cost1=dcos(theta(i-1))
1822         sint1=dsin(theta(i-1))
1823         sint1sq=sint1*sint1
1824         sint1cub=sint1sq*sint1
1825         sint1cost1=2*sint1*cost1
1826 #ifdef DEBUG
1827         write (iout,*) "bnew1",i,iti
1828         write (iout,*) (bnew1(k,1,iti),k=1,3)
1829         write (iout,*) (bnew1(k,2,iti),k=1,3)
1830         write (iout,*) "bnew2",i,iti
1831         write (iout,*) (bnew2(k,1,iti),k=1,3)
1832         write (iout,*) (bnew2(k,2,iti),k=1,3)
1833 #endif
1834         do k=1,2
1835           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1836           b1(k,i-2)=sint1*b1k
1837           gtb1(k,i-2)=cost1*b1k-sint1sq*
1838      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1839           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1840           b2(k,i-2)=sint1*b2k
1841           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1842      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1843         enddo
1844         do k=1,2
1845           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1846           cc(1,k,i-2)=sint1sq*aux
1847           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1848      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1849           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1850           dd(1,k,i-2)=sint1sq*aux
1851           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1852      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1853         enddo
1854         cc(2,1,i-2)=cc(1,2,i-2)
1855         cc(2,2,i-2)=-cc(1,1,i-2)
1856         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1857         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1858         dd(2,1,i-2)=dd(1,2,i-2)
1859         dd(2,2,i-2)=-dd(1,1,i-2)
1860         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1861         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1862         do k=1,2
1863           do l=1,2
1864             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1865             EE(l,k,i-2)=sint1sq*aux
1866             if (calc_grad)
1867      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1868           enddo
1869         enddo
1870         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1871         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1872         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1873         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1874         if (calc_grad) then
1875         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1876         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1877         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1878         endif
1879 c        b1tilde(1,i-2)=b1(1,i-2)
1880 c        b1tilde(2,i-2)=-b1(2,i-2)
1881 c        b2tilde(1,i-2)=b2(1,i-2)
1882 c        b2tilde(2,i-2)=-b2(2,i-2)
1883 #ifdef DEBUG
1884         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1885         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1886         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1887         write (iout,*) 'theta=', theta(i-1)
1888 #endif
1889 #else
1890 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1891 c          iti = itype2loc(itype(i-2))
1892 c        else
1893 c          iti=nloctyp
1894 c        endif
1895 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1896 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1897 c          iti1 = itype2loc(itype(i-1))
1898 c        else
1899 c          iti1=nloctyp
1900 c        endif
1901         b1(1,i-2)=b(3,iti)
1902         b1(2,i-2)=b(5,iti)
1903         b2(1,i-2)=b(2,iti)
1904         b2(2,i-2)=b(4,iti)
1905         do k=1,2
1906           do l=1,2
1907            CC(k,l,i-2)=ccold(k,l,iti)
1908            DD(k,l,i-2)=ddold(k,l,iti)
1909            EE(k,l,i-2)=eeold(k,l,iti)
1910           enddo
1911         enddo
1912 #endif
1913         b1tilde(1,i-2)= b1(1,i-2)
1914         b1tilde(2,i-2)=-b1(2,i-2)
1915         b2tilde(1,i-2)= b2(1,i-2)
1916         b2tilde(2,i-2)=-b2(2,i-2)
1917 c
1918         Ctilde(1,1,i-2)= CC(1,1,i-2)
1919         Ctilde(1,2,i-2)= CC(1,2,i-2)
1920         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1921         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1922 c
1923         Dtilde(1,1,i-2)= DD(1,1,i-2)
1924         Dtilde(1,2,i-2)= DD(1,2,i-2)
1925         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1926         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1927 #ifdef DEBUG
1928         write(iout,*) "i",i," iti",iti
1929         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1930         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1931 #endif
1932       enddo
1933       do i=3,nres+1
1934         if (i .lt. nres+1) then
1935           sin1=dsin(phi(i))
1936           cos1=dcos(phi(i))
1937           sintab(i-2)=sin1
1938           costab(i-2)=cos1
1939           obrot(1,i-2)=cos1
1940           obrot(2,i-2)=sin1
1941           sin2=dsin(2*phi(i))
1942           cos2=dcos(2*phi(i))
1943           sintab2(i-2)=sin2
1944           costab2(i-2)=cos2
1945           obrot2(1,i-2)=cos2
1946           obrot2(2,i-2)=sin2
1947           Ug(1,1,i-2)=-cos1
1948           Ug(1,2,i-2)=-sin1
1949           Ug(2,1,i-2)=-sin1
1950           Ug(2,2,i-2)= cos1
1951           Ug2(1,1,i-2)=-cos2
1952           Ug2(1,2,i-2)=-sin2
1953           Ug2(2,1,i-2)=-sin2
1954           Ug2(2,2,i-2)= cos2
1955         else
1956           costab(i-2)=1.0d0
1957           sintab(i-2)=0.0d0
1958           obrot(1,i-2)=1.0d0
1959           obrot(2,i-2)=0.0d0
1960           obrot2(1,i-2)=0.0d0
1961           obrot2(2,i-2)=0.0d0
1962           Ug(1,1,i-2)=1.0d0
1963           Ug(1,2,i-2)=0.0d0
1964           Ug(2,1,i-2)=0.0d0
1965           Ug(2,2,i-2)=1.0d0
1966           Ug2(1,1,i-2)=0.0d0
1967           Ug2(1,2,i-2)=0.0d0
1968           Ug2(2,1,i-2)=0.0d0
1969           Ug2(2,2,i-2)=0.0d0
1970         endif
1971         if (i .gt. 3 .and. i .lt. nres+1) then
1972           obrot_der(1,i-2)=-sin1
1973           obrot_der(2,i-2)= cos1
1974           Ugder(1,1,i-2)= sin1
1975           Ugder(1,2,i-2)=-cos1
1976           Ugder(2,1,i-2)=-cos1
1977           Ugder(2,2,i-2)=-sin1
1978           dwacos2=cos2+cos2
1979           dwasin2=sin2+sin2
1980           obrot2_der(1,i-2)=-dwasin2
1981           obrot2_der(2,i-2)= dwacos2
1982           Ug2der(1,1,i-2)= dwasin2
1983           Ug2der(1,2,i-2)=-dwacos2
1984           Ug2der(2,1,i-2)=-dwacos2
1985           Ug2der(2,2,i-2)=-dwasin2
1986         else
1987           obrot_der(1,i-2)=0.0d0
1988           obrot_der(2,i-2)=0.0d0
1989           Ugder(1,1,i-2)=0.0d0
1990           Ugder(1,2,i-2)=0.0d0
1991           Ugder(2,1,i-2)=0.0d0
1992           Ugder(2,2,i-2)=0.0d0
1993           obrot2_der(1,i-2)=0.0d0
1994           obrot2_der(2,i-2)=0.0d0
1995           Ug2der(1,1,i-2)=0.0d0
1996           Ug2der(1,2,i-2)=0.0d0
1997           Ug2der(2,1,i-2)=0.0d0
1998           Ug2der(2,2,i-2)=0.0d0
1999         endif
2000 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2001         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2002           iti = itype2loc(itype(i-2))
2003         else
2004           iti=nloctyp
2005         endif
2006 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2007         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2008           iti1 = itype2loc(itype(i-1))
2009         else
2010           iti1=nloctyp
2011         endif
2012 cd        write (iout,*) '*******i',i,' iti1',iti
2013 cd        write (iout,*) 'b1',b1(:,iti)
2014 cd        write (iout,*) 'b2',b2(:,iti)
2015 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2016 c        if (i .gt. iatel_s+2) then
2017         if (i .gt. nnt+2) then
2018           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2019 #ifdef NEWCORR
2020           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2021 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2022 #endif
2023 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2024 c     &    EE(1,2,iti),EE(2,2,i)
2025           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2026           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2027 c          write(iout,*) "Macierz EUG",
2028 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2029 c     &    eug(2,2,i-2)
2030 #ifdef FOURBODY
2031           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2032      &    then
2033           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2034           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2035           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2036           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2037           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2038           endif
2039 #endif
2040         else
2041           do k=1,2
2042             Ub2(k,i-2)=0.0d0
2043             Ctobr(k,i-2)=0.0d0
2044             Dtobr2(k,i-2)=0.0d0
2045             do l=1,2
2046               EUg(l,k,i-2)=0.0d0
2047               CUg(l,k,i-2)=0.0d0
2048               DUg(l,k,i-2)=0.0d0
2049               DtUg2(l,k,i-2)=0.0d0
2050             enddo
2051           enddo
2052         endif
2053         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2054         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2055         do k=1,2
2056           muder(k,i-2)=Ub2der(k,i-2)
2057         enddo
2058 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2059         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2060           if (itype(i-1).le.ntyp) then
2061             iti1 = itype2loc(itype(i-1))
2062           else
2063             iti1=nloctyp
2064           endif
2065         else
2066           iti1=nloctyp
2067         endif
2068         do k=1,2
2069           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2070         enddo
2071 #ifdef MUOUT
2072         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2073      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2074      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2075      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2076      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2077      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2078 #endif
2079 cd        write (iout,*) 'mu1',mu1(:,i-2)
2080 cd        write (iout,*) 'mu2',mu2(:,i-2)
2081 #ifdef FOURBODY
2082         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2083      &  then
2084         if (calc_grad) then
2085         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2086         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2087         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2088         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2089         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2090         endif
2091 C Vectors and matrices dependent on a single virtual-bond dihedral.
2092         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2093         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2094         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2095         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2096         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2097         if (calc_grad) then
2098         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2099         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2100         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2101         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2102         endif
2103         endif
2104 #endif
2105       enddo
2106 #ifdef FOURBODY
2107 C Matrices dependent on two consecutive virtual-bond dihedrals.
2108 C The order of matrices is from left to right.
2109       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2110      &then
2111       do i=2,nres-1
2112         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2113         if (calc_grad) then
2114         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2115         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2116         endif
2117         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2118         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2119         if (calc_grad) then
2120         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2121         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2122         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2123         endif
2124       enddo
2125       endif
2126 #endif
2127       return
2128       end
2129 C--------------------------------------------------------------------------
2130       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2131 C
2132 C This subroutine calculates the average interaction energy and its gradient
2133 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2134 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2135 C The potential depends both on the distance of peptide-group centers and on
2136 C the orientation of the CA-CA virtual bonds.
2137 C
2138       implicit real*8 (a-h,o-z)
2139 #ifdef MPI
2140       include 'mpif.h'
2141 #endif
2142       include 'DIMENSIONS'
2143       include 'DIMENSIONS.ZSCOPT'
2144       include 'COMMON.CONTROL'
2145       include 'COMMON.IOUNITS'
2146       include 'COMMON.GEO'
2147       include 'COMMON.VAR'
2148       include 'COMMON.LOCAL'
2149       include 'COMMON.CHAIN'
2150       include 'COMMON.DERIV'
2151       include 'COMMON.INTERACT'
2152 #ifdef FOURBODY
2153       include 'COMMON.CONTACTS'
2154       include 'COMMON.CONTMAT'
2155 #endif
2156       include 'COMMON.CORRMAT'
2157       include 'COMMON.TORSION'
2158       include 'COMMON.VECTORS'
2159       include 'COMMON.FFIELD'
2160       include 'COMMON.TIME1'
2161       include 'COMMON.SPLITELE'
2162       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2163      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2164       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2165      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2166       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2167      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2168      &    num_conti,j1,j2
2169 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2170 #ifdef MOMENT
2171       double precision scal_el /1.0d0/
2172 #else
2173       double precision scal_el /0.5d0/
2174 #endif
2175 C 12/13/98
2176 C 13-go grudnia roku pamietnego...
2177       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2178      &                   0.0d0,1.0d0,0.0d0,
2179      &                   0.0d0,0.0d0,1.0d0/
2180 cd      write(iout,*) 'In EELEC'
2181 cd      do i=1,nloctyp
2182 cd        write(iout,*) 'Type',i
2183 cd        write(iout,*) 'B1',B1(:,i)
2184 cd        write(iout,*) 'B2',B2(:,i)
2185 cd        write(iout,*) 'CC',CC(:,:,i)
2186 cd        write(iout,*) 'DD',DD(:,:,i)
2187 cd        write(iout,*) 'EE',EE(:,:,i)
2188 cd      enddo
2189 cd      call check_vecgrad
2190 cd      stop
2191       if (icheckgrad.eq.1) then
2192         do i=1,nres-1
2193           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2194           do k=1,3
2195             dc_norm(k,i)=dc(k,i)*fac
2196           enddo
2197 c          write (iout,*) 'i',i,' fac',fac
2198         enddo
2199       endif
2200       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2201      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2202      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2203 c        call vec_and_deriv
2204 #ifdef TIMING
2205         time01=MPI_Wtime()
2206 #endif
2207         call set_matrices
2208 #ifdef TIMING
2209         time_mat=time_mat+MPI_Wtime()-time01
2210 #endif
2211       endif
2212 cd      do i=1,nres-1
2213 cd        write (iout,*) 'i=',i
2214 cd        do k=1,3
2215 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2216 cd        enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2219 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2220 cd        enddo
2221 cd      enddo
2222       t_eelecij=0.0d0
2223       ees=0.0D0
2224       evdw1=0.0D0
2225       eel_loc=0.0d0
2226       eello_turn3=0.0d0
2227       eello_turn4=0.0d0
2228       ind=0
2229 #ifdef FOURBODY
2230       do i=1,nres
2231         num_cont_hb(i)=0
2232       enddo
2233 #endif
2234 cd      print '(a)','Enter EELEC'
2235 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2236       do i=1,nres
2237         gel_loc_loc(i)=0.0d0
2238         gcorr_loc(i)=0.0d0
2239       enddo
2240 c
2241 c
2242 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2243 C
2244 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2245 C
2246 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2247       do i=iturn3_start,iturn3_end
2248 c        if (i.le.1) cycle
2249 C        write(iout,*) "tu jest i",i
2250         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2251 C changes suggested by Ana to avoid out of bounds
2252 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2253 c     & .or.((i+4).gt.nres)
2254 c     & .or.((i-1).le.0)
2255 C end of changes by Ana
2256 C dobra zmiana wycofana
2257      &  .or. itype(i+2).eq.ntyp1
2258      &  .or. itype(i+3).eq.ntyp1) cycle
2259 C Adam: Instructions below will switch off existing interactions
2260 c        if(i.gt.1)then
2261 c          if(itype(i-1).eq.ntyp1)cycle
2262 c        end if
2263 c        if(i.LT.nres-3)then
2264 c          if (itype(i+4).eq.ntyp1) cycle
2265 c        end if
2266         dxi=dc(1,i)
2267         dyi=dc(2,i)
2268         dzi=dc(3,i)
2269         dx_normi=dc_norm(1,i)
2270         dy_normi=dc_norm(2,i)
2271         dz_normi=dc_norm(3,i)
2272         xmedi=c(1,i)+0.5d0*dxi
2273         ymedi=c(2,i)+0.5d0*dyi
2274         zmedi=c(3,i)+0.5d0*dzi
2275           xmedi=mod(xmedi,boxxsize)
2276           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2277           ymedi=mod(ymedi,boxysize)
2278           if (ymedi.lt.0) ymedi=ymedi+boxysize
2279           zmedi=mod(zmedi,boxzsize)
2280           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2281         num_conti=0
2282         call eelecij(i,i+2,ees,evdw1,eel_loc)
2283         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2284 #ifdef FOURBODY
2285         num_cont_hb(i)=num_conti
2286 #endif
2287       enddo
2288       do i=iturn4_start,iturn4_end
2289         if (i.lt.1) cycle
2290         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2291 C changes suggested by Ana to avoid out of bounds
2292 c     & .or.((i+5).gt.nres)
2293 c     & .or.((i-1).le.0)
2294 C end of changes suggested by Ana
2295      &    .or. itype(i+3).eq.ntyp1
2296      &    .or. itype(i+4).eq.ntyp1
2297 c     &    .or. itype(i+5).eq.ntyp1
2298 c     &    .or. itype(i).eq.ntyp1
2299 c     &    .or. itype(i-1).eq.ntyp1
2300      &                             ) cycle
2301         dxi=dc(1,i)
2302         dyi=dc(2,i)
2303         dzi=dc(3,i)
2304         dx_normi=dc_norm(1,i)
2305         dy_normi=dc_norm(2,i)
2306         dz_normi=dc_norm(3,i)
2307         xmedi=c(1,i)+0.5d0*dxi
2308         ymedi=c(2,i)+0.5d0*dyi
2309         zmedi=c(3,i)+0.5d0*dzi
2310 C Return atom into box, boxxsize is size of box in x dimension
2311 c  194   continue
2312 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2313 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2314 C Condition for being inside the proper box
2315 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2316 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2317 c        go to 194
2318 c        endif
2319 c  195   continue
2320 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2321 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2322 C Condition for being inside the proper box
2323 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2324 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2325 c        go to 195
2326 c        endif
2327 c  196   continue
2328 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2329 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2330 C Condition for being inside the proper box
2331 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2332 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2333 c        go to 196
2334 c        endif
2335           xmedi=mod(xmedi,boxxsize)
2336           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2337           ymedi=mod(ymedi,boxysize)
2338           if (ymedi.lt.0) ymedi=ymedi+boxysize
2339           zmedi=mod(zmedi,boxzsize)
2340           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2341 #ifdef FOURBODY
2342         num_conti=num_cont_hb(i)
2343 #endif
2344 c        write(iout,*) "JESTEM W PETLI"
2345         call eelecij(i,i+3,ees,evdw1,eel_loc)
2346         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2347      &   call eturn4(i,eello_turn4)
2348 #ifdef FOURBODY
2349         num_cont_hb(i)=num_conti
2350 #endif
2351       enddo   ! i
2352 C Loop over all neighbouring boxes
2353 C      do xshift=-1,1
2354 C      do yshift=-1,1
2355 C      do zshift=-1,1
2356 c
2357 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2358 c
2359 CTU KURWA
2360       do i=iatel_s,iatel_e
2361 C        do i=75,75
2362 c        if (i.le.1) cycle
2363         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2364 C changes suggested by Ana to avoid out of bounds
2365 c     & .or.((i+2).gt.nres)
2366 c     & .or.((i-1).le.0)
2367 C end of changes by Ana
2368 c     &  .or. itype(i+2).eq.ntyp1
2369 c     &  .or. itype(i-1).eq.ntyp1
2370      &                ) cycle
2371         dxi=dc(1,i)
2372         dyi=dc(2,i)
2373         dzi=dc(3,i)
2374         dx_normi=dc_norm(1,i)
2375         dy_normi=dc_norm(2,i)
2376         dz_normi=dc_norm(3,i)
2377         xmedi=c(1,i)+0.5d0*dxi
2378         ymedi=c(2,i)+0.5d0*dyi
2379         zmedi=c(3,i)+0.5d0*dzi
2380           xmedi=mod(xmedi,boxxsize)
2381           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2382           ymedi=mod(ymedi,boxysize)
2383           if (ymedi.lt.0) ymedi=ymedi+boxysize
2384           zmedi=mod(zmedi,boxzsize)
2385           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2386 C          xmedi=xmedi+xshift*boxxsize
2387 C          ymedi=ymedi+yshift*boxysize
2388 C          zmedi=zmedi+zshift*boxzsize
2389
2390 C Return tom into box, boxxsize is size of box in x dimension
2391 c  164   continue
2392 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2393 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2394 C Condition for being inside the proper box
2395 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2396 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2397 c        go to 164
2398 c        endif
2399 c  165   continue
2400 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2401 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2402 C Condition for being inside the proper box
2403 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2404 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2405 c        go to 165
2406 c        endif
2407 c  166   continue
2408 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2409 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2410 cC Condition for being inside the proper box
2411 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2412 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2413 c        go to 166
2414 c        endif
2415
2416 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2417 #ifdef FOURBODY
2418         num_conti=num_cont_hb(i)
2419 #endif
2420 C I TU KURWA
2421         do j=ielstart(i),ielend(i)
2422 C          do j=16,17
2423 C          write (iout,*) i,j
2424 C         if (j.le.1) cycle
2425           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2426 C changes suggested by Ana to avoid out of bounds
2427 c     & .or.((j+2).gt.nres)
2428 c     & .or.((j-1).le.0)
2429 C end of changes by Ana
2430 c     & .or.itype(j+2).eq.ntyp1
2431 c     & .or.itype(j-1).eq.ntyp1
2432      &) cycle
2433           call eelecij(i,j,ees,evdw1,eel_loc)
2434         enddo ! j
2435 #ifdef FOURBODY
2436         num_cont_hb(i)=num_conti
2437 #endif
2438       enddo   ! i
2439 C     enddo   ! zshift
2440 C      enddo   ! yshift
2441 C      enddo   ! xshift
2442
2443 c      write (iout,*) "Number of loop steps in EELEC:",ind
2444 cd      do i=1,nres
2445 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2446 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2447 cd      enddo
2448 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2449 ccc      eel_loc=eel_loc+eello_turn3
2450 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2451       return
2452       end
2453 C-------------------------------------------------------------------------------
2454       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2455       implicit real*8 (a-h,o-z)
2456       include 'DIMENSIONS'
2457       include 'DIMENSIONS.ZSCOPT'
2458 #ifdef MPI
2459       include "mpif.h"
2460 #endif
2461       include 'COMMON.CONTROL'
2462       include 'COMMON.IOUNITS'
2463       include 'COMMON.GEO'
2464       include 'COMMON.VAR'
2465       include 'COMMON.LOCAL'
2466       include 'COMMON.CHAIN'
2467       include 'COMMON.DERIV'
2468       include 'COMMON.INTERACT'
2469 #ifdef FOURBODY
2470       include 'COMMON.CONTACTS'
2471       include 'COMMON.CONTMAT'
2472 #endif
2473       include 'COMMON.CORRMAT'
2474       include 'COMMON.TORSION'
2475       include 'COMMON.VECTORS'
2476       include 'COMMON.FFIELD'
2477       include 'COMMON.TIME1'
2478       include 'COMMON.SPLITELE'
2479       include 'COMMON.SHIELD'
2480       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2481      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2482       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2483      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2484      &    gmuij2(4),gmuji2(4)
2485       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2486      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2487      &    num_conti,j1,j2
2488 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2489 #ifdef MOMENT
2490       double precision scal_el /1.0d0/
2491 #else
2492       double precision scal_el /0.5d0/
2493 #endif
2494 C 12/13/98
2495 C 13-go grudnia roku pamietnego...
2496       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2497      &                   0.0d0,1.0d0,0.0d0,
2498      &                   0.0d0,0.0d0,1.0d0/
2499        integer xshift,yshift,zshift
2500 c          time00=MPI_Wtime()
2501 cd      write (iout,*) "eelecij",i,j
2502 c          ind=ind+1
2503           iteli=itel(i)
2504           itelj=itel(j)
2505           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2506           aaa=app(iteli,itelj)
2507           bbb=bpp(iteli,itelj)
2508           ael6i=ael6(iteli,itelj)
2509           ael3i=ael3(iteli,itelj)
2510           dxj=dc(1,j)
2511           dyj=dc(2,j)
2512           dzj=dc(3,j)
2513           dx_normj=dc_norm(1,j)
2514           dy_normj=dc_norm(2,j)
2515           dz_normj=dc_norm(3,j)
2516 C          xj=c(1,j)+0.5D0*dxj-xmedi
2517 C          yj=c(2,j)+0.5D0*dyj-ymedi
2518 C          zj=c(3,j)+0.5D0*dzj-zmedi
2519           xj=c(1,j)+0.5D0*dxj
2520           yj=c(2,j)+0.5D0*dyj
2521           zj=c(3,j)+0.5D0*dzj
2522           xj=mod(xj,boxxsize)
2523           if (xj.lt.0) xj=xj+boxxsize
2524           yj=mod(yj,boxysize)
2525           if (yj.lt.0) yj=yj+boxysize
2526           zj=mod(zj,boxzsize)
2527           if (zj.lt.0) zj=zj+boxzsize
2528           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2529       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2530       xj_safe=xj
2531       yj_safe=yj
2532       zj_safe=zj
2533       isubchap=0
2534       do xshift=-1,1
2535       do yshift=-1,1
2536       do zshift=-1,1
2537           xj=xj_safe+xshift*boxxsize
2538           yj=yj_safe+yshift*boxysize
2539           zj=zj_safe+zshift*boxzsize
2540           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2541           if(dist_temp.lt.dist_init) then
2542             dist_init=dist_temp
2543             xj_temp=xj
2544             yj_temp=yj
2545             zj_temp=zj
2546             isubchap=1
2547           endif
2548        enddo
2549        enddo
2550        enddo
2551        if (isubchap.eq.1) then
2552           xj=xj_temp-xmedi
2553           yj=yj_temp-ymedi
2554           zj=zj_temp-zmedi
2555        else
2556           xj=xj_safe-xmedi
2557           yj=yj_safe-ymedi
2558           zj=zj_safe-zmedi
2559        endif
2560 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2561 c  174   continue
2562 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2563 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2564 C Condition for being inside the proper box
2565 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2566 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2567 c        go to 174
2568 c        endif
2569 c  175   continue
2570 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2571 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2572 C Condition for being inside the proper box
2573 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2574 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2575 c        go to 175
2576 c        endif
2577 c  176   continue
2578 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2579 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2580 C Condition for being inside the proper box
2581 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2582 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2583 c        go to 176
2584 c        endif
2585 C        endif !endPBC condintion
2586 C        xj=xj-xmedi
2587 C        yj=yj-ymedi
2588 C        zj=zj-zmedi
2589           rij=xj*xj+yj*yj+zj*zj
2590
2591           sss=sscale(sqrt(rij))
2592           if (sss.eq.0.0d0) return
2593           sssgrad=sscagrad(sqrt(rij))
2594 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2595 c     &       " rlamb",rlamb," sss",sss
2596 c            if (sss.gt.0.0d0) then
2597           rrmij=1.0D0/rij
2598           rij=dsqrt(rij)
2599           rmij=1.0D0/rij
2600           r3ij=rrmij*rmij
2601           r6ij=r3ij*r3ij
2602           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2603           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2604           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2605           fac=cosa-3.0D0*cosb*cosg
2606           ev1=aaa*r6ij*r6ij
2607 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2608           if (j.eq.i+2) ev1=scal_el*ev1
2609           ev2=bbb*r6ij
2610           fac3=ael6i*r6ij
2611           fac4=ael3i*r3ij
2612           evdwij=(ev1+ev2)
2613           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2614           el2=fac4*fac
2615 C MARYSIA
2616 C          eesij=(el1+el2)
2617 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2618           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2619           if (shield_mode.gt.0) then
2620 C          fac_shield(i)=0.4
2621 C          fac_shield(j)=0.6
2622           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2623           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2624           eesij=(el1+el2)
2625           ees=ees+eesij
2626           else
2627           fac_shield(i)=1.0
2628           fac_shield(j)=1.0
2629           eesij=(el1+el2)
2630           ees=ees+eesij
2631           endif
2632           evdw1=evdw1+evdwij*sss
2633 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2634 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2635 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2636 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2637
2638           if (energy_dec) then
2639               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2640      &'evdw1',i,j,evdwij
2641      &,iteli,itelj,aaa,evdw1,sss
2642               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2643      &fac_shield(i),fac_shield(j)
2644           endif
2645
2646 C
2647 C Calculate contributions to the Cartesian gradient.
2648 C
2649 #ifdef SPLITELE
2650           facvdw=-6*rrmij*(ev1+evdwij)*sss
2651           facel=-3*rrmij*(el1+eesij)
2652           fac1=fac
2653           erij(1)=xj*rmij
2654           erij(2)=yj*rmij
2655           erij(3)=zj*rmij
2656
2657 *
2658 * Radial derivatives. First process both termini of the fragment (i,j)
2659 *
2660           if (calc_grad) then
2661           ggg(1)=facel*xj
2662           ggg(2)=facel*yj
2663           ggg(3)=facel*zj
2664           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2665      &  (shield_mode.gt.0)) then
2666 C          print *,i,j
2667           do ilist=1,ishield_list(i)
2668            iresshield=shield_list(ilist,i)
2669            do k=1,3
2670            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2671      &      *2.0
2672            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2673      &              rlocshield
2674      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2675             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2676 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2677 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2678 C             if (iresshield.gt.i) then
2679 C               do ishi=i+1,iresshield-1
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             else
2685 C               do ishi=iresshield,i
2686 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2687 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2688 C
2689 C               enddo
2690 C              endif
2691            enddo
2692           enddo
2693           do ilist=1,ishield_list(j)
2694            iresshield=shield_list(ilist,j)
2695            do k=1,3
2696            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2697      &     *2.0
2698            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2699      &              rlocshield
2700      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2701            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2702
2703 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2704 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2705 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2706 C             if (iresshield.gt.j) then
2707 C               do ishi=j+1,iresshield-1
2708 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2709 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2710 C
2711 C               enddo
2712 C            else
2713 C               do ishi=iresshield,j
2714 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2715 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2716 C               enddo
2717 C              endif
2718            enddo
2719           enddo
2720
2721           do k=1,3
2722             gshieldc(k,i)=gshieldc(k,i)+
2723      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2724             gshieldc(k,j)=gshieldc(k,j)+
2725      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2726             gshieldc(k,i-1)=gshieldc(k,i-1)+
2727      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2728             gshieldc(k,j-1)=gshieldc(k,j-1)+
2729      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2730
2731            enddo
2732            endif
2733 c          do k=1,3
2734 c            ghalf=0.5D0*ggg(k)
2735 c            gelc(k,i)=gelc(k,i)+ghalf
2736 c            gelc(k,j)=gelc(k,j)+ghalf
2737 c          enddo
2738 c 9/28/08 AL Gradient compotents will be summed only at the end
2739 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2740           do k=1,3
2741             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2742 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2743             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2744 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2745 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2746 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2747 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2748 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2749           enddo
2750 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2751
2752 *
2753 * Loop over residues i+1 thru j-1.
2754 *
2755 cgrad          do k=i+1,j-1
2756 cgrad            do l=1,3
2757 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2758 cgrad            enddo
2759 cgrad          enddo
2760           if (sss.gt.0.0) then
2761           facvdw=facvdw+sssgrad*rmij*evdwij
2762           ggg(1)=facvdw*xj
2763           ggg(2)=facvdw*yj
2764           ggg(3)=facvdw*zj
2765           else
2766           ggg(1)=0.0
2767           ggg(2)=0.0
2768           ggg(3)=0.0
2769           endif
2770 c          do k=1,3
2771 c            ghalf=0.5D0*ggg(k)
2772 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2773 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2774 c          enddo
2775 c 9/28/08 AL Gradient compotents will be summed only at the end
2776           do k=1,3
2777             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2778             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2779           enddo
2780 *
2781 * Loop over residues i+1 thru j-1.
2782 *
2783 cgrad          do k=i+1,j-1
2784 cgrad            do l=1,3
2785 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2786 cgrad            enddo
2787 cgrad          enddo
2788           endif ! calc_grad
2789 #else
2790 C MARYSIA
2791           facvdw=(ev1+evdwij)
2792           facel=(el1+eesij)
2793           fac1=fac
2794           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2795      &       +(evdwij+eesij)*sssgrad*rrmij
2796           erij(1)=xj*rmij
2797           erij(2)=yj*rmij
2798           erij(3)=zj*rmij
2799 *
2800 * Radial derivatives. First process both termini of the fragment (i,j)
2801 *
2802           if (calc_grad) then
2803           ggg(1)=fac*xj
2804 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2805           ggg(2)=fac*yj
2806 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2807           ggg(3)=fac*zj
2808 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2809 c          do k=1,3
2810 c            ghalf=0.5D0*ggg(k)
2811 c            gelc(k,i)=gelc(k,i)+ghalf
2812 c            gelc(k,j)=gelc(k,j)+ghalf
2813 c          enddo
2814 c 9/28/08 AL Gradient compotents will be summed only at the end
2815           do k=1,3
2816             gelc_long(k,j)=gelc(k,j)+ggg(k)
2817             gelc_long(k,i)=gelc(k,i)-ggg(k)
2818           enddo
2819 *
2820 * Loop over residues i+1 thru j-1.
2821 *
2822 cgrad          do k=i+1,j-1
2823 cgrad            do l=1,3
2824 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2825 cgrad            enddo
2826 cgrad          enddo
2827 c 9/28/08 AL Gradient compotents will be summed only at the end
2828           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2829           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2830           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2831           do k=1,3
2832             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2833             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2834           enddo
2835           endif ! calc_grad
2836 #endif
2837 *
2838 * Angular part
2839 *
2840           if (calc_grad) then
2841           ecosa=2.0D0*fac3*fac1+fac4
2842           fac4=-3.0D0*fac4
2843           fac3=-6.0D0*fac3
2844           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2845           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2846           do k=1,3
2847             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2848             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2849           enddo
2850 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2851 cd   &          (dcosg(k),k=1,3)
2852           do k=1,3
2853             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2854      &      fac_shield(i)**2*fac_shield(j)**2
2855           enddo
2856 c          do k=1,3
2857 c            ghalf=0.5D0*ggg(k)
2858 c            gelc(k,i)=gelc(k,i)+ghalf
2859 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2860 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2861 c            gelc(k,j)=gelc(k,j)+ghalf
2862 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2863 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2864 c          enddo
2865 cgrad          do k=i+1,j-1
2866 cgrad            do l=1,3
2867 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2868 cgrad            enddo
2869 cgrad          enddo
2870 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2871           do k=1,3
2872             gelc(k,i)=gelc(k,i)
2873      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2874      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2875      &           *fac_shield(i)**2*fac_shield(j)**2
2876             gelc(k,j)=gelc(k,j)
2877      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2878      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2879      &           *fac_shield(i)**2*fac_shield(j)**2
2880             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2881             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2882           enddo
2883 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2884
2885 C MARYSIA
2886 c          endif !sscale
2887           endif ! calc_grad
2888           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2889      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2890      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2891 C
2892 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2893 C   energy of a peptide unit is assumed in the form of a second-order
2894 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2895 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2896 C   are computed for EVERY pair of non-contiguous peptide groups.
2897 C
2898
2899           if (j.lt.nres-1) then
2900             j1=j+1
2901             j2=j-1
2902           else
2903             j1=j-1
2904             j2=j-2
2905           endif
2906           kkk=0
2907           lll=0
2908           do k=1,2
2909             do l=1,2
2910               kkk=kkk+1
2911               muij(kkk)=mu(k,i)*mu(l,j)
2912 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2913 #ifdef NEWCORR
2914              if (calc_grad) then
2915              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2916 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2917              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2918              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2919 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2920              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2921              endif
2922 #endif
2923             enddo
2924           enddo
2925 #ifdef DEBUG
2926           write (iout,*) 'EELEC: i',i,' j',j
2927           write (iout,*) 'j',j,' j1',j1,' j2',j2
2928           write(iout,*) 'muij',muij
2929           write (iout,*) "uy",uy(:,i)
2930           write (iout,*) "uz",uz(:,j)
2931           write (iout,*) "erij",erij
2932 #endif
2933           ury=scalar(uy(1,i),erij)
2934           urz=scalar(uz(1,i),erij)
2935           vry=scalar(uy(1,j),erij)
2936           vrz=scalar(uz(1,j),erij)
2937           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2938           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2939           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2940           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2941           fac=dsqrt(-ael6i)*r3ij
2942           a22=a22*fac
2943           a23=a23*fac
2944           a32=a32*fac
2945           a33=a33*fac
2946 cd          write (iout,'(4i5,4f10.5)')
2947 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2948 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2949 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2950 cd     &      uy(:,j),uz(:,j)
2951 cd          write (iout,'(4f10.5)')
2952 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2953 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2954 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2955 cd           write (iout,'(9f10.5/)')
2956 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2957 C Derivatives of the elements of A in virtual-bond vectors
2958           if (calc_grad) then
2959           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2960           do k=1,3
2961             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2962             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2963             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2964             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2965             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2966             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2967             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2968             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2969             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2970             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2971             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2972             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2973           enddo
2974 C Compute radial contributions to the gradient
2975           facr=-3.0d0*rrmij
2976           a22der=a22*facr
2977           a23der=a23*facr
2978           a32der=a32*facr
2979           a33der=a33*facr
2980           agg(1,1)=a22der*xj
2981           agg(2,1)=a22der*yj
2982           agg(3,1)=a22der*zj
2983           agg(1,2)=a23der*xj
2984           agg(2,2)=a23der*yj
2985           agg(3,2)=a23der*zj
2986           agg(1,3)=a32der*xj
2987           agg(2,3)=a32der*yj
2988           agg(3,3)=a32der*zj
2989           agg(1,4)=a33der*xj
2990           agg(2,4)=a33der*yj
2991           agg(3,4)=a33der*zj
2992 C Add the contributions coming from er
2993           fac3=-3.0d0*fac
2994           do k=1,3
2995             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2996             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2997             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2998             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2999           enddo
3000           do k=1,3
3001 C Derivatives in DC(i)
3002 cgrad            ghalf1=0.5d0*agg(k,1)
3003 cgrad            ghalf2=0.5d0*agg(k,2)
3004 cgrad            ghalf3=0.5d0*agg(k,3)
3005 cgrad            ghalf4=0.5d0*agg(k,4)
3006             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3007      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3008             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3009      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3010             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3011      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3012             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3013      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3014 C Derivatives in DC(i+1)
3015             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3016      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3017             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3018      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3019             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3020      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3021             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3022      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3023 C Derivatives in DC(j)
3024             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3025      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3026             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3027      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3028             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3029      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3030             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3031      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3032 C Derivatives in DC(j+1) or DC(nres-1)
3033             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3034      &      -3.0d0*vryg(k,3)*ury)
3035             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3036      &      -3.0d0*vrzg(k,3)*ury)
3037             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3038      &      -3.0d0*vryg(k,3)*urz)
3039             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3040      &      -3.0d0*vrzg(k,3)*urz)
3041 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3042 cgrad              do l=1,4
3043 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3044 cgrad              enddo
3045 cgrad            endif
3046           enddo
3047           endif ! calc_grad
3048           acipa(1,1)=a22
3049           acipa(1,2)=a23
3050           acipa(2,1)=a32
3051           acipa(2,2)=a33
3052           a22=-a22
3053           a23=-a23
3054           if (calc_grad) then
3055           do l=1,2
3056             do k=1,3
3057               agg(k,l)=-agg(k,l)
3058               aggi(k,l)=-aggi(k,l)
3059               aggi1(k,l)=-aggi1(k,l)
3060               aggj(k,l)=-aggj(k,l)
3061               aggj1(k,l)=-aggj1(k,l)
3062             enddo
3063           enddo
3064           endif ! calc_grad
3065           if (j.lt.nres-1) then
3066             a22=-a22
3067             a32=-a32
3068             do l=1,3,2
3069               do k=1,3
3070                 agg(k,l)=-agg(k,l)
3071                 aggi(k,l)=-aggi(k,l)
3072                 aggi1(k,l)=-aggi1(k,l)
3073                 aggj(k,l)=-aggj(k,l)
3074                 aggj1(k,l)=-aggj1(k,l)
3075               enddo
3076             enddo
3077           else
3078             a22=-a22
3079             a23=-a23
3080             a32=-a32
3081             a33=-a33
3082             do l=1,4
3083               do k=1,3
3084                 agg(k,l)=-agg(k,l)
3085                 aggi(k,l)=-aggi(k,l)
3086                 aggi1(k,l)=-aggi1(k,l)
3087                 aggj(k,l)=-aggj(k,l)
3088                 aggj1(k,l)=-aggj1(k,l)
3089               enddo
3090             enddo
3091           endif
3092           ENDIF ! WCORR
3093           IF (wel_loc.gt.0.0d0) THEN
3094 C Contribution to the local-electrostatic energy coming from the i-j pair
3095           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3096      &     +a33*muij(4)
3097 #ifdef DEBUG
3098           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3099      &     " a33",a33
3100           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3101      &     " wel_loc",wel_loc
3102 #endif
3103           if (shield_mode.eq.0) then
3104            fac_shield(i)=1.0
3105            fac_shield(j)=1.0
3106 C          else
3107 C           fac_shield(i)=0.4
3108 C           fac_shield(j)=0.6
3109           endif
3110           eel_loc_ij=eel_loc_ij
3111      &    *fac_shield(i)*fac_shield(j)*sss
3112           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3113      &            'eelloc',i,j,eel_loc_ij
3114 c           if (eel_loc_ij.ne.0)
3115 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3116 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3117
3118           eel_loc=eel_loc+eel_loc_ij
3119 C Now derivative over eel_loc
3120           if (calc_grad) then
3121           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3122      &  (shield_mode.gt.0)) then
3123 C          print *,i,j
3124
3125           do ilist=1,ishield_list(i)
3126            iresshield=shield_list(ilist,i)
3127            do k=1,3
3128            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3129      &                                          /fac_shield(i)
3130 C     &      *2.0
3131            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3132      &              rlocshield
3133      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3134             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3135      &      +rlocshield
3136            enddo
3137           enddo
3138           do ilist=1,ishield_list(j)
3139            iresshield=shield_list(ilist,j)
3140            do k=1,3
3141            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3142      &                                       /fac_shield(j)
3143 C     &     *2.0
3144            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3145      &              rlocshield
3146      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3147            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3148      &             +rlocshield
3149
3150            enddo
3151           enddo
3152
3153           do k=1,3
3154             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3155      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3156             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3157      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3158             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3159      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3160             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3161      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3162            enddo
3163            endif
3164
3165
3166 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3167 c     &                     ' eel_loc_ij',eel_loc_ij
3168 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3169 C Calculate patrial derivative for theta angle
3170 #ifdef NEWCORR
3171          geel_loc_ij=(a22*gmuij1(1)
3172      &     +a23*gmuij1(2)
3173      &     +a32*gmuij1(3)
3174      &     +a33*gmuij1(4))
3175      &    *fac_shield(i)*fac_shield(j)*sss
3176 c         write(iout,*) "derivative over thatai"
3177 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3178 c     &   a33*gmuij1(4)
3179          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3180      &      geel_loc_ij*wel_loc
3181 c         write(iout,*) "derivative over thatai-1"
3182 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3183 c     &   a33*gmuij2(4)
3184          geel_loc_ij=
3185      &     a22*gmuij2(1)
3186      &     +a23*gmuij2(2)
3187      &     +a32*gmuij2(3)
3188      &     +a33*gmuij2(4)
3189          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3190      &      geel_loc_ij*wel_loc
3191      &    *fac_shield(i)*fac_shield(j)*sss
3192
3193 c  Derivative over j residue
3194          geel_loc_ji=a22*gmuji1(1)
3195      &     +a23*gmuji1(2)
3196      &     +a32*gmuji1(3)
3197      &     +a33*gmuji1(4)
3198 c         write(iout,*) "derivative over thataj"
3199 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3200 c     &   a33*gmuji1(4)
3201
3202         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3203      &      geel_loc_ji*wel_loc
3204      &    *fac_shield(i)*fac_shield(j)
3205
3206          geel_loc_ji=
3207      &     +a22*gmuji2(1)
3208      &     +a23*gmuji2(2)
3209      &     +a32*gmuji2(3)
3210      &     +a33*gmuji2(4)
3211 c         write(iout,*) "derivative over thataj-1"
3212 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3213 c     &   a33*gmuji2(4)
3214          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3215      &      geel_loc_ji*wel_loc
3216      &    *fac_shield(i)*fac_shield(j)*sss
3217 #endif
3218 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3219
3220 C Partial derivatives in virtual-bond dihedral angles gamma
3221           if (i.gt.1)
3222      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3223      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3224      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3225      &    *fac_shield(i)*fac_shield(j)
3226
3227           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3228      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3229      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3230      &    *fac_shield(i)*fac_shield(j)
3231 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3232           aux=eel_loc_ij/sss*sssgrad*rmij
3233           ggg(1)=aux*xj
3234           ggg(2)=aux*yj
3235           ggg(3)=aux*zj
3236           do l=1,3
3237             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3238      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3239      &    *fac_shield(i)*fac_shield(j)*sss
3240             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3241             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3242 cgrad            ghalf=0.5d0*ggg(l)
3243 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3244 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3245           enddo
3246 cgrad          do k=i+1,j2
3247 cgrad            do l=1,3
3248 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3249 cgrad            enddo
3250 cgrad          enddo
3251 C Remaining derivatives of eello
3252           do l=1,3
3253             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3254      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3255      &    *fac_shield(i)*fac_shield(j)
3256
3257             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3258      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3259      &    *fac_shield(i)*fac_shield(j)
3260
3261             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3262      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3263      &    *fac_shield(i)*fac_shield(j)
3264
3265             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3266      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3267      &    *fac_shield(i)*fac_shield(j)
3268
3269           enddo
3270           endif ! calc_grad
3271           ENDIF
3272
3273
3274 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3275 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3276 #ifdef FOURBODY
3277           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3278      &       .and. num_conti.le.maxconts) then
3279 c            write (iout,*) i,j," entered corr"
3280 C
3281 C Calculate the contact function. The ith column of the array JCONT will
3282 C contain the numbers of atoms that make contacts with the atom I (of numbers
3283 C greater than I). The arrays FACONT and GACONT will contain the values of
3284 C the contact function and its derivative.
3285 c           r0ij=1.02D0*rpp(iteli,itelj)
3286 c           r0ij=1.11D0*rpp(iteli,itelj)
3287             r0ij=2.20D0*rpp(iteli,itelj)
3288 c           r0ij=1.55D0*rpp(iteli,itelj)
3289             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3290             if (fcont.gt.0.0D0) then
3291               num_conti=num_conti+1
3292               if (num_conti.gt.maxconts) then
3293                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3294      &                         ' will skip next contacts for this conf.'
3295               else
3296                 jcont_hb(num_conti,i)=j
3297 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3298 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3299                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3300      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3301 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3302 C  terms.
3303                 d_cont(num_conti,i)=rij
3304 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3305 C     --- Electrostatic-interaction matrix ---
3306                 a_chuj(1,1,num_conti,i)=a22
3307                 a_chuj(1,2,num_conti,i)=a23
3308                 a_chuj(2,1,num_conti,i)=a32
3309                 a_chuj(2,2,num_conti,i)=a33
3310 C     --- Gradient of rij
3311                 if (calc_grad) then
3312                 do kkk=1,3
3313                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3314                 enddo
3315                 kkll=0
3316                 do k=1,2
3317                   do l=1,2
3318                     kkll=kkll+1
3319                     do m=1,3
3320                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3321                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3322                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3323                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3324                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3325                     enddo
3326                   enddo
3327                 enddo
3328                 endif ! calc_grad
3329                 ENDIF
3330                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3331 C Calculate contact energies
3332                 cosa4=4.0D0*cosa
3333                 wij=cosa-3.0D0*cosb*cosg
3334                 cosbg1=cosb+cosg
3335                 cosbg2=cosb-cosg
3336 c               fac3=dsqrt(-ael6i)/r0ij**3
3337                 fac3=dsqrt(-ael6i)*r3ij
3338 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3339                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3340                 if (ees0tmp.gt.0) then
3341                   ees0pij=dsqrt(ees0tmp)
3342                 else
3343                   ees0pij=0
3344                 endif
3345 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3346                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3347                 if (ees0tmp.gt.0) then
3348                   ees0mij=dsqrt(ees0tmp)
3349                 else
3350                   ees0mij=0
3351                 endif
3352 c               ees0mij=0.0D0
3353                 if (shield_mode.eq.0) then
3354                 fac_shield(i)=1.0d0
3355                 fac_shield(j)=1.0d0
3356                 else
3357                 ees0plist(num_conti,i)=j
3358 C                fac_shield(i)=0.4d0
3359 C                fac_shield(j)=0.6d0
3360                 endif
3361                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3362      &          *fac_shield(i)*fac_shield(j)
3363                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3364      &          *fac_shield(i)*fac_shield(j)
3365 C Diagnostics. Comment out or remove after debugging!
3366 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3367 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3368 c               ees0m(num_conti,i)=0.0D0
3369 C End diagnostics.
3370 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3371 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3372 C Angular derivatives of the contact function
3373
3374                 ees0pij1=fac3/ees0pij
3375                 ees0mij1=fac3/ees0mij
3376                 fac3p=-3.0D0*fac3*rrmij
3377                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3378                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3379 c               ees0mij1=0.0D0
3380                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3381                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3382                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3383                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3384                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3385                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3386                 ecosap=ecosa1+ecosa2
3387                 ecosbp=ecosb1+ecosb2
3388                 ecosgp=ecosg1+ecosg2
3389                 ecosam=ecosa1-ecosa2
3390                 ecosbm=ecosb1-ecosb2
3391                 ecosgm=ecosg1-ecosg2
3392 C Diagnostics
3393 c               ecosap=ecosa1
3394 c               ecosbp=ecosb1
3395 c               ecosgp=ecosg1
3396 c               ecosam=0.0D0
3397 c               ecosbm=0.0D0
3398 c               ecosgm=0.0D0
3399 C End diagnostics
3400                 facont_hb(num_conti,i)=fcont
3401
3402                 if (calc_grad) then
3403                 fprimcont=fprimcont/rij
3404 cd              facont_hb(num_conti,i)=1.0D0
3405 C Following line is for diagnostics.
3406 cd              fprimcont=0.0D0
3407                 do k=1,3
3408                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3409                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3410                 enddo
3411                 do k=1,3
3412                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3413                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3414                 enddo
3415                 gggp(1)=gggp(1)+ees0pijp*xj
3416      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3417                 gggp(2)=gggp(2)+ees0pijp*yj
3418      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3419                 gggp(3)=gggp(3)+ees0pijp*zj
3420      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3421                 gggm(1)=gggm(1)+ees0mijp*xj
3422      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3423                 gggm(2)=gggm(2)+ees0mijp*yj
3424      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3425                 gggm(3)=gggm(3)+ees0mijp*zj
3426      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3427 C Derivatives due to the contact function
3428                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3429                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3430                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3431                 do k=1,3
3432 c
3433 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3434 c          following the change of gradient-summation algorithm.
3435 c
3436 cgrad                  ghalfp=0.5D0*gggp(k)
3437 cgrad                  ghalfm=0.5D0*gggm(k)
3438                   gacontp_hb1(k,num_conti,i)=!ghalfp
3439      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3440      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3441      &          *fac_shield(i)*fac_shield(j)*sss
3442
3443                   gacontp_hb2(k,num_conti,i)=!ghalfp
3444      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3445      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3446      &          *fac_shield(i)*fac_shield(j)*sss
3447
3448                   gacontp_hb3(k,num_conti,i)=gggp(k)
3449      &          *fac_shield(i)*fac_shield(j)*sss
3450
3451                   gacontm_hb1(k,num_conti,i)=!ghalfm
3452      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3453      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3454      &          *fac_shield(i)*fac_shield(j)*sss
3455
3456                   gacontm_hb2(k,num_conti,i)=!ghalfm
3457      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3458      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3459      &          *fac_shield(i)*fac_shield(j)*sss
3460
3461                   gacontm_hb3(k,num_conti,i)=gggm(k)
3462      &          *fac_shield(i)*fac_shield(j)*sss
3463
3464                 enddo
3465 C Diagnostics. Comment out or remove after debugging!
3466 cdiag           do k=1,3
3467 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3468 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3469 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3470 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3471 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3472 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3473 cdiag           enddo
3474
3475                  endif ! calc_grad
3476
3477               ENDIF ! wcorr
3478               endif  ! num_conti.le.maxconts
3479             endif  ! fcont.gt.0
3480           endif    ! j.gt.i+1
3481 #endif
3482           if (calc_grad) then
3483           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3484             do k=1,4
3485               do l=1,3
3486                 ghalf=0.5d0*agg(l,k)
3487                 aggi(l,k)=aggi(l,k)+ghalf
3488                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3489                 aggj(l,k)=aggj(l,k)+ghalf
3490               enddo
3491             enddo
3492             if (j.eq.nres-1 .and. i.lt.j-2) then
3493               do k=1,4
3494                 do l=1,3
3495                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3496                 enddo
3497               enddo
3498             endif
3499           endif
3500           endif ! calc_grad
3501 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3502       return
3503       end
3504 C-----------------------------------------------------------------------------
3505       subroutine eturn3(i,eello_turn3)
3506 C Third- and fourth-order contributions from turns
3507       implicit real*8 (a-h,o-z)
3508       include 'DIMENSIONS'
3509       include 'DIMENSIONS.ZSCOPT'
3510       include 'COMMON.IOUNITS'
3511       include 'COMMON.GEO'
3512       include 'COMMON.VAR'
3513       include 'COMMON.LOCAL'
3514       include 'COMMON.CHAIN'
3515       include 'COMMON.DERIV'
3516       include 'COMMON.INTERACT'
3517       include 'COMMON.CONTACTS'
3518       include 'COMMON.TORSION'
3519       include 'COMMON.VECTORS'
3520       include 'COMMON.FFIELD'
3521       include 'COMMON.CONTROL'
3522       include 'COMMON.SHIELD'
3523       include 'COMMON.CORRMAT'
3524       dimension ggg(3)
3525       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3526      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3527      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3528      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3529      &  auxgmat2(2,2),auxgmatt2(2,2)
3530       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3531      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3532       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3533      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3534      &    num_conti,j1,j2
3535       j=i+2
3536 c      write (iout,*) "eturn3",i,j,j1,j2
3537       a_temp(1,1)=a22
3538       a_temp(1,2)=a23
3539       a_temp(2,1)=a32
3540       a_temp(2,2)=a33
3541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3542 C
3543 C               Third-order contributions
3544 C
3545 C                 (i+2)o----(i+3)
3546 C                      | |
3547 C                      | |
3548 C                 (i+1)o----i
3549 C
3550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3551 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3552         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3553 c auxalary matices for theta gradient
3554 c auxalary matrix for i+1 and constant i+2
3555         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3556 c auxalary matrix for i+2 and constant i+1
3557         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3558         call transpose2(auxmat(1,1),auxmat1(1,1))
3559         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3560         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3561         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3562         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3563         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3564         if (shield_mode.eq.0) then
3565         fac_shield(i)=1.0
3566         fac_shield(j)=1.0
3567 C        else
3568 C        fac_shield(i)=0.4
3569 C        fac_shield(j)=0.6
3570         endif
3571         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3572      &  *fac_shield(i)*fac_shield(j)
3573         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3574      &  *fac_shield(i)*fac_shield(j)
3575         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3576      &    eello_t3
3577         if (calc_grad) then
3578 C#ifdef NEWCORR
3579 C Derivatives in theta
3580         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3581      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3582      &   *fac_shield(i)*fac_shield(j)
3583         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3584      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3585      &   *fac_shield(i)*fac_shield(j)
3586 C#endif
3587
3588 C Derivatives in shield mode
3589           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3590      &  (shield_mode.gt.0)) then
3591 C          print *,i,j
3592
3593           do ilist=1,ishield_list(i)
3594            iresshield=shield_list(ilist,i)
3595            do k=1,3
3596            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3597 C     &      *2.0
3598            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3599      &              rlocshield
3600      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3601             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3602      &      +rlocshield
3603            enddo
3604           enddo
3605           do ilist=1,ishield_list(j)
3606            iresshield=shield_list(ilist,j)
3607            do k=1,3
3608            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3609 C     &     *2.0
3610            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3611      &              rlocshield
3612      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3613            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3614      &             +rlocshield
3615
3616            enddo
3617           enddo
3618
3619           do k=1,3
3620             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3621      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3622             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3623      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3624             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3625      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3626             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3627      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3628            enddo
3629            endif
3630
3631 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3632 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3633 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3634 cd     &    ' eello_turn3_num',4*eello_turn3_num
3635 C Derivatives in gamma(i)
3636         call matmat2(EUgder(1,1,i+1),EUg(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)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3640      &   *fac_shield(i)*fac_shield(j)
3641 C Derivatives in gamma(i+1)
3642         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3643         call transpose2(auxmat2(1,1),auxmat3(1,1))
3644         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3645         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3646      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3647      &   *fac_shield(i)*fac_shield(j)
3648 C Cartesian derivatives
3649         do l=1,3
3650 c            ghalf1=0.5d0*agg(l,1)
3651 c            ghalf2=0.5d0*agg(l,2)
3652 c            ghalf3=0.5d0*agg(l,3)
3653 c            ghalf4=0.5d0*agg(l,4)
3654           a_temp(1,1)=aggi(l,1)!+ghalf1
3655           a_temp(1,2)=aggi(l,2)!+ghalf2
3656           a_temp(2,1)=aggi(l,3)!+ghalf3
3657           a_temp(2,2)=aggi(l,4)!+ghalf4
3658           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3659           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3660      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3661      &   *fac_shield(i)*fac_shield(j)
3662
3663           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3664           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3665           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3666           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3667           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3668           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3669      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3670      &   *fac_shield(i)*fac_shield(j)
3671           a_temp(1,1)=aggj(l,1)!+ghalf1
3672           a_temp(1,2)=aggj(l,2)!+ghalf2
3673           a_temp(2,1)=aggj(l,3)!+ghalf3
3674           a_temp(2,2)=aggj(l,4)!+ghalf4
3675           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3676           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3677      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3678      &   *fac_shield(i)*fac_shield(j)
3679           a_temp(1,1)=aggj1(l,1)
3680           a_temp(1,2)=aggj1(l,2)
3681           a_temp(2,1)=aggj1(l,3)
3682           a_temp(2,2)=aggj1(l,4)
3683           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3684           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3685      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3686      &   *fac_shield(i)*fac_shield(j)
3687         enddo
3688
3689         endif ! calc_grad
3690
3691       return
3692       end
3693 C-------------------------------------------------------------------------------
3694       subroutine eturn4(i,eello_turn4)
3695 C Third- and fourth-order contributions from turns
3696       implicit real*8 (a-h,o-z)
3697       include 'DIMENSIONS'
3698       include 'DIMENSIONS.ZSCOPT'
3699       include 'COMMON.IOUNITS'
3700       include 'COMMON.GEO'
3701       include 'COMMON.VAR'
3702       include 'COMMON.LOCAL'
3703       include 'COMMON.CHAIN'
3704       include 'COMMON.DERIV'
3705       include 'COMMON.INTERACT'
3706       include 'COMMON.CONTACTS'
3707       include 'COMMON.TORSION'
3708       include 'COMMON.VECTORS'
3709       include 'COMMON.FFIELD'
3710       include 'COMMON.CONTROL'
3711       include 'COMMON.SHIELD'
3712       include 'COMMON.CORRMAT'
3713       dimension ggg(3)
3714       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3715      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3716      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3717      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3718      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3719      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3720      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3721       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3722      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3723       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3724      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3725      &    num_conti,j1,j2
3726       j=i+3
3727 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3728 C
3729 C               Fourth-order contributions
3730 C
3731 C                 (i+3)o----(i+4)
3732 C                     /  |
3733 C               (i+2)o   |
3734 C                     \  |
3735 C                 (i+1)o----i
3736 C
3737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3738 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3739 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3740 c        write(iout,*)"WCHODZE W PROGRAM"
3741         a_temp(1,1)=a22
3742         a_temp(1,2)=a23
3743         a_temp(2,1)=a32
3744         a_temp(2,2)=a33
3745         iti1=itype2loc(itype(i+1))
3746         iti2=itype2loc(itype(i+2))
3747         iti3=itype2loc(itype(i+3))
3748 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3749         call transpose2(EUg(1,1,i+1),e1t(1,1))
3750         call transpose2(Eug(1,1,i+2),e2t(1,1))
3751         call transpose2(Eug(1,1,i+3),e3t(1,1))
3752 C Ematrix derivative in theta
3753         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3754         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3755         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3756         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757 c       eta1 in derivative theta
3758         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3759         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3760 c       auxgvec is derivative of Ub2 so i+3 theta
3761         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3762 c       auxalary matrix of E i+1
3763         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3764 c        s1=0.0
3765 c        gs1=0.0
3766         s1=scalar2(b1(1,i+2),auxvec(1))
3767 c derivative of theta i+2 with constant i+3
3768         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3769 c derivative of theta i+2 with constant i+2
3770         gs32=scalar2(b1(1,i+2),auxgvec(1))
3771 c derivative of E matix in theta of i+1
3772         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3773
3774         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3775 c       ea31 in derivative theta
3776         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3777         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3778 c auxilary matrix auxgvec of Ub2 with constant E matirx
3779         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3780 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3781         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3782
3783 c        s2=0.0
3784 c        gs2=0.0
3785         s2=scalar2(b1(1,i+1),auxvec(1))
3786 c derivative of theta i+1 with constant i+3
3787         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3788 c derivative of theta i+2 with constant i+1
3789         gs21=scalar2(b1(1,i+1),auxgvec(1))
3790 c derivative of theta i+3 with constant i+1
3791         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3792 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3793 c     &  gtb1(1,i+1)
3794         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3795 c two derivatives over diffetent matrices
3796 c gtae3e2 is derivative over i+3
3797         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3798 c ae3gte2 is derivative over i+2
3799         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3800         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3801 c three possible derivative over theta E matices
3802 c i+1
3803         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3804 c i+2
3805         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3806 c i+3
3807         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3808         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3809
3810         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3811         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3812         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3813         if (shield_mode.eq.0) then
3814         fac_shield(i)=1.0
3815         fac_shield(j)=1.0
3816 C        else
3817 C        fac_shield(i)=0.6
3818 C        fac_shield(j)=0.4
3819         endif
3820         eello_turn4=eello_turn4-(s1+s2+s3)
3821      &  *fac_shield(i)*fac_shield(j)
3822         eello_t4=-(s1+s2+s3)
3823      &  *fac_shield(i)*fac_shield(j)
3824 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3825         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3826      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3827 C Now derivative over shield:
3828           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3829      &  (shield_mode.gt.0)) then
3830 C          print *,i,j
3831
3832           do ilist=1,ishield_list(i)
3833            iresshield=shield_list(ilist,i)
3834            do k=1,3
3835            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3836 C     &      *2.0
3837            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3838      &              rlocshield
3839      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3840             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3841      &      +rlocshield
3842            enddo
3843           enddo
3844           do ilist=1,ishield_list(j)
3845            iresshield=shield_list(ilist,j)
3846            do k=1,3
3847            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3848 C     &     *2.0
3849            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3850      &              rlocshield
3851      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3852            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3853      &             +rlocshield
3854
3855            enddo
3856           enddo
3857
3858           do k=1,3
3859             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3860      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3861             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3862      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3863             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3864      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3865             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3866      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3867            enddo
3868            endif
3869 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3870 cd     &    ' eello_turn4_num',8*eello_turn4_num
3871 #ifdef NEWCORR
3872         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3873      &                  -(gs13+gsE13+gsEE1)*wturn4
3874      &  *fac_shield(i)*fac_shield(j)
3875         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3876      &                    -(gs23+gs21+gsEE2)*wturn4
3877      &  *fac_shield(i)*fac_shield(j)
3878
3879         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3880      &                    -(gs32+gsE31+gsEE3)*wturn4
3881      &  *fac_shield(i)*fac_shield(j)
3882
3883 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3884 c     &   gs2
3885 #endif
3886         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3887      &      'eturn4',i,j,-(s1+s2+s3)
3888 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3889 c     &    ' eello_turn4_num',8*eello_turn4_num
3890 C Derivatives in gamma(i)
3891         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3892         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3893         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3894         s1=scalar2(b1(1,i+2),auxvec(1))
3895         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3896         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3898      &  *fac_shield(i)*fac_shield(j)
3899 C Derivatives in gamma(i+1)
3900         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3901         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3902         s2=scalar2(b1(1,i+1),auxvec(1))
3903         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3904         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3905         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3906         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3907      &  *fac_shield(i)*fac_shield(j)
3908 C Derivatives in gamma(i+2)
3909         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3910         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3911         s1=scalar2(b1(1,i+2),auxvec(1))
3912         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3913         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3914         s2=scalar2(b1(1,i+1),auxvec(1))
3915         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3916         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3917         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3919      &  *fac_shield(i)*fac_shield(j)
3920         if (calc_grad) then
3921 C Cartesian derivatives
3922 C Derivatives of this turn contributions in DC(i+2)
3923         if (j.lt.nres-1) then
3924           do l=1,3
3925             a_temp(1,1)=agg(l,1)
3926             a_temp(1,2)=agg(l,2)
3927             a_temp(2,1)=agg(l,3)
3928             a_temp(2,2)=agg(l,4)
3929             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3930             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3931             s1=scalar2(b1(1,i+2),auxvec(1))
3932             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3933             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3934             s2=scalar2(b1(1,i+1),auxvec(1))
3935             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3936             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3937             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938             ggg(l)=-(s1+s2+s3)
3939             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3940      &  *fac_shield(i)*fac_shield(j)
3941           enddo
3942         endif
3943 C Remaining derivatives of this turn contribution
3944         do l=1,3
3945           a_temp(1,1)=aggi(l,1)
3946           a_temp(1,2)=aggi(l,2)
3947           a_temp(2,1)=aggi(l,3)
3948           a_temp(2,2)=aggi(l,4)
3949           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3950           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3951           s1=scalar2(b1(1,i+2),auxvec(1))
3952           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3953           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3954           s2=scalar2(b1(1,i+1),auxvec(1))
3955           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3956           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3957           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3958           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3959      &  *fac_shield(i)*fac_shield(j)
3960           a_temp(1,1)=aggi1(l,1)
3961           a_temp(1,2)=aggi1(l,2)
3962           a_temp(2,1)=aggi1(l,3)
3963           a_temp(2,2)=aggi1(l,4)
3964           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966           s1=scalar2(b1(1,i+2),auxvec(1))
3967           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969           s2=scalar2(b1(1,i+1),auxvec(1))
3970           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3974      &  *fac_shield(i)*fac_shield(j)
3975           a_temp(1,1)=aggj(l,1)
3976           a_temp(1,2)=aggj(l,2)
3977           a_temp(2,1)=aggj(l,3)
3978           a_temp(2,2)=aggj(l,4)
3979           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981           s1=scalar2(b1(1,i+2),auxvec(1))
3982           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984           s2=scalar2(b1(1,i+1),auxvec(1))
3985           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3989      &  *fac_shield(i)*fac_shield(j)
3990           a_temp(1,1)=aggj1(l,1)
3991           a_temp(1,2)=aggj1(l,2)
3992           a_temp(2,1)=aggj1(l,3)
3993           a_temp(2,2)=aggj1(l,4)
3994           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3995           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3996           s1=scalar2(b1(1,i+2),auxvec(1))
3997           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3998           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3999           s2=scalar2(b1(1,i+1),auxvec(1))
4000           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4001           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4002           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4003 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4004           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4005      &  *fac_shield(i)*fac_shield(j)
4006         enddo
4007
4008         endif ! calc_grad
4009
4010       return
4011       end
4012 C-----------------------------------------------------------------------------
4013       subroutine vecpr(u,v,w)
4014       implicit real*8(a-h,o-z)
4015       dimension u(3),v(3),w(3)
4016       w(1)=u(2)*v(3)-u(3)*v(2)
4017       w(2)=-u(1)*v(3)+u(3)*v(1)
4018       w(3)=u(1)*v(2)-u(2)*v(1)
4019       return
4020       end
4021 C-----------------------------------------------------------------------------
4022       subroutine unormderiv(u,ugrad,unorm,ungrad)
4023 C This subroutine computes the derivatives of a normalized vector u, given
4024 C the derivatives computed without normalization conditions, ugrad. Returns
4025 C ungrad.
4026       implicit none
4027       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4028       double precision vec(3)
4029       double precision scalar
4030       integer i,j
4031 c      write (2,*) 'ugrad',ugrad
4032 c      write (2,*) 'u',u
4033       do i=1,3
4034         vec(i)=scalar(ugrad(1,i),u(1))
4035       enddo
4036 c      write (2,*) 'vec',vec
4037       do i=1,3
4038         do j=1,3
4039           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4040         enddo
4041       enddo
4042 c      write (2,*) 'ungrad',ungrad
4043       return
4044       end
4045 C-----------------------------------------------------------------------------
4046       subroutine escp(evdw2,evdw2_14)
4047 C
4048 C This subroutine calculates the excluded-volume interaction energy between
4049 C peptide-group centers and side chains and its gradient in virtual-bond and
4050 C side-chain vectors.
4051 C
4052       implicit real*8 (a-h,o-z)
4053       include 'DIMENSIONS'
4054       include 'DIMENSIONS.ZSCOPT'
4055       include 'COMMON.CONTROL'
4056       include 'COMMON.GEO'
4057       include 'COMMON.VAR'
4058       include 'COMMON.LOCAL'
4059       include 'COMMON.CHAIN'
4060       include 'COMMON.DERIV'
4061       include 'COMMON.INTERACT'
4062       include 'COMMON.FFIELD'
4063       include 'COMMON.IOUNITS'
4064       dimension ggg(3)
4065       evdw2=0.0D0
4066       evdw2_14=0.0d0
4067 cd    print '(a)','Enter ESCP'
4068 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4069 c     &  ' scal14',scal14
4070       do i=iatscp_s,iatscp_e
4071         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4072         iteli=itel(i)
4073 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4074 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4075         if (iteli.eq.0) goto 1225
4076         xi=0.5D0*(c(1,i)+c(1,i+1))
4077         yi=0.5D0*(c(2,i)+c(2,i+1))
4078         zi=0.5D0*(c(3,i)+c(3,i+1))
4079 C Returning the ith atom to box
4080           xi=mod(xi,boxxsize)
4081           if (xi.lt.0) xi=xi+boxxsize
4082           yi=mod(yi,boxysize)
4083           if (yi.lt.0) yi=yi+boxysize
4084           zi=mod(zi,boxzsize)
4085           if (zi.lt.0) zi=zi+boxzsize
4086         do iint=1,nscp_gr(i)
4087
4088         do j=iscpstart(i,iint),iscpend(i,iint)
4089           itypj=iabs(itype(j))
4090           if (itypj.eq.ntyp1) cycle
4091 C Uncomment following three lines for SC-p interactions
4092 c         xj=c(1,nres+j)-xi
4093 c         yj=c(2,nres+j)-yi
4094 c         zj=c(3,nres+j)-zi
4095 C Uncomment following three lines for Ca-p interactions
4096           xj=c(1,j)
4097           yj=c(2,j)
4098           zj=c(3,j)
4099 C returning the jth atom to box
4100           xj=mod(xj,boxxsize)
4101           if (xj.lt.0) xj=xj+boxxsize
4102           yj=mod(yj,boxysize)
4103           if (yj.lt.0) yj=yj+boxysize
4104           zj=mod(zj,boxzsize)
4105           if (zj.lt.0) zj=zj+boxzsize
4106       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4107       xj_safe=xj
4108       yj_safe=yj
4109       zj_safe=zj
4110       subchap=0
4111 C Finding the closest jth atom
4112       do xshift=-1,1
4113       do yshift=-1,1
4114       do zshift=-1,1
4115           xj=xj_safe+xshift*boxxsize
4116           yj=yj_safe+yshift*boxysize
4117           zj=zj_safe+zshift*boxzsize
4118           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4119           if(dist_temp.lt.dist_init) then
4120             dist_init=dist_temp
4121             xj_temp=xj
4122             yj_temp=yj
4123             zj_temp=zj
4124             subchap=1
4125           endif
4126        enddo
4127        enddo
4128        enddo
4129        if (subchap.eq.1) then
4130           xj=xj_temp-xi
4131           yj=yj_temp-yi
4132           zj=zj_temp-zi
4133        else
4134           xj=xj_safe-xi
4135           yj=yj_safe-yi
4136           zj=zj_safe-zi
4137        endif
4138           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4139 C sss is scaling function for smoothing the cutoff gradient otherwise
4140 C the gradient would not be continuouse
4141           sss=sscale(1.0d0/(dsqrt(rrij)))
4142           if (sss.le.0.0d0) cycle
4143           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4144           fac=rrij**expon2
4145           e1=fac*fac*aad(itypj,iteli)
4146           e2=fac*bad(itypj,iteli)
4147           if (iabs(j-i) .le. 2) then
4148             e1=scal14*e1
4149             e2=scal14*e2
4150             evdw2_14=evdw2_14+(e1+e2)*sss
4151           endif
4152           evdwij=e1+e2
4153 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4154 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4155 c     &       bad(itypj,iteli)
4156           evdw2=evdw2+evdwij*sss
4157           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4158      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4159      &       bad(itypj,iteli)
4160
4161           if (calc_grad) then
4162 C
4163 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4164 C
4165           fac=-(evdwij+e1)*rrij*sss
4166           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4167           ggg(1)=xj*fac
4168           ggg(2)=yj*fac
4169           ggg(3)=zj*fac
4170           if (j.lt.i) then
4171 cd          write (iout,*) 'j<i'
4172 C Uncomment following three lines for SC-p interactions
4173 c           do k=1,3
4174 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4175 c           enddo
4176           else
4177 cd          write (iout,*) 'j>i'
4178             do k=1,3
4179               ggg(k)=-ggg(k)
4180 C Uncomment following line for SC-p interactions
4181 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4182             enddo
4183           endif
4184           do k=1,3
4185             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4186           enddo
4187           kstart=min0(i+1,j)
4188           kend=max0(i-1,j-1)
4189 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4190 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4191           do k=kstart,kend
4192             do l=1,3
4193               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4194             enddo
4195           enddo
4196           endif ! calc_grad
4197         enddo
4198         enddo ! iint
4199  1225   continue
4200       enddo ! i
4201       do i=1,nct
4202         do j=1,3
4203           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4204           gradx_scp(j,i)=expon*gradx_scp(j,i)
4205         enddo
4206       enddo
4207 C******************************************************************************
4208 C
4209 C                              N O T E !!!
4210 C
4211 C To save time the factor EXPON has been extracted from ALL components
4212 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4213 C use!
4214 C
4215 C******************************************************************************
4216       return
4217       end
4218 C--------------------------------------------------------------------------
4219       subroutine edis(ehpb)
4220 C
4221 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4222 C
4223       implicit real*8 (a-h,o-z)
4224       include 'DIMENSIONS'
4225       include 'DIMENSIONS.ZSCOPT'
4226       include 'COMMON.SBRIDGE'
4227       include 'COMMON.CHAIN'
4228       include 'COMMON.DERIV'
4229       include 'COMMON.VAR'
4230       include 'COMMON.INTERACT'
4231       include 'COMMON.CONTROL'
4232       include 'COMMON.IOUNITS'
4233       dimension ggg(3),ggg_peak(3,1000)
4234       ehpb=0.0D0
4235       do i=1,3
4236        ggg(i)=0.0d0
4237       enddo
4238 c 8/21/18 AL: added explicit restraints on reference coords
4239 c      write (iout,*) "restr_on_coord",restr_on_coord
4240       if (restr_on_coord) then
4241
4242       do i=nnt,nct
4243         ecoor=0.0d0
4244         if (itype(i).eq.ntyp1) cycle
4245         do j=1,3
4246           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4247           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4248         enddo
4249         if (itype(i).ne.10) then
4250           do j=1,3
4251             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4252             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4253           enddo
4254         endif
4255         if (energy_dec) write (iout,*)
4256      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4257         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4258       enddo
4259
4260       endif
4261
4262 C      write (iout,*) ,"link_end",link_end,constr_dist
4263 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4264 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4265 c     &  " constr_dist",constr_dist
4266       if (link_end.eq.0.and.link_end_peak.eq.0) return
4267       do i=link_start_peak,link_end_peak
4268         ehpb_peak=0.0d0
4269 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4270 c     &   ipeak(1,i),ipeak(2,i)
4271         do ip=ipeak(1,i),ipeak(2,i)
4272           ii=ihpb_peak(ip)
4273           jj=jhpb_peak(ip)
4274           dd=dist(ii,jj)
4275           iip=ip-ipeak(1,i)+1
4276 C iii and jjj point to the residues for which the distance is assigned.
4277 c          if (ii.gt.nres) then
4278 c            iii=ii-nres
4279 c            jjj=jj-nres
4280 c          else
4281 c            iii=ii
4282 c            jjj=jj
4283 c          endif
4284           if (ii.gt.nres) then
4285             iii=ii-nres
4286           else
4287             iii=ii
4288           endif
4289           if (jj.gt.nres) then
4290             jjj=jj-nres
4291           else
4292             jjj=jj
4293           endif
4294           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4295           aux=dexp(-scal_peak*aux)
4296           ehpb_peak=ehpb_peak+aux
4297           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4298      &      forcon_peak(ip))*aux/dd
4299           do j=1,3
4300             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4303      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4304      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4305         enddo
4306 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4307         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4308         do ip=ipeak(1,i),ipeak(2,i)
4309           iip=ip-ipeak(1,i)+1
4310           do j=1,3
4311             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4312           enddo
4313           ii=ihpb_peak(ip)
4314           jj=jhpb_peak(ip)
4315 C iii and jjj point to the residues for which the distance is assigned.
4316           if (ii.gt.nres) then
4317             iii=ii-nres
4318             jjj=jj-nres
4319           else
4320             iii=ii
4321             jjj=jj
4322           endif
4323           if (iii.lt.ii) then
4324             do j=1,3
4325               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4326             enddo
4327           endif
4328           if (jjj.lt.jj) then
4329             do j=1,3
4330               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4331             enddo
4332           endif
4333           do k=1,3
4334             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4335             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4336           enddo
4337         enddo
4338       enddo
4339       do i=link_start,link_end
4340 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4341 C CA-CA distance used in regularization of structure.
4342         ii=ihpb(i)
4343         jj=jhpb(i)
4344 C iii and jjj point to the residues for which the distance is assigned.
4345         if (ii.gt.nres) then
4346           iii=ii-nres
4347         else
4348           iii=ii
4349         endif
4350         if (jj.gt.nres) then
4351           jjj=jj-nres
4352         else
4353           jjj=jj
4354         endif
4355 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4356 c     &    dhpb(i),dhpb1(i),forcon(i)
4357 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4358 C    distance and angle dependent SS bond potential.
4359 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4360 C     & iabs(itype(jjj)).eq.1) then
4361 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4362 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4363         if (.not.dyn_ss .and. i.le.nss) then
4364 C 15/02/13 CC dynamic SSbond - additional check
4365           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4366      &        iabs(itype(jjj)).eq.1) then
4367            call ssbond_ene(iii,jjj,eij)
4368            ehpb=ehpb+2*eij
4369          endif
4370 cd          write (iout,*) "eij",eij
4371 cd   &   ' waga=',waga,' fac=',fac
4372 !        else if (ii.gt.nres .and. jj.gt.nres) then
4373         else
4374 C Calculate the distance between the two points and its difference from the
4375 C target distance.
4376           dd=dist(ii,jj)
4377           if (irestr_type(i).eq.11) then
4378             ehpb=ehpb+fordepth(i)!**4.0d0
4379      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4380             fac=fordepth(i)!**4.0d0
4381      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4382             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4383      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4384      &        ehpb,irestr_type(i)
4385           else if (irestr_type(i).eq.10) then
4386 c AL 6//19/2018 cross-link restraints
4387             xdis = 0.5d0*(dd/forcon(i))**2
4388             expdis = dexp(-xdis)
4389 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4390             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4391 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4392 c     &          " wboltzd",wboltzd
4393             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4394 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4395             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4396      &           *expdis/(aux*forcon(i)**2)
4397             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4398      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4399      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4400           else if (irestr_type(i).eq.2) then
4401 c Quartic restraints
4402             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4403             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4404      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4405      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4406             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4407           else
4408 c Quadratic restraints
4409             rdis=dd-dhpb(i)
4410 C Get the force constant corresponding to this distance.
4411             waga=forcon(i)
4412 C Calculate the contribution to energy.
4413             ehpb=ehpb+0.5d0*waga*rdis*rdis
4414             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4415      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4416      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4417 C
4418 C Evaluate gradient.
4419 C
4420             fac=waga*rdis/dd
4421           endif
4422 c Calculate Cartesian gradient
4423           do j=1,3
4424             ggg(j)=fac*(c(j,jj)-c(j,ii))
4425           enddo
4426 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4427 C If this is a SC-SC distance, we need to calculate the contributions to the
4428 C Cartesian gradient in the SC vectors (ghpbx).
4429           if (iii.lt.ii) then
4430             do j=1,3
4431               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4432             enddo
4433           endif
4434           if (jjj.lt.jj) then
4435             do j=1,3
4436               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4437             enddo
4438           endif
4439           do k=1,3
4440             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4441             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4442           enddo
4443         endif
4444       enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ssbond_ene(i,j,eij)
4449 C
4450 C Calculate the distance and angle dependent SS-bond potential energy
4451 C using a free-energy function derived based on RHF/6-31G** ab initio
4452 C calculations of diethyl disulfide.
4453 C
4454 C A. Liwo and U. Kozlowska, 11/24/03
4455 C
4456       implicit real*8 (a-h,o-z)
4457       include 'DIMENSIONS'
4458       include 'DIMENSIONS.ZSCOPT'
4459       include 'COMMON.SBRIDGE'
4460       include 'COMMON.CHAIN'
4461       include 'COMMON.DERIV'
4462       include 'COMMON.LOCAL'
4463       include 'COMMON.INTERACT'
4464       include 'COMMON.VAR'
4465       include 'COMMON.IOUNITS'
4466       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4467       itypi=iabs(itype(i))
4468       xi=c(1,nres+i)
4469       yi=c(2,nres+i)
4470       zi=c(3,nres+i)
4471       dxi=dc_norm(1,nres+i)
4472       dyi=dc_norm(2,nres+i)
4473       dzi=dc_norm(3,nres+i)
4474       dsci_inv=dsc_inv(itypi)
4475       itypj=iabs(itype(j))
4476       dscj_inv=dsc_inv(itypj)
4477       xj=c(1,nres+j)-xi
4478       yj=c(2,nres+j)-yi
4479       zj=c(3,nres+j)-zi
4480       dxj=dc_norm(1,nres+j)
4481       dyj=dc_norm(2,nres+j)
4482       dzj=dc_norm(3,nres+j)
4483       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4484       rij=dsqrt(rrij)
4485       erij(1)=xj*rij
4486       erij(2)=yj*rij
4487       erij(3)=zj*rij
4488       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4489       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4490       om12=dxi*dxj+dyi*dyj+dzi*dzj
4491       do k=1,3
4492         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4493         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4494       enddo
4495       rij=1.0d0/rij
4496       deltad=rij-d0cm
4497       deltat1=1.0d0-om1
4498       deltat2=1.0d0+om2
4499       deltat12=om2-om1+2.0d0
4500       cosphi=om12-om1*om2
4501       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4502      &  +akct*deltad*deltat12
4503      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4504 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4505 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4506 c     &  " deltat12",deltat12," eij",eij
4507       ed=2*akcm*deltad+akct*deltat12
4508       pom1=akct*deltad
4509       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4510       eom1=-2*akth*deltat1-pom1-om2*pom2
4511       eom2= 2*akth*deltat2+pom1-om1*pom2
4512       eom12=pom2
4513       do k=1,3
4514         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4515       enddo
4516       do k=1,3
4517         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4518      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4519         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4520      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4521       enddo
4522 C
4523 C Calculate the components of the gradient in DC and X
4524 C
4525       do k=i,j-1
4526         do l=1,3
4527           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4528         enddo
4529       enddo
4530       return
4531       end
4532 C--------------------------------------------------------------------------
4533 c MODELLER restraint function
4534       subroutine e_modeller(ehomology_constr)
4535       implicit real*8 (a-h,o-z)
4536       include 'DIMENSIONS'
4537       include 'DIMENSIONS.ZSCOPT'
4538       include 'DIMENSIONS.FREE'
4539       integer nnn, i, j, k, ki, irec, l
4540       integer katy, odleglosci, test7
4541       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4542       real*8 distance(max_template),distancek(max_template),
4543      &    min_odl,godl(max_template),dih_diff(max_template)
4544
4545 c
4546 c     FP - 30/10/2014 Temporary specifications for homology restraints
4547 c
4548       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4549      &                 sgtheta
4550       double precision, dimension (maxres) :: guscdiff,usc_diff
4551       double precision, dimension (max_template) ::
4552      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4553      &           theta_diff
4554
4555       include 'COMMON.SBRIDGE'
4556       include 'COMMON.CHAIN'
4557       include 'COMMON.GEO'
4558       include 'COMMON.DERIV'
4559       include 'COMMON.LOCAL'
4560       include 'COMMON.INTERACT'
4561       include 'COMMON.VAR'
4562       include 'COMMON.IOUNITS'
4563       include 'COMMON.CONTROL'
4564       include 'COMMON.HOMRESTR'
4565       include 'COMMON.HOMOLOGY'
4566       include 'COMMON.SETUP'
4567       include 'COMMON.NAMES'
4568
4569       do i=1,max_template
4570         distancek(i)=9999999.9
4571       enddo
4572
4573       odleg=0.0d0
4574
4575 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4576 c function)
4577 C AL 5/2/14 - Introduce list of restraints
4578 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4579 #ifdef DEBUG
4580       write(iout,*) "------- dist restrs start -------"
4581 #endif
4582       do ii = link_start_homo,link_end_homo
4583          i = ires_homo(ii)
4584          j = jres_homo(ii)
4585          dij=dist(i,j)
4586 c        write (iout,*) "dij(",i,j,") =",dij
4587          nexl=0
4588          do k=1,constr_homology
4589            if(.not.l_homo(k,ii)) then
4590               nexl=nexl+1
4591               cycle
4592            endif
4593            distance(k)=odl(k,ii)-dij
4594 c          write (iout,*) "distance(",k,") =",distance(k)
4595 c
4596 c          For Gaussian-type Urestr
4597 c
4598            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4599 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4600 c          write (iout,*) "distancek(",k,") =",distancek(k)
4601 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4602 c
4603 c          For Lorentzian-type Urestr
4604 c
4605            if (waga_dist.lt.0.0d0) then
4606               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4607               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4608      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4609            endif
4610          enddo
4611
4612 c         min_odl=minval(distancek)
4613          if (nexl.gt.0) then
4614            min_odl=0.0d0
4615          else
4616            do kk=1,constr_homology
4617             if(l_homo(kk,ii)) then
4618               min_odl=distancek(kk)
4619               exit
4620             endif
4621            enddo
4622            do kk=1,constr_homology
4623             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4624      &              min_odl=distancek(kk)
4625            enddo
4626          endif
4627 c        write (iout,* )"min_odl",min_odl
4628 #ifdef DEBUG
4629          write (iout,*) "ij dij",i,j,dij
4630          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4631          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4632          write (iout,* )"min_odl",min_odl
4633 #endif
4634 #ifdef OLDRESTR
4635          odleg2=0.0d0
4636 #else
4637          if (waga_dist.ge.0.0d0) then
4638            odleg2=nexl
4639          else
4640            odleg2=0.0d0
4641          endif
4642 #endif
4643          do k=1,constr_homology
4644 c Nie wiem po co to liczycie jeszcze raz!
4645 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4646 c     &              (2*(sigma_odl(i,j,k))**2))
4647            if(.not.l_homo(k,ii)) cycle
4648            if (waga_dist.ge.0.0d0) then
4649 c
4650 c          For Gaussian-type Urestr
4651 c
4652             godl(k)=dexp(-distancek(k)+min_odl)
4653             odleg2=odleg2+godl(k)
4654 c
4655 c          For Lorentzian-type Urestr
4656 c
4657            else
4658             odleg2=odleg2+distancek(k)
4659            endif
4660
4661 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4662 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4663 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4664 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4665
4666          enddo
4667 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4668 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4669 #ifdef DEBUG
4670          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4671          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4672 #endif
4673            if (waga_dist.ge.0.0d0) then
4674 c
4675 c          For Gaussian-type Urestr
4676 c
4677               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4678 c
4679 c          For Lorentzian-type Urestr
4680 c
4681            else
4682               odleg=odleg+odleg2/constr_homology
4683            endif
4684 c
4685 #ifdef GRAD
4686 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4687 c Gradient
4688 c
4689 c          For Gaussian-type Urestr
4690 c
4691          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4692          sum_sgodl=0.0d0
4693          do k=1,constr_homology
4694 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4695 c     &           *waga_dist)+min_odl
4696 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4697 c
4698          if(.not.l_homo(k,ii)) cycle
4699          if (waga_dist.ge.0.0d0) then
4700 c          For Gaussian-type Urestr
4701 c
4702            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4703 c
4704 c          For Lorentzian-type Urestr
4705 c
4706          else
4707            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4708      &           sigma_odlir(k,ii)**2)**2)
4709          endif
4710            sum_sgodl=sum_sgodl+sgodl
4711
4712 c            sgodl2=sgodl2+sgodl
4713 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4714 c      write(iout,*) "constr_homology=",constr_homology
4715 c      write(iout,*) i, j, k, "TEST K"
4716          enddo
4717          if (waga_dist.ge.0.0d0) then
4718 c
4719 c          For Gaussian-type Urestr
4720 c
4721             grad_odl3=waga_homology(iset)*waga_dist
4722      &                *sum_sgodl/(sum_godl*dij)
4723 c
4724 c          For Lorentzian-type Urestr
4725 c
4726          else
4727 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4728 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4729             grad_odl3=-waga_homology(iset)*waga_dist*
4730      &                sum_sgodl/(constr_homology*dij)
4731          endif
4732 c
4733 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4734
4735
4736 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4737 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4738 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4739
4740 ccc      write(iout,*) godl, sgodl, grad_odl3
4741
4742 c          grad_odl=grad_odl+grad_odl3
4743
4744          do jik=1,3
4745             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4746 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4747 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4748 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4749             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4750             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4751 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4752 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4753 c         if (i.eq.25.and.j.eq.27) then
4754 c         write(iout,*) "jik",jik,"i",i,"j",j
4755 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4756 c         write(iout,*) "grad_odl3",grad_odl3
4757 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4758 c         write(iout,*) "ggodl",ggodl
4759 c         write(iout,*) "ghpbc(",jik,i,")",
4760 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4761 c     &                 ghpbc(jik,j)
4762 c         endif
4763          enddo
4764 #endif
4765 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4766 ccc     & dLOG(odleg2),"-odleg=", -odleg
4767
4768       enddo ! ii-loop for dist
4769 #ifdef DEBUG
4770       write(iout,*) "------- dist restrs end -------"
4771 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4772 c    &     waga_d.eq.1.0d0) call sum_gradient
4773 #endif
4774 c Pseudo-energy and gradient from dihedral-angle restraints from
4775 c homology templates
4776 c      write (iout,*) "End of distance loop"
4777 c      call flush(iout)
4778       kat=0.0d0
4779 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4780 #ifdef DEBUG
4781       write(iout,*) "------- dih restrs start -------"
4782       do i=idihconstr_start_homo,idihconstr_end_homo
4783         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4784       enddo
4785 #endif
4786       do i=idihconstr_start_homo,idihconstr_end_homo
4787         kat2=0.0d0
4788 c        betai=beta(i,i+1,i+2,i+3)
4789         betai = phi(i)
4790 c       write (iout,*) "betai =",betai
4791         do k=1,constr_homology
4792           dih_diff(k)=pinorm(dih(k,i)-betai)
4793 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4794 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4795 c     &                                   -(6.28318-dih_diff(i,k))
4796 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4797 c     &                                   6.28318+dih_diff(i,k)
4798 #ifdef OLD_DIHED
4799           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4800 #else
4801           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4802 #endif
4803 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4804           gdih(k)=dexp(kat3)
4805           kat2=kat2+gdih(k)
4806 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4807 c          write(*,*)""
4808         enddo
4809 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4810 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4811 #ifdef DEBUG
4812         write (iout,*) "i",i," betai",betai," kat2",kat2
4813         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4814 #endif
4815         if (kat2.le.1.0d-14) cycle
4816         kat=kat-dLOG(kat2/constr_homology)
4817 c       write (iout,*) "kat",kat ! sum of -ln-s
4818
4819 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4820 ccc     & dLOG(kat2), "-kat=", -kat
4821
4822 #ifdef GRAD
4823 c ----------------------------------------------------------------------
4824 c Gradient
4825 c ----------------------------------------------------------------------
4826
4827         sum_gdih=kat2
4828         sum_sgdih=0.0d0
4829         do k=1,constr_homology
4830 #ifdef OLD_DIHED
4831           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4832 #else
4833           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4834 #endif
4835 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4836           sum_sgdih=sum_sgdih+sgdih
4837         enddo
4838 c       grad_dih3=sum_sgdih/sum_gdih
4839         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4840
4841 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4842 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4843 ccc     & gloc(nphi+i-3,icg)
4844         gloc(i,icg)=gloc(i,icg)+grad_dih3
4845 c        if (i.eq.25) then
4846 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4847 c        endif
4848 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4849 ccc     & gloc(nphi+i-3,icg)
4850 #endif
4851       enddo ! i-loop for dih
4852 #ifdef DEBUG
4853       write(iout,*) "------- dih restrs end -------"
4854 #endif
4855
4856 c Pseudo-energy and gradient for theta angle restraints from
4857 c homology templates
4858 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4859 c adapted
4860
4861 c
4862 c     For constr_homology reference structures (FP)
4863 c
4864 c     Uconst_back_tot=0.0d0
4865       Eval=0.0d0
4866       Erot=0.0d0
4867 c     Econstr_back legacy
4868 #ifdef GRAD
4869       do i=1,nres
4870 c     do i=ithet_start,ithet_end
4871        dutheta(i)=0.0d0
4872 c     enddo
4873 c     do i=loc_start,loc_end
4874         do j=1,3
4875           duscdiff(j,i)=0.0d0
4876           duscdiffx(j,i)=0.0d0
4877         enddo
4878       enddo
4879 #endif
4880 c
4881 c     do iref=1,nref
4882 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4883 c     write (iout,*) "waga_theta",waga_theta
4884       if (waga_theta.gt.0.0d0) then
4885 #ifdef DEBUG
4886       write (iout,*) "usampl",usampl
4887       write(iout,*) "------- theta restrs start -------"
4888 c     do i=ithet_start,ithet_end
4889 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4890 c     enddo
4891 #endif
4892 c     write (iout,*) "maxres",maxres,"nres",nres
4893
4894       do i=ithet_start,ithet_end
4895 c
4896 c     do i=1,nfrag_back
4897 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4898 c
4899 c Deviation of theta angles wrt constr_homology ref structures
4900 c
4901         utheta_i=0.0d0 ! argument of Gaussian for single k
4902         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4903 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4904 c       over residues in a fragment
4905 c       write (iout,*) "theta(",i,")=",theta(i)
4906         do k=1,constr_homology
4907 c
4908 c         dtheta_i=theta(j)-thetaref(j,iref)
4909 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4910           theta_diff(k)=thetatpl(k,i)-theta(i)
4911 c
4912           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4913 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4914           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4915           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4916 c         Gradient for single Gaussian restraint in subr Econstr_back
4917 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4918 c
4919         enddo
4920 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4921 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4922
4923 c
4924 #ifdef GRAD
4925 c         Gradient for multiple Gaussian restraint
4926         sum_gtheta=gutheta_i
4927         sum_sgtheta=0.0d0
4928         do k=1,constr_homology
4929 c        New generalized expr for multiple Gaussian from Econstr_back
4930          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4931 c
4932 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4933           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4934         enddo
4935 c
4936 c       Final value of gradient using same var as in Econstr_back
4937         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4938      &               *waga_homology(iset)
4939 c       dutheta(i)=sum_sgtheta/sum_gtheta
4940 c
4941 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4942 #endif
4943         Eval=Eval-dLOG(gutheta_i/constr_homology)
4944 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4945 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4946 c       Uconst_back=Uconst_back+utheta(i)
4947       enddo ! (i-loop for theta)
4948 #ifdef DEBUG
4949       write(iout,*) "------- theta restrs end -------"
4950 #endif
4951       endif
4952 c
4953 c Deviation of local SC geometry
4954 c
4955 c Separation of two i-loops (instructed by AL - 11/3/2014)
4956 c
4957 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4958 c     write (iout,*) "waga_d",waga_d
4959
4960 #ifdef DEBUG
4961       write(iout,*) "------- SC restrs start -------"
4962       write (iout,*) "Initial duscdiff,duscdiffx"
4963       do i=loc_start,loc_end
4964         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4965      &                 (duscdiffx(jik,i),jik=1,3)
4966       enddo
4967 #endif
4968       do i=loc_start,loc_end
4969         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4970         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4971 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4972 c       write(iout,*) "xxtab, yytab, zztab"
4973 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4974         do k=1,constr_homology
4975 c
4976           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4977 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4978           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4979           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4980 c         write(iout,*) "dxx, dyy, dzz"
4981 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4982 c
4983           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4984 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4985 c         uscdiffk(k)=usc_diff(i)
4986           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4987           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4988 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4989 c     &      xxref(j),yyref(j),zzref(j)
4990         enddo
4991 c
4992 c       Gradient
4993 c
4994 c       Generalized expression for multiple Gaussian acc to that for a single
4995 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4996 c
4997 c       Original implementation
4998 c       sum_guscdiff=guscdiff(i)
4999 c
5000 c       sum_sguscdiff=0.0d0
5001 c       do k=1,constr_homology
5002 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
5003 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
5004 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
5005 c       enddo
5006 c
5007 c       Implementation of new expressions for gradient (Jan. 2015)
5008 c
5009 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
5010 #ifdef GRAD
5011         do k=1,constr_homology
5012 c
5013 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
5014 c       before. Now the drivatives should be correct
5015 c
5016           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
5017 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
5018           dyy=-yytpl(k,i)+yytab(i) ! ibid y
5019           dzz=-zztpl(k,i)+zztab(i) ! ibid z
5020 c
5021 c         New implementation
5022 c
5023           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
5024      &                 sigma_d(k,i) ! for the grad wrt r'
5025 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
5026 c
5027 c
5028 c        New implementation
5029          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
5030          do jik=1,3
5031             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
5032      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
5033      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
5034             duscdiff(jik,i)=duscdiff(jik,i)+
5035      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
5036      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
5037             duscdiffx(jik,i)=duscdiffx(jik,i)+
5038      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
5039      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
5040 c
5041 #ifdef DEBUG
5042              write(iout,*) "jik",jik,"i",i
5043              write(iout,*) "dxx, dyy, dzz"
5044              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
5045              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
5046 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
5047 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
5048 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
5049 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
5050 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
5051 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
5052 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
5053 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
5054 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
5055 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
5056 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
5057 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
5058 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
5059 c            endif
5060 #endif
5061          enddo
5062         enddo
5063 #endif
5064 c
5065 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
5066 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
5067 c
5068 c        write (iout,*) i," uscdiff",uscdiff(i)
5069 c
5070 c Put together deviations from local geometry
5071
5072 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
5073 c      &            wfrag_back(3,i,iset)*uscdiff(i)
5074         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
5075 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
5076 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
5077 c       Uconst_back=Uconst_back+usc_diff(i)
5078 c
5079 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
5080 c
5081 c     New implment: multiplied by sum_sguscdiff
5082 c
5083
5084       enddo ! (i-loop for dscdiff)
5085
5086 c      endif
5087
5088 #ifdef DEBUG
5089       write(iout,*) "------- SC restrs end -------"
5090         write (iout,*) "------ After SC loop in e_modeller ------"
5091         do i=loc_start,loc_end
5092          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
5093          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
5094         enddo
5095       if (waga_theta.eq.1.0d0) then
5096       write (iout,*) "in e_modeller after SC restr end: dutheta"
5097       do i=ithet_start,ithet_end
5098         write (iout,*) i,dutheta(i)
5099       enddo
5100       endif
5101       if (waga_d.eq.1.0d0) then
5102       write (iout,*) "e_modeller after SC loop: duscdiff/x"
5103       do i=1,nres
5104         write (iout,*) i,(duscdiff(j,i),j=1,3)
5105         write (iout,*) i,(duscdiffx(j,i),j=1,3)
5106       enddo
5107       endif
5108 #endif
5109
5110 c Total energy from homology restraints
5111 #ifdef DEBUG
5112       write (iout,*) "odleg",odleg," kat",kat
5113       write (iout,*) "odleg",odleg," kat",kat
5114       write (iout,*) "Eval",Eval," Erot",Erot
5115       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5116       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5117       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5118 #endif
5119 c
5120 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5121 c
5122 c     ehomology_constr=odleg+kat
5123 c
5124 c     For Lorentzian-type Urestr
5125 c
5126
5127       if (waga_dist.ge.0.0d0) then
5128 c
5129 c          For Gaussian-type Urestr
5130 c
5131 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5132 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5133         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5134      &              waga_theta*Eval+waga_d*Erot
5135 c     write (iout,*) "ehomology_constr=",ehomology_constr
5136       else
5137 c
5138 c          For Lorentzian-type Urestr
5139 c
5140 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5141 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5142         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5143      &              waga_theta*Eval+waga_d*Erot
5144 c     write (iout,*) "ehomology_constr=",ehomology_constr
5145       endif
5146 #ifdef DEBUG
5147       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5148      & "Eval",waga_theta,eval,
5149      &   "Erot",waga_d,Erot
5150       write (iout,*) "ehomology_constr",ehomology_constr
5151 #endif
5152       return
5153
5154   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5155   747 format(a12,i4,i4,i4,f8.3,f8.3)
5156   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5157   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5158   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5159      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5160       end
5161 c-----------------------------------------------------------------------
5162       subroutine ebond(estr)
5163 c
5164 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5165 c
5166       implicit real*8 (a-h,o-z)
5167       include 'DIMENSIONS'
5168       include 'DIMENSIONS.ZSCOPT'
5169       include 'COMMON.LOCAL'
5170       include 'COMMON.GEO'
5171       include 'COMMON.INTERACT'
5172       include 'COMMON.DERIV'
5173       include 'COMMON.VAR'
5174       include 'COMMON.CHAIN'
5175       include 'COMMON.IOUNITS'
5176       include 'COMMON.NAMES'
5177       include 'COMMON.FFIELD'
5178       include 'COMMON.CONTROL'
5179       double precision u(3),ud(3)
5180       estr=0.0d0
5181       estr1=0.0d0
5182 c      write (iout,*) "distchainmax",distchainmax
5183       do i=nnt+1,nct
5184 #ifdef FIVEDIAG
5185         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5186         diff = vbld(i)-vbldp0
5187 #else
5188         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5189 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5190 C          do j=1,3
5191 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5192 C     &      *dc(j,i-1)/vbld(i)
5193 C          enddo
5194 C          if (energy_dec) write(iout,*)
5195 C     &       "estr1",i,vbld(i),distchainmax,
5196 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5197 C        else
5198          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5199         diff = vbld(i)-vbldpDUM
5200 C         write(iout,*) i,diff
5201          else
5202           diff = vbld(i)-vbldp0
5203 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5204          endif
5205 #endif
5206           estr=estr+diff*diff
5207           do j=1,3
5208             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5209           enddo
5210 C        endif
5211           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5212      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5213       enddo
5214       estr=0.5d0*AKP*estr+estr1
5215 c
5216 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5217 c
5218       do i=nnt,nct
5219         iti=iabs(itype(i))
5220         if (iti.ne.10 .and. iti.ne.ntyp1) then
5221           nbi=nbondterm(iti)
5222           if (nbi.eq.1) then
5223             diff=vbld(i+nres)-vbldsc0(1,iti)
5224             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5225      &      vbldsc0(1,iti),diff,
5226      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5227             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5228             do j=1,3
5229               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5230             enddo
5231           else
5232             do j=1,nbi
5233               diff=vbld(i+nres)-vbldsc0(j,iti)
5234               ud(j)=aksc(j,iti)*diff
5235               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5236             enddo
5237             uprod=u(1)
5238             do j=2,nbi
5239               uprod=uprod*u(j)
5240             enddo
5241             usum=0.0d0
5242             usumsqder=0.0d0
5243             do j=1,nbi
5244               uprod1=1.0d0
5245               uprod2=1.0d0
5246               do k=1,nbi
5247                 if (k.ne.j) then
5248                   uprod1=uprod1*u(k)
5249                   uprod2=uprod2*u(k)*u(k)
5250                 endif
5251               enddo
5252               usum=usum+uprod1
5253               usumsqder=usumsqder+ud(j)*uprod2
5254             enddo
5255 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5256 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5257             estr=estr+uprod/usum
5258             do j=1,3
5259              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5260             enddo
5261           endif
5262         endif
5263       enddo
5264       return
5265       end
5266 #ifdef CRYST_THETA
5267 C--------------------------------------------------------------------------
5268       subroutine ebend(etheta,ethetacnstr)
5269 C
5270 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5271 C angles gamma and its derivatives in consecutive thetas and gammas.
5272 C
5273       implicit real*8 (a-h,o-z)
5274       include 'DIMENSIONS'
5275       include 'DIMENSIONS.ZSCOPT'
5276       include 'COMMON.LOCAL'
5277       include 'COMMON.GEO'
5278       include 'COMMON.INTERACT'
5279       include 'COMMON.DERIV'
5280       include 'COMMON.VAR'
5281       include 'COMMON.CHAIN'
5282       include 'COMMON.IOUNITS'
5283       include 'COMMON.NAMES'
5284       include 'COMMON.FFIELD'
5285       include 'COMMON.TORCNSTR'
5286       common /calcthet/ term1,term2,termm,diffak,ratak,
5287      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5288      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5289       double precision y(2),z(2)
5290       delta=0.02d0*pi
5291 c      time11=dexp(-2*time)
5292 c      time12=1.0d0
5293       etheta=0.0D0
5294 c      write (iout,*) "nres",nres
5295 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5296 c      write (iout,*) ithet_start,ithet_end
5297       do i=ithet_start,ithet_end
5298 C        if (itype(i-1).eq.ntyp1) cycle
5299         if (i.le.2) cycle
5300         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5301      &  .or.itype(i).eq.ntyp1) cycle
5302 C Zero the energy function and its derivative at 0 or pi.
5303         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5304         it=itype(i-1)
5305         ichir1=isign(1,itype(i-2))
5306         ichir2=isign(1,itype(i))
5307          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5308          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5309          if (itype(i-1).eq.10) then
5310           itype1=isign(10,itype(i-2))
5311           ichir11=isign(1,itype(i-2))
5312           ichir12=isign(1,itype(i-2))
5313           itype2=isign(10,itype(i))
5314           ichir21=isign(1,itype(i))
5315           ichir22=isign(1,itype(i))
5316          endif
5317          if (i.eq.3) then
5318           y(1)=0.0D0
5319           y(2)=0.0D0
5320           else
5321
5322         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5323 #ifdef OSF
5324           phii=phi(i)
5325 c          icrc=0
5326 c          call proc_proc(phii,icrc)
5327           if (icrc.eq.1) phii=150.0
5328 #else
5329           phii=phi(i)
5330 #endif
5331           y(1)=dcos(phii)
5332           y(2)=dsin(phii)
5333         else
5334           y(1)=0.0D0
5335           y(2)=0.0D0
5336         endif
5337         endif
5338         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5339 #ifdef OSF
5340           phii1=phi(i+1)
5341 c          icrc=0
5342 c          call proc_proc(phii1,icrc)
5343           if (icrc.eq.1) phii1=150.0
5344           phii1=pinorm(phii1)
5345           z(1)=cos(phii1)
5346 #else
5347           phii1=phi(i+1)
5348           z(1)=dcos(phii1)
5349 #endif
5350           z(2)=dsin(phii1)
5351         else
5352           z(1)=0.0D0
5353           z(2)=0.0D0
5354         endif
5355 C Calculate the "mean" value of theta from the part of the distribution
5356 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5357 C In following comments this theta will be referred to as t_c.
5358         thet_pred_mean=0.0d0
5359         do k=1,2
5360             athetk=athet(k,it,ichir1,ichir2)
5361             bthetk=bthet(k,it,ichir1,ichir2)
5362           if (it.eq.10) then
5363              athetk=athet(k,itype1,ichir11,ichir12)
5364              bthetk=bthet(k,itype2,ichir21,ichir22)
5365           endif
5366           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5367         enddo
5368 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5369         dthett=thet_pred_mean*ssd
5370         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5371 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5372 C Derivatives of the "mean" values in gamma1 and gamma2.
5373         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5374      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5375          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5376      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5377          if (it.eq.10) then
5378       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5379      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5380         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5381      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5382          endif
5383         if (theta(i).gt.pi-delta) then
5384           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5385      &         E_tc0)
5386           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5387           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5388           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5389      &        E_theta)
5390           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5391      &        E_tc)
5392         else if (theta(i).lt.delta) then
5393           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5394           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5395           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5396      &        E_theta)
5397           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5398           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5399      &        E_tc)
5400         else
5401           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5402      &        E_theta,E_tc)
5403         endif
5404         etheta=etheta+ethetai
5405 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5406 c     &      'ebend',i,ethetai,theta(i),itype(i)
5407 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5408 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5409         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5410         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5411         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5412 c 1215   continue
5413       enddo
5414       ethetacnstr=0.0d0
5415 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5416       do i=1,ntheta_constr
5417         itheta=itheta_constr(i)
5418         thetiii=theta(itheta)
5419         difi=pinorm(thetiii-theta_constr0(i))
5420         if (difi.gt.theta_drange(i)) then
5421           difi=difi-theta_drange(i)
5422           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5423           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5424      &    +for_thet_constr(i)*difi**3
5425         else if (difi.lt.-drange(i)) then
5426           difi=difi+drange(i)
5427           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5428           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5429      &    +for_thet_constr(i)*difi**3
5430         else
5431           difi=0.0
5432         endif
5433 C       if (energy_dec) then
5434 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5435 C     &    i,itheta,rad2deg*thetiii,
5436 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5437 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5438 C     &    gloc(itheta+nphi-2,icg)
5439 C        endif
5440       enddo
5441 C Ufff.... We've done all this!!!
5442       return
5443       end
5444 C---------------------------------------------------------------------------
5445       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5446      &     E_tc)
5447       implicit real*8 (a-h,o-z)
5448       include 'DIMENSIONS'
5449       include 'COMMON.LOCAL'
5450       include 'COMMON.IOUNITS'
5451       common /calcthet/ term1,term2,termm,diffak,ratak,
5452      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5453      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5454 C Calculate the contributions to both Gaussian lobes.
5455 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5456 C The "polynomial part" of the "standard deviation" of this part of
5457 C the distribution.
5458         sig=polthet(3,it)
5459         do j=2,0,-1
5460           sig=sig*thet_pred_mean+polthet(j,it)
5461         enddo
5462 C Derivative of the "interior part" of the "standard deviation of the"
5463 C gamma-dependent Gaussian lobe in t_c.
5464         sigtc=3*polthet(3,it)
5465         do j=2,1,-1
5466           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5467         enddo
5468         sigtc=sig*sigtc
5469 C Set the parameters of both Gaussian lobes of the distribution.
5470 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5471         fac=sig*sig+sigc0(it)
5472         sigcsq=fac+fac
5473         sigc=1.0D0/sigcsq
5474 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5475         sigsqtc=-4.0D0*sigcsq*sigtc
5476 c       print *,i,sig,sigtc,sigsqtc
5477 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5478         sigtc=-sigtc/(fac*fac)
5479 C Following variable is sigma(t_c)**(-2)
5480         sigcsq=sigcsq*sigcsq
5481         sig0i=sig0(it)
5482         sig0inv=1.0D0/sig0i**2
5483         delthec=thetai-thet_pred_mean
5484         delthe0=thetai-theta0i
5485         term1=-0.5D0*sigcsq*delthec*delthec
5486         term2=-0.5D0*sig0inv*delthe0*delthe0
5487 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5488 C NaNs in taking the logarithm. We extract the largest exponent which is added
5489 C to the energy (this being the log of the distribution) at the end of energy
5490 C term evaluation for this virtual-bond angle.
5491         if (term1.gt.term2) then
5492           termm=term1
5493           term2=dexp(term2-termm)
5494           term1=1.0d0
5495         else
5496           termm=term2
5497           term1=dexp(term1-termm)
5498           term2=1.0d0
5499         endif
5500 C The ratio between the gamma-independent and gamma-dependent lobes of
5501 C the distribution is a Gaussian function of thet_pred_mean too.
5502         diffak=gthet(2,it)-thet_pred_mean
5503         ratak=diffak/gthet(3,it)**2
5504         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5505 C Let's differentiate it in thet_pred_mean NOW.
5506         aktc=ak*ratak
5507 C Now put together the distribution terms to make complete distribution.
5508         termexp=term1+ak*term2
5509         termpre=sigc+ak*sig0i
5510 C Contribution of the bending energy from this theta is just the -log of
5511 C the sum of the contributions from the two lobes and the pre-exponential
5512 C factor. Simple enough, isn't it?
5513         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5514 C NOW the derivatives!!!
5515 C 6/6/97 Take into account the deformation.
5516         E_theta=(delthec*sigcsq*term1
5517      &       +ak*delthe0*sig0inv*term2)/termexp
5518         E_tc=((sigtc+aktc*sig0i)/termpre
5519      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5520      &       aktc*term2)/termexp)
5521       return
5522       end
5523 c-----------------------------------------------------------------------------
5524       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5525       implicit real*8 (a-h,o-z)
5526       include 'DIMENSIONS'
5527       include 'COMMON.LOCAL'
5528       include 'COMMON.IOUNITS'
5529       common /calcthet/ term1,term2,termm,diffak,ratak,
5530      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5531      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5532       delthec=thetai-thet_pred_mean
5533       delthe0=thetai-theta0i
5534 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5535       t3 = thetai-thet_pred_mean
5536       t6 = t3**2
5537       t9 = term1
5538       t12 = t3*sigcsq
5539       t14 = t12+t6*sigsqtc
5540       t16 = 1.0d0
5541       t21 = thetai-theta0i
5542       t23 = t21**2
5543       t26 = term2
5544       t27 = t21*t26
5545       t32 = termexp
5546       t40 = t32**2
5547       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5548      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5549      & *(-t12*t9-ak*sig0inv*t27)
5550       return
5551       end
5552 #else
5553 C--------------------------------------------------------------------------
5554       subroutine ebend(etheta)
5555 C
5556 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5557 C angles gamma and its derivatives in consecutive thetas and gammas.
5558 C ab initio-derived potentials from
5559 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5560 C
5561       implicit real*8 (a-h,o-z)
5562       include 'DIMENSIONS'
5563       include 'DIMENSIONS.ZSCOPT'
5564       include 'COMMON.LOCAL'
5565       include 'COMMON.GEO'
5566       include 'COMMON.INTERACT'
5567       include 'COMMON.DERIV'
5568       include 'COMMON.VAR'
5569       include 'COMMON.CHAIN'
5570       include 'COMMON.IOUNITS'
5571       include 'COMMON.NAMES'
5572       include 'COMMON.FFIELD'
5573       include 'COMMON.CONTROL'
5574       include 'COMMON.TORCNSTR'
5575       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5576      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5577      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5578      & sinph1ph2(maxdouble,maxdouble)
5579       logical lprn /.false./, lprn1 /.false./
5580       etheta=0.0D0
5581 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5582       do i=ithet_start,ithet_end
5583 C         if (i.eq.2) cycle
5584 C        if (itype(i-1).eq.ntyp1) cycle
5585         if (i.le.2) cycle
5586         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5587      &  .or.itype(i).eq.ntyp1) cycle
5588         if (iabs(itype(i+1)).eq.20) iblock=2
5589         if (iabs(itype(i+1)).ne.20) iblock=1
5590         dethetai=0.0d0
5591         dephii=0.0d0
5592         dephii1=0.0d0
5593         theti2=0.5d0*theta(i)
5594         ityp2=ithetyp((itype(i-1)))
5595         do k=1,nntheterm
5596           coskt(k)=dcos(k*theti2)
5597           sinkt(k)=dsin(k*theti2)
5598         enddo
5599 cu        if (i.eq.3) then
5600 cu          phii=0.0d0
5601 cu          ityp1=nthetyp+1
5602 cu          do k=1,nsingle
5603 cu            cosph1(k)=0.0d0
5604 cu            sinph1(k)=0.0d0
5605 cu          enddo
5606 cu        else
5607         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5608 #ifdef OSF
5609           phii=phi(i)
5610           if (phii.ne.phii) phii=150.0
5611 #else
5612           phii=phi(i)
5613 #endif
5614           ityp1=ithetyp((itype(i-2)))
5615           do k=1,nsingle
5616             cosph1(k)=dcos(k*phii)
5617             sinph1(k)=dsin(k*phii)
5618           enddo
5619         else
5620           phii=0.0d0
5621 c          ityp1=nthetyp+1
5622           do k=1,nsingle
5623             ityp1=ithetyp((itype(i-2)))
5624             cosph1(k)=0.0d0
5625             sinph1(k)=0.0d0
5626           enddo
5627         endif
5628         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5629 #ifdef OSF
5630           phii1=phi(i+1)
5631           if (phii1.ne.phii1) phii1=150.0
5632           phii1=pinorm(phii1)
5633 #else
5634           phii1=phi(i+1)
5635 #endif
5636           ityp3=ithetyp((itype(i)))
5637           do k=1,nsingle
5638             cosph2(k)=dcos(k*phii1)
5639             sinph2(k)=dsin(k*phii1)
5640           enddo
5641         else
5642           phii1=0.0d0
5643 c          ityp3=nthetyp+1
5644           ityp3=ithetyp((itype(i)))
5645           do k=1,nsingle
5646             cosph2(k)=0.0d0
5647             sinph2(k)=0.0d0
5648           enddo
5649         endif
5650 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5651 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5652 c        call flush(iout)
5653         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5654         do k=1,ndouble
5655           do l=1,k-1
5656             ccl=cosph1(l)*cosph2(k-l)
5657             ssl=sinph1(l)*sinph2(k-l)
5658             scl=sinph1(l)*cosph2(k-l)
5659             csl=cosph1(l)*sinph2(k-l)
5660             cosph1ph2(l,k)=ccl-ssl
5661             cosph1ph2(k,l)=ccl+ssl
5662             sinph1ph2(l,k)=scl+csl
5663             sinph1ph2(k,l)=scl-csl
5664           enddo
5665         enddo
5666         if (lprn) then
5667         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5668      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5669         write (iout,*) "coskt and sinkt"
5670         do k=1,nntheterm
5671           write (iout,*) k,coskt(k),sinkt(k)
5672         enddo
5673         endif
5674         do k=1,ntheterm
5675           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5676           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5677      &      *coskt(k)
5678           if (lprn)
5679      &    write (iout,*) "k",k,"
5680      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5681      &     " ethetai",ethetai
5682         enddo
5683         if (lprn) then
5684         write (iout,*) "cosph and sinph"
5685         do k=1,nsingle
5686           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5687         enddo
5688         write (iout,*) "cosph1ph2 and sinph2ph2"
5689         do k=2,ndouble
5690           do l=1,k-1
5691             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5692      &         sinph1ph2(l,k),sinph1ph2(k,l)
5693           enddo
5694         enddo
5695         write(iout,*) "ethetai",ethetai
5696         endif
5697         do m=1,ntheterm2
5698           do k=1,nsingle
5699             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5700      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5701      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5702      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5703             ethetai=ethetai+sinkt(m)*aux
5704             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5705             dephii=dephii+k*sinkt(m)*(
5706      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5707      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5708             dephii1=dephii1+k*sinkt(m)*(
5709      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5710      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5711             if (lprn)
5712      &      write (iout,*) "m",m," k",k," bbthet",
5713      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5714      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5715      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5716      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5717           enddo
5718         enddo
5719         if (lprn)
5720      &  write(iout,*) "ethetai",ethetai
5721         do m=1,ntheterm3
5722           do k=2,ndouble
5723             do l=1,k-1
5724               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5725      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5726      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5727      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5728               ethetai=ethetai+sinkt(m)*aux
5729               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5730               dephii=dephii+l*sinkt(m)*(
5731      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5732      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5733      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5734      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5735               dephii1=dephii1+(k-l)*sinkt(m)*(
5736      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5737      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5738      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5739      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5740               if (lprn) then
5741               write (iout,*) "m",m," k",k," l",l," ffthet",
5742      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5743      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5744      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5745      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5746      &            " ethetai",ethetai
5747               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5748      &            cosph1ph2(k,l)*sinkt(m),
5749      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5750               endif
5751             enddo
5752           enddo
5753         enddo
5754 10      continue
5755         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5756      &   i,theta(i)*rad2deg,phii*rad2deg,
5757      &   phii1*rad2deg,ethetai
5758         etheta=etheta+ethetai
5759         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5760         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5761 c        gloc(nphi+i-2,icg)=wang*dethetai
5762         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5763       enddo
5764       return
5765       end
5766 #endif
5767 #ifdef CRYST_SC
5768 c-----------------------------------------------------------------------------
5769       subroutine esc(escloc)
5770 C Calculate the local energy of a side chain and its derivatives in the
5771 C corresponding virtual-bond valence angles THETA and the spherical angles
5772 C ALPHA and OMEGA.
5773       implicit real*8 (a-h,o-z)
5774       include 'DIMENSIONS'
5775       include 'DIMENSIONS.ZSCOPT'
5776       include 'COMMON.GEO'
5777       include 'COMMON.LOCAL'
5778       include 'COMMON.VAR'
5779       include 'COMMON.INTERACT'
5780       include 'COMMON.DERIV'
5781       include 'COMMON.CHAIN'
5782       include 'COMMON.IOUNITS'
5783       include 'COMMON.NAMES'
5784       include 'COMMON.FFIELD'
5785       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5786      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5787       common /sccalc/ time11,time12,time112,theti,it,nlobit
5788       delta=0.02d0*pi
5789       escloc=0.0D0
5790 C      write (iout,*) 'ESC'
5791       do i=loc_start,loc_end
5792         it=itype(i)
5793         if (it.eq.ntyp1) cycle
5794         if (it.eq.10) goto 1
5795         nlobit=nlob(iabs(it))
5796 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5797 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5798         theti=theta(i+1)-pipol
5799         x(1)=dtan(theti)
5800         x(2)=alph(i)
5801         x(3)=omeg(i)
5802 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5803
5804         if (x(2).gt.pi-delta) then
5805           xtemp(1)=x(1)
5806           xtemp(2)=pi-delta
5807           xtemp(3)=x(3)
5808           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5809           xtemp(2)=pi
5810           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5811           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5812      &        escloci,dersc(2))
5813           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5814      &        ddersc0(1),dersc(1))
5815           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5816      &        ddersc0(3),dersc(3))
5817           xtemp(2)=pi-delta
5818           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5819           xtemp(2)=pi
5820           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5821           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5822      &            dersc0(2),esclocbi,dersc02)
5823           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5824      &            dersc12,dersc01)
5825           call splinthet(x(2),0.5d0*delta,ss,ssd)
5826           dersc0(1)=dersc01
5827           dersc0(2)=dersc02
5828           dersc0(3)=0.0d0
5829           do k=1,3
5830             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5831           enddo
5832           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5833           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5834      &             esclocbi,ss,ssd
5835           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5836 c         escloci=esclocbi
5837 c         write (iout,*) escloci
5838         else if (x(2).lt.delta) then
5839           xtemp(1)=x(1)
5840           xtemp(2)=delta
5841           xtemp(3)=x(3)
5842           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5843           xtemp(2)=0.0d0
5844           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5845           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5846      &        escloci,dersc(2))
5847           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5848      &        ddersc0(1),dersc(1))
5849           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5850      &        ddersc0(3),dersc(3))
5851           xtemp(2)=delta
5852           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5853           xtemp(2)=0.0d0
5854           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5855           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5856      &            dersc0(2),esclocbi,dersc02)
5857           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5858      &            dersc12,dersc01)
5859           dersc0(1)=dersc01
5860           dersc0(2)=dersc02
5861           dersc0(3)=0.0d0
5862           call splinthet(x(2),0.5d0*delta,ss,ssd)
5863           do k=1,3
5864             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5865           enddo
5866           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5867 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5868 c     &             esclocbi,ss,ssd
5869           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5870 C         write (iout,*) 'i=',i, escloci
5871         else
5872           call enesc(x,escloci,dersc,ddummy,.false.)
5873         endif
5874
5875         escloc=escloc+escloci
5876 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5877             write (iout,'(a6,i5,0pf7.3)')
5878      &     'escloc',i,escloci
5879
5880         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5881      &   wscloc*dersc(1)
5882         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5883         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5884     1   continue
5885       enddo
5886       return
5887       end
5888 C---------------------------------------------------------------------------
5889       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5890       implicit real*8 (a-h,o-z)
5891       include 'DIMENSIONS'
5892       include 'COMMON.GEO'
5893       include 'COMMON.LOCAL'
5894       include 'COMMON.IOUNITS'
5895       common /sccalc/ time11,time12,time112,theti,it,nlobit
5896       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5897       double precision contr(maxlob,-1:1)
5898       logical mixed
5899 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5900         escloc_i=0.0D0
5901         do j=1,3
5902           dersc(j)=0.0D0
5903           if (mixed) ddersc(j)=0.0d0
5904         enddo
5905         x3=x(3)
5906
5907 C Because of periodicity of the dependence of the SC energy in omega we have
5908 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5909 C To avoid underflows, first compute & store the exponents.
5910
5911         do iii=-1,1
5912
5913           x(3)=x3+iii*dwapi
5914
5915           do j=1,nlobit
5916             do k=1,3
5917               z(k)=x(k)-censc(k,j,it)
5918             enddo
5919             do k=1,3
5920               Axk=0.0D0
5921               do l=1,3
5922                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5923               enddo
5924               Ax(k,j,iii)=Axk
5925             enddo
5926             expfac=0.0D0
5927             do k=1,3
5928               expfac=expfac+Ax(k,j,iii)*z(k)
5929             enddo
5930             contr(j,iii)=expfac
5931           enddo ! j
5932
5933         enddo ! iii
5934
5935         x(3)=x3
5936 C As in the case of ebend, we want to avoid underflows in exponentiation and
5937 C subsequent NaNs and INFs in energy calculation.
5938 C Find the largest exponent
5939         emin=contr(1,-1)
5940         do iii=-1,1
5941           do j=1,nlobit
5942             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5943           enddo
5944         enddo
5945         emin=0.5D0*emin
5946 cd      print *,'it=',it,' emin=',emin
5947
5948 C Compute the contribution to SC energy and derivatives
5949         do iii=-1,1
5950
5951           do j=1,nlobit
5952             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5953 cd          print *,'j=',j,' expfac=',expfac
5954             escloc_i=escloc_i+expfac
5955             do k=1,3
5956               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5957             enddo
5958             if (mixed) then
5959               do k=1,3,2
5960                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5961      &            +gaussc(k,2,j,it))*expfac
5962               enddo
5963             endif
5964           enddo
5965
5966         enddo ! iii
5967
5968         dersc(1)=dersc(1)/cos(theti)**2
5969         ddersc(1)=ddersc(1)/cos(theti)**2
5970         ddersc(3)=ddersc(3)
5971
5972         escloci=-(dlog(escloc_i)-emin)
5973         do j=1,3
5974           dersc(j)=dersc(j)/escloc_i
5975         enddo
5976         if (mixed) then
5977           do j=1,3,2
5978             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5979           enddo
5980         endif
5981       return
5982       end
5983 C------------------------------------------------------------------------------
5984       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5985       implicit real*8 (a-h,o-z)
5986       include 'DIMENSIONS'
5987       include 'COMMON.GEO'
5988       include 'COMMON.LOCAL'
5989       include 'COMMON.IOUNITS'
5990       common /sccalc/ time11,time12,time112,theti,it,nlobit
5991       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5992       double precision contr(maxlob)
5993       logical mixed
5994
5995       escloc_i=0.0D0
5996
5997       do j=1,3
5998         dersc(j)=0.0D0
5999       enddo
6000
6001       do j=1,nlobit
6002         do k=1,2
6003           z(k)=x(k)-censc(k,j,it)
6004         enddo
6005         z(3)=dwapi
6006         do k=1,3
6007           Axk=0.0D0
6008           do l=1,3
6009             Axk=Axk+gaussc(l,k,j,it)*z(l)
6010           enddo
6011           Ax(k,j)=Axk
6012         enddo
6013         expfac=0.0D0
6014         do k=1,3
6015           expfac=expfac+Ax(k,j)*z(k)
6016         enddo
6017         contr(j)=expfac
6018       enddo ! j
6019
6020 C As in the case of ebend, we want to avoid underflows in exponentiation and
6021 C subsequent NaNs and INFs in energy calculation.
6022 C Find the largest exponent
6023       emin=contr(1)
6024       do j=1,nlobit
6025         if (emin.gt.contr(j)) emin=contr(j)
6026       enddo
6027       emin=0.5D0*emin
6028
6029 C Compute the contribution to SC energy and derivatives
6030
6031       dersc12=0.0d0
6032       do j=1,nlobit
6033         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6034         escloc_i=escloc_i+expfac
6035         do k=1,2
6036           dersc(k)=dersc(k)+Ax(k,j)*expfac
6037         enddo
6038         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6039      &            +gaussc(1,2,j,it))*expfac
6040         dersc(3)=0.0d0
6041       enddo
6042
6043       dersc(1)=dersc(1)/cos(theti)**2
6044       dersc12=dersc12/cos(theti)**2
6045       escloci=-(dlog(escloc_i)-emin)
6046       do j=1,2
6047         dersc(j)=dersc(j)/escloc_i
6048       enddo
6049       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6050       return
6051       end
6052 #else
6053 c----------------------------------------------------------------------------------
6054       subroutine esc(escloc)
6055 C Calculate the local energy of a side chain and its derivatives in the
6056 C corresponding virtual-bond valence angles THETA and the spherical angles
6057 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6058 C added by Urszula Kozlowska. 07/11/2007
6059 C
6060       implicit real*8 (a-h,o-z)
6061       include 'DIMENSIONS'
6062       include 'DIMENSIONS.ZSCOPT'
6063       include 'COMMON.GEO'
6064       include 'COMMON.LOCAL'
6065       include 'COMMON.VAR'
6066       include 'COMMON.SCROT'
6067       include 'COMMON.INTERACT'
6068       include 'COMMON.DERIV'
6069       include 'COMMON.CHAIN'
6070       include 'COMMON.IOUNITS'
6071       include 'COMMON.NAMES'
6072       include 'COMMON.FFIELD'
6073       include 'COMMON.CONTROL'
6074       include 'COMMON.VECTORS'
6075       double precision x_prime(3),y_prime(3),z_prime(3)
6076      &    , sumene,dsc_i,dp2_i,x(65),
6077      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6078      &    de_dxx,de_dyy,de_dzz,de_dt
6079       double precision s1_t,s1_6_t,s2_t,s2_6_t
6080       double precision
6081      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6082      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6083      & dt_dCi(3),dt_dCi1(3)
6084       common /sccalc/ time11,time12,time112,theti,it,nlobit
6085       delta=0.02d0*pi
6086       escloc=0.0D0
6087       do i=loc_start,loc_end
6088         if (itype(i).eq.ntyp1) cycle
6089         costtab(i+1) =dcos(theta(i+1))
6090         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6091         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6092         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6093         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6094         cosfac=dsqrt(cosfac2)
6095         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6096         sinfac=dsqrt(sinfac2)
6097         it=iabs(itype(i))
6098         if (it.eq.10) goto 1
6099 c
6100 C  Compute the axes of tghe local cartesian coordinates system; store in
6101 c   x_prime, y_prime and z_prime
6102 c
6103         do j=1,3
6104           x_prime(j) = 0.00
6105           y_prime(j) = 0.00
6106           z_prime(j) = 0.00
6107         enddo
6108 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6109 C     &   dc_norm(3,i+nres)
6110         do j = 1,3
6111           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6112           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6113         enddo
6114         do j = 1,3
6115           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6116         enddo
6117 c       write (2,*) "i",i
6118 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6119 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6120 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6121 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6122 c      & " xy",scalar(x_prime(1),y_prime(1)),
6123 c      & " xz",scalar(x_prime(1),z_prime(1)),
6124 c      & " yy",scalar(y_prime(1),y_prime(1)),
6125 c      & " yz",scalar(y_prime(1),z_prime(1)),
6126 c      & " zz",scalar(z_prime(1),z_prime(1))
6127 c
6128 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6129 C to local coordinate system. Store in xx, yy, zz.
6130 c
6131         xx=0.0d0
6132         yy=0.0d0
6133         zz=0.0d0
6134         do j = 1,3
6135           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6136           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6137           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6138         enddo
6139
6140         xxtab(i)=xx
6141         yytab(i)=yy
6142         zztab(i)=zz
6143 C
6144 C Compute the energy of the ith side cbain
6145 C
6146 c        write (2,*) "xx",xx," yy",yy," zz",zz
6147         it=iabs(itype(i))
6148         do j = 1,65
6149           x(j) = sc_parmin(j,it)
6150         enddo
6151 #ifdef CHECK_COORD
6152 Cc diagnostics - remove later
6153         xx1 = dcos(alph(2))
6154         yy1 = dsin(alph(2))*dcos(omeg(2))
6155         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6156         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6157      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6158      &    xx1,yy1,zz1
6159 C,"  --- ", xx_w,yy_w,zz_w
6160 c end diagnostics
6161 #endif
6162         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6163      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6164      &   + x(10)*yy*zz
6165         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6166      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6167      & + x(20)*yy*zz
6168         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6169      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6170      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6171      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6172      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6173      &  +x(40)*xx*yy*zz
6174         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6175      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6176      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6177      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6178      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6179      &  +x(60)*xx*yy*zz
6180         dsc_i   = 0.743d0+x(61)
6181         dp2_i   = 1.9d0+x(62)
6182         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6183      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6184         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6185      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6186         s1=(1+x(63))/(0.1d0 + dscp1)
6187         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6188         s2=(1+x(65))/(0.1d0 + dscp2)
6189         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6190         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6191      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6192 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6193 c     &   sumene4,
6194 c     &   dscp1,dscp2,sumene
6195 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6196         escloc = escloc + sumene
6197 c        write (2,*) "escloc",escloc
6198 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6199 c     &  zz,xx,yy
6200         if (.not. calc_grad) goto 1
6201 #ifdef DEBUG
6202 C
6203 C This section to check the numerical derivatives of the energy of ith side
6204 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6205 C #define DEBUG in the code to turn it on.
6206 C
6207         write (2,*) "sumene               =",sumene
6208         aincr=1.0d-7
6209         xxsave=xx
6210         xx=xx+aincr
6211         write (2,*) xx,yy,zz
6212         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6213         de_dxx_num=(sumenep-sumene)/aincr
6214         xx=xxsave
6215         write (2,*) "xx+ sumene from enesc=",sumenep
6216         yysave=yy
6217         yy=yy+aincr
6218         write (2,*) xx,yy,zz
6219         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6220         de_dyy_num=(sumenep-sumene)/aincr
6221         yy=yysave
6222         write (2,*) "yy+ sumene from enesc=",sumenep
6223         zzsave=zz
6224         zz=zz+aincr
6225         write (2,*) xx,yy,zz
6226         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6227         de_dzz_num=(sumenep-sumene)/aincr
6228         zz=zzsave
6229         write (2,*) "zz+ sumene from enesc=",sumenep
6230         costsave=cost2tab(i+1)
6231         sintsave=sint2tab(i+1)
6232         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6233         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6234         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6235         de_dt_num=(sumenep-sumene)/aincr
6236         write (2,*) " t+ sumene from enesc=",sumenep
6237         cost2tab(i+1)=costsave
6238         sint2tab(i+1)=sintsave
6239 C End of diagnostics section.
6240 #endif
6241 C
6242 C Compute the gradient of esc
6243 C
6244         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6245         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6246         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6247         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6248         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6249         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6250         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6251         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6252         pom1=(sumene3*sint2tab(i+1)+sumene1)
6253      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6254         pom2=(sumene4*cost2tab(i+1)+sumene2)
6255      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6256         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6257         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6258      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6259      &  +x(40)*yy*zz
6260         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6261         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6262      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6263      &  +x(60)*yy*zz
6264         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6265      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6266      &        +(pom1+pom2)*pom_dx
6267 #ifdef DEBUG
6268         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6269 #endif
6270 C
6271         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6272         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6273      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6274      &  +x(40)*xx*zz
6275         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6276         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6277      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6278      &  +x(59)*zz**2 +x(60)*xx*zz
6279         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6280      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6281      &        +(pom1-pom2)*pom_dy
6282 #ifdef DEBUG
6283         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6284 #endif
6285 C
6286         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6287      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6288      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6289      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6290      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6291      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6292      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6293      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6294 #ifdef DEBUG
6295         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6296 #endif
6297 C
6298         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6299      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6300      &  +pom1*pom_dt1+pom2*pom_dt2
6301 #ifdef DEBUG
6302         write(2,*), "de_dt = ", de_dt,de_dt_num
6303 #endif
6304 c
6305 C
6306        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6307        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6308        cosfac2xx=cosfac2*xx
6309        sinfac2yy=sinfac2*yy
6310        do k = 1,3
6311          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6312      &      vbld_inv(i+1)
6313          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6314      &      vbld_inv(i)
6315          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6316          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6317 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6318 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6319 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6320 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6321          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6322          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6323          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6324          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6325          dZZ_Ci1(k)=0.0d0
6326          dZZ_Ci(k)=0.0d0
6327          do j=1,3
6328            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6329      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6330            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6331      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6332          enddo
6333
6334          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6335          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6336          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6337 c
6338          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6339          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6340        enddo
6341
6342        do k=1,3
6343          dXX_Ctab(k,i)=dXX_Ci(k)
6344          dXX_C1tab(k,i)=dXX_Ci1(k)
6345          dYY_Ctab(k,i)=dYY_Ci(k)
6346          dYY_C1tab(k,i)=dYY_Ci1(k)
6347          dZZ_Ctab(k,i)=dZZ_Ci(k)
6348          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6349          dXX_XYZtab(k,i)=dXX_XYZ(k)
6350          dYY_XYZtab(k,i)=dYY_XYZ(k)
6351          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6352        enddo
6353
6354        do k = 1,3
6355 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6356 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6357 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6358 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6359 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6360 c     &    dt_dci(k)
6361 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6362 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6363          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6364      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6365          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6366      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6367          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6368      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6369        enddo
6370 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6371 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6372
6373 C to check gradient call subroutine check_grad
6374
6375     1 continue
6376       enddo
6377       return
6378       end
6379 #endif
6380 c------------------------------------------------------------------------------
6381       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6382 C
6383 C This procedure calculates two-body contact function g(rij) and its derivative:
6384 C
6385 C           eps0ij                                     !       x < -1
6386 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6387 C            0                                         !       x > 1
6388 C
6389 C where x=(rij-r0ij)/delta
6390 C
6391 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6392 C
6393       implicit none
6394       double precision rij,r0ij,eps0ij,fcont,fprimcont
6395       double precision x,x2,x4,delta
6396 c     delta=0.02D0*r0ij
6397 c      delta=0.2D0*r0ij
6398       x=(rij-r0ij)/delta
6399       if (x.lt.-1.0D0) then
6400         fcont=eps0ij
6401         fprimcont=0.0D0
6402       else if (x.le.1.0D0) then
6403         x2=x*x
6404         x4=x2*x2
6405         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6406         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6407       else
6408         fcont=0.0D0
6409         fprimcont=0.0D0
6410       endif
6411       return
6412       end
6413 c------------------------------------------------------------------------------
6414       subroutine splinthet(theti,delta,ss,ssder)
6415       implicit real*8 (a-h,o-z)
6416       include 'DIMENSIONS'
6417       include 'DIMENSIONS.ZSCOPT'
6418       include 'COMMON.VAR'
6419       include 'COMMON.GEO'
6420       thetup=pi-delta
6421       thetlow=delta
6422       if (theti.gt.pipol) then
6423         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6424       else
6425         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6426         ssder=-ssder
6427       endif
6428       return
6429       end
6430 c------------------------------------------------------------------------------
6431       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6432       implicit none
6433       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6434       double precision ksi,ksi2,ksi3,a1,a2,a3
6435       a1=fprim0*delta/(f1-f0)
6436       a2=3.0d0-2.0d0*a1
6437       a3=a1-2.0d0
6438       ksi=(x-x0)/delta
6439       ksi2=ksi*ksi
6440       ksi3=ksi2*ksi
6441       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6442       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6443       return
6444       end
6445 c------------------------------------------------------------------------------
6446       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6447       implicit none
6448       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6449       double precision ksi,ksi2,ksi3,a1,a2,a3
6450       ksi=(x-x0)/delta
6451       ksi2=ksi*ksi
6452       ksi3=ksi2*ksi
6453       a1=fprim0x*delta
6454       a2=3*(f1x-f0x)-2*fprim0x*delta
6455       a3=fprim0x*delta-2*(f1x-f0x)
6456       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6457       return
6458       end
6459 C-----------------------------------------------------------------------------
6460 #ifdef CRYST_TOR
6461 C-----------------------------------------------------------------------------
6462       subroutine etor(etors,fact)
6463       implicit real*8 (a-h,o-z)
6464       include 'DIMENSIONS'
6465       include 'DIMENSIONS.ZSCOPT'
6466       include 'COMMON.VAR'
6467       include 'COMMON.GEO'
6468       include 'COMMON.LOCAL'
6469       include 'COMMON.TORSION'
6470       include 'COMMON.INTERACT'
6471       include 'COMMON.DERIV'
6472       include 'COMMON.CHAIN'
6473       include 'COMMON.NAMES'
6474       include 'COMMON.IOUNITS'
6475       include 'COMMON.FFIELD'
6476       include 'COMMON.TORCNSTR'
6477       logical lprn
6478 C Set lprn=.true. for debugging
6479       lprn=.false.
6480 c      lprn=.true.
6481       etors=0.0D0
6482       do i=iphi_start,iphi_end
6483         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6484      &      .or. itype(i).eq.ntyp1) cycle
6485         itori=itortyp(itype(i-2))
6486         itori1=itortyp(itype(i-1))
6487         phii=phi(i)
6488         gloci=0.0D0
6489 C Proline-Proline pair is a special case...
6490         if (itori.eq.3 .and. itori1.eq.3) then
6491           if (phii.gt.-dwapi3) then
6492             cosphi=dcos(3*phii)
6493             fac=1.0D0/(1.0D0-cosphi)
6494             etorsi=v1(1,3,3)*fac
6495             etorsi=etorsi+etorsi
6496             etors=etors+etorsi-v1(1,3,3)
6497             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6498           endif
6499           do j=1,3
6500             v1ij=v1(j+1,itori,itori1)
6501             v2ij=v2(j+1,itori,itori1)
6502             cosphi=dcos(j*phii)
6503             sinphi=dsin(j*phii)
6504             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6505             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6506           enddo
6507         else
6508           do j=1,nterm_old
6509             v1ij=v1(j,itori,itori1)
6510             v2ij=v2(j,itori,itori1)
6511             cosphi=dcos(j*phii)
6512             sinphi=dsin(j*phii)
6513             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6514             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6515           enddo
6516         endif
6517         if (lprn)
6518      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6519      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6520      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6521         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6522 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6523       enddo
6524       return
6525       end
6526 c------------------------------------------------------------------------------
6527 #else
6528       subroutine etor(etors,fact)
6529       implicit real*8 (a-h,o-z)
6530       include 'DIMENSIONS'
6531       include 'DIMENSIONS.ZSCOPT'
6532       include 'COMMON.VAR'
6533       include 'COMMON.GEO'
6534       include 'COMMON.LOCAL'
6535       include 'COMMON.TORSION'
6536       include 'COMMON.INTERACT'
6537       include 'COMMON.DERIV'
6538       include 'COMMON.CHAIN'
6539       include 'COMMON.NAMES'
6540       include 'COMMON.IOUNITS'
6541       include 'COMMON.FFIELD'
6542       include 'COMMON.TORCNSTR'
6543       logical lprn
6544 C Set lprn=.true. for debugging
6545       lprn=.false.
6546 c      lprn=.true.
6547       etors=0.0D0
6548       do i=iphi_start,iphi_end
6549         if (i.le.2) cycle
6550         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6551      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6552 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6553 C     &       .or. itype(i).eq.ntyp1) cycle
6554         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6555          if (iabs(itype(i)).eq.20) then
6556          iblock=2
6557          else
6558          iblock=1
6559          endif
6560         itori=itortyp(itype(i-2))
6561         itori1=itortyp(itype(i-1))
6562         phii=phi(i)
6563         gloci=0.0D0
6564 C Regular cosine and sine terms
6565         do j=1,nterm(itori,itori1,iblock)
6566           v1ij=v1(j,itori,itori1,iblock)
6567           v2ij=v2(j,itori,itori1,iblock)
6568           cosphi=dcos(j*phii)
6569           sinphi=dsin(j*phii)
6570           etors=etors+v1ij*cosphi+v2ij*sinphi
6571           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6572         enddo
6573 C Lorentz terms
6574 C                         v1
6575 C  E = SUM ----------------------------------- - v1
6576 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6577 C
6578         cosphi=dcos(0.5d0*phii)
6579         sinphi=dsin(0.5d0*phii)
6580         do j=1,nlor(itori,itori1,iblock)
6581           vl1ij=vlor1(j,itori,itori1)
6582           vl2ij=vlor2(j,itori,itori1)
6583           vl3ij=vlor3(j,itori,itori1)
6584           pom=vl2ij*cosphi+vl3ij*sinphi
6585           pom1=1.0d0/(pom*pom+1.0d0)
6586           etors=etors+vl1ij*pom1
6587 c          if (energy_dec) etors_ii=etors_ii+
6588 c     &                vl1ij*pom1
6589           pom=-pom*pom1*pom1
6590           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6591         enddo
6592 C Subtract the constant term
6593         etors=etors-v0(itori,itori1,iblock)
6594         if (lprn)
6595      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6596      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6597      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6598         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6599 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6600  1215   continue
6601       enddo
6602       return
6603       end
6604 c----------------------------------------------------------------------------
6605       subroutine etor_d(etors_d,fact2)
6606 C 6/23/01 Compute double torsional energy
6607       implicit real*8 (a-h,o-z)
6608       include 'DIMENSIONS'
6609       include 'DIMENSIONS.ZSCOPT'
6610       include 'COMMON.VAR'
6611       include 'COMMON.GEO'
6612       include 'COMMON.LOCAL'
6613       include 'COMMON.TORSION'
6614       include 'COMMON.INTERACT'
6615       include 'COMMON.DERIV'
6616       include 'COMMON.CHAIN'
6617       include 'COMMON.NAMES'
6618       include 'COMMON.IOUNITS'
6619       include 'COMMON.FFIELD'
6620       include 'COMMON.TORCNSTR'
6621       logical lprn
6622 C Set lprn=.true. for debugging
6623       lprn=.false.
6624 c     lprn=.true.
6625       etors_d=0.0D0
6626       do i=iphi_start,iphi_end-1
6627         if (i.le.3) cycle
6628 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6629 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6630          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6631      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6632      &  (itype(i+1).eq.ntyp1)) cycle
6633         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6634      &     goto 1215
6635         itori=itortyp(itype(i-2))
6636         itori1=itortyp(itype(i-1))
6637         itori2=itortyp(itype(i))
6638         phii=phi(i)
6639         phii1=phi(i+1)
6640         gloci1=0.0D0
6641         gloci2=0.0D0
6642         iblock=1
6643         if (iabs(itype(i+1)).eq.20) iblock=2
6644 C Regular cosine and sine terms
6645         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6646           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6647           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6648           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6649           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6650           cosphi1=dcos(j*phii)
6651           sinphi1=dsin(j*phii)
6652           cosphi2=dcos(j*phii1)
6653           sinphi2=dsin(j*phii1)
6654           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6655      &     v2cij*cosphi2+v2sij*sinphi2
6656           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6657           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6658         enddo
6659         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6660           do l=1,k-1
6661             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6662             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6663             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6664             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6665             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6666             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6667             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6668             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6669             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6670      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6671             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6672      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6673             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6674      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6675           enddo
6676         enddo
6677         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6678         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6679  1215   continue
6680       enddo
6681       return
6682       end
6683 #endif
6684 c---------------------------------------------------------------------------
6685 C The rigorous attempt to derive energy function
6686       subroutine etor_kcc(etors,fact)
6687       implicit real*8 (a-h,o-z)
6688       include 'DIMENSIONS'
6689       include 'DIMENSIONS.ZSCOPT'
6690       include 'COMMON.VAR'
6691       include 'COMMON.GEO'
6692       include 'COMMON.LOCAL'
6693       include 'COMMON.TORSION'
6694       include 'COMMON.INTERACT'
6695       include 'COMMON.DERIV'
6696       include 'COMMON.CHAIN'
6697       include 'COMMON.NAMES'
6698       include 'COMMON.IOUNITS'
6699       include 'COMMON.FFIELD'
6700       include 'COMMON.TORCNSTR'
6701       include 'COMMON.CONTROL'
6702       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6703       logical lprn
6704 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6705 C Set lprn=.true. for debugging
6706       lprn=energy_dec
6707 c     lprn=.true.
6708 C      print *,"wchodze kcc"
6709       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6710       etors=0.0D0
6711       do i=iphi_start,iphi_end
6712 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6713 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6714 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6715 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6716         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6717      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6718         itori=itortyp(itype(i-2))
6719         itori1=itortyp(itype(i-1))
6720         phii=phi(i)
6721         glocig=0.0D0
6722         glocit1=0.0d0
6723         glocit2=0.0d0
6724 C to avoid multiple devision by 2
6725 c        theti22=0.5d0*theta(i)
6726 C theta 12 is the theta_1 /2
6727 C theta 22 is theta_2 /2
6728 c        theti12=0.5d0*theta(i-1)
6729 C and appropriate sinus function
6730         sinthet1=dsin(theta(i-1))
6731         sinthet2=dsin(theta(i))
6732         costhet1=dcos(theta(i-1))
6733         costhet2=dcos(theta(i))
6734 C to speed up lets store its mutliplication
6735         sint1t2=sinthet2*sinthet1
6736         sint1t2n=1.0d0
6737 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6738 C +d_n*sin(n*gamma)) *
6739 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6740 C we have two sum 1) Non-Chebyshev which is with n and gamma
6741         nval=nterm_kcc_Tb(itori,itori1)
6742         c1(0)=0.0d0
6743         c2(0)=0.0d0
6744         c1(1)=1.0d0
6745         c2(1)=1.0d0
6746         do j=2,nval
6747           c1(j)=c1(j-1)*costhet1
6748           c2(j)=c2(j-1)*costhet2
6749         enddo
6750         etori=0.0d0
6751         do j=1,nterm_kcc(itori,itori1)
6752           cosphi=dcos(j*phii)
6753           sinphi=dsin(j*phii)
6754           sint1t2n1=sint1t2n
6755           sint1t2n=sint1t2n*sint1t2
6756           sumvalc=0.0d0
6757           gradvalct1=0.0d0
6758           gradvalct2=0.0d0
6759           do k=1,nval
6760             do l=1,nval
6761               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6762               gradvalct1=gradvalct1+
6763      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6764               gradvalct2=gradvalct2+
6765      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6766             enddo
6767           enddo
6768           gradvalct1=-gradvalct1*sinthet1
6769           gradvalct2=-gradvalct2*sinthet2
6770           sumvals=0.0d0
6771           gradvalst1=0.0d0
6772           gradvalst2=0.0d0
6773           do k=1,nval
6774             do l=1,nval
6775               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6776               gradvalst1=gradvalst1+
6777      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6778               gradvalst2=gradvalst2+
6779      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6780             enddo
6781           enddo
6782           gradvalst1=-gradvalst1*sinthet1
6783           gradvalst2=-gradvalst2*sinthet2
6784           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6785 C glocig is the gradient local i site in gamma
6786           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6787 C now gradient over theta_1
6788           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6789      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6790           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6791      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6792         enddo ! j
6793         etors=etors+etori
6794 C derivative over gamma
6795         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6796 C derivative over theta1
6797         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6798 C now derivative over theta2
6799         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6800         if (lprn) then
6801           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6802      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6803           write (iout,*) "c1",(c1(k),k=0,nval),
6804      &    " c2",(c2(k),k=0,nval)
6805           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6806         endif
6807       enddo
6808       return
6809       end
6810 c---------------------------------------------------------------------------------------------
6811       subroutine etor_constr(edihcnstr)
6812       implicit real*8 (a-h,o-z)
6813       include 'DIMENSIONS'
6814       include 'DIMENSIONS.ZSCOPT'
6815       include 'COMMON.VAR'
6816       include 'COMMON.GEO'
6817       include 'COMMON.LOCAL'
6818       include 'COMMON.TORSION'
6819       include 'COMMON.INTERACT'
6820       include 'COMMON.DERIV'
6821       include 'COMMON.CHAIN'
6822       include 'COMMON.NAMES'
6823       include 'COMMON.IOUNITS'
6824       include 'COMMON.FFIELD'
6825       include 'COMMON.TORCNSTR'
6826       include 'COMMON.CONTROL'
6827 ! 6/20/98 - dihedral angle constraints
6828       edihcnstr=0.0d0
6829 c      do i=1,ndih_constr
6830 c      write (iout,*) "idihconstr_start",idihconstr_start,
6831 c     &  " idihconstr_end",idihconstr_end
6832
6833       if (raw_psipred) then
6834         do i=idihconstr_start,idihconstr_end
6835           itori=idih_constr(i)
6836           phii=phi(itori)
6837           gaudih_i=vpsipred(1,i)
6838           gauder_i=0.0d0
6839           do j=1,2
6840             s = sdihed(j,i)
6841             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6842             dexpcos_i=dexp(-cos_i*cos_i)
6843             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6844             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6845      &            *cos_i*dexpcos_i/s**2
6846           enddo
6847           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6848           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6849           if (energy_dec)
6850      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6851      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6852      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6853      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6854      &     -wdihc*dlog(gaudih_i)
6855         enddo
6856       else
6857
6858       do i=idihconstr_start,idihconstr_end
6859         itori=idih_constr(i)
6860         phii=phi(itori)
6861         difi=pinorm(phii-phi0(i))
6862         if (difi.gt.drange(i)) then
6863           difi=difi-drange(i)
6864           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6865           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6866         else if (difi.lt.-drange(i)) then
6867           difi=difi+drange(i)
6868           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6870         else
6871           difi=0.0
6872         endif
6873       enddo
6874
6875       endif
6876
6877 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6878       return
6879       end
6880 c----------------------------------------------------------------------------
6881 C The rigorous attempt to derive energy function
6882       subroutine ebend_kcc(etheta)
6883
6884       implicit real*8 (a-h,o-z)
6885       include 'DIMENSIONS'
6886       include 'DIMENSIONS.ZSCOPT'
6887       include 'COMMON.VAR'
6888       include 'COMMON.GEO'
6889       include 'COMMON.LOCAL'
6890       include 'COMMON.TORSION'
6891       include 'COMMON.INTERACT'
6892       include 'COMMON.DERIV'
6893       include 'COMMON.CHAIN'
6894       include 'COMMON.NAMES'
6895       include 'COMMON.IOUNITS'
6896       include 'COMMON.FFIELD'
6897       include 'COMMON.TORCNSTR'
6898       include 'COMMON.CONTROL'
6899       logical lprn
6900       double precision thybt1(maxang_kcc)
6901 C Set lprn=.true. for debugging
6902       lprn=energy_dec
6903 c     lprn=.true.
6904 C      print *,"wchodze kcc"
6905       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6906       etheta=0.0D0
6907       do i=ithet_start,ithet_end
6908 c        print *,i,itype(i-1),itype(i),itype(i-2)
6909         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6910      &  .or.itype(i).eq.ntyp1) cycle
6911         iti=iabs(itortyp(itype(i-1)))
6912         sinthet=dsin(theta(i))
6913         costhet=dcos(theta(i))
6914         do j=1,nbend_kcc_Tb(iti)
6915           thybt1(j)=v1bend_chyb(j,iti)
6916         enddo
6917         sumth1thyb=v1bend_chyb(0,iti)+
6918      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6919         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6920      &    sumth1thyb
6921         ihelp=nbend_kcc_Tb(iti)-1
6922         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6923         etheta=etheta+sumth1thyb
6924 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6925         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6926       enddo
6927       return
6928       end
6929 c-------------------------------------------------------------------------------------
6930       subroutine etheta_constr(ethetacnstr)
6931
6932       implicit real*8 (a-h,o-z)
6933       include 'DIMENSIONS'
6934       include 'DIMENSIONS.ZSCOPT'
6935       include 'COMMON.VAR'
6936       include 'COMMON.GEO'
6937       include 'COMMON.LOCAL'
6938       include 'COMMON.TORSION'
6939       include 'COMMON.INTERACT'
6940       include 'COMMON.DERIV'
6941       include 'COMMON.CHAIN'
6942       include 'COMMON.NAMES'
6943       include 'COMMON.IOUNITS'
6944       include 'COMMON.FFIELD'
6945       include 'COMMON.TORCNSTR'
6946       include 'COMMON.CONTROL'
6947       ethetacnstr=0.0d0
6948 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6949       do i=ithetaconstr_start,ithetaconstr_end
6950         itheta=itheta_constr(i)
6951         thetiii=theta(itheta)
6952         difi=pinorm(thetiii-theta_constr0(i))
6953         if (difi.gt.theta_drange(i)) then
6954           difi=difi-theta_drange(i)
6955           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6956           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6957      &    +for_thet_constr(i)*difi**3
6958         else if (difi.lt.-drange(i)) then
6959           difi=difi+drange(i)
6960           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6961           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6962      &    +for_thet_constr(i)*difi**3
6963         else
6964           difi=0.0
6965         endif
6966        if (energy_dec) then
6967         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6968      &    i,itheta,rad2deg*thetiii,
6969      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6970      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6971      &    gloc(itheta+nphi-2,icg)
6972         endif
6973       enddo
6974       return
6975       end
6976 c------------------------------------------------------------------------------
6977 c------------------------------------------------------------------------------
6978       subroutine eback_sc_corr(esccor)
6979 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6980 c        conformational states; temporarily implemented as differences
6981 c        between UNRES torsional potentials (dependent on three types of
6982 c        residues) and the torsional potentials dependent on all 20 types
6983 c        of residues computed from AM1 energy surfaces of terminally-blocked
6984 c        amino-acid residues.
6985       implicit real*8 (a-h,o-z)
6986       include 'DIMENSIONS'
6987       include 'DIMENSIONS.ZSCOPT'
6988       include 'COMMON.VAR'
6989       include 'COMMON.GEO'
6990       include 'COMMON.LOCAL'
6991       include 'COMMON.TORSION'
6992       include 'COMMON.SCCOR'
6993       include 'COMMON.INTERACT'
6994       include 'COMMON.DERIV'
6995       include 'COMMON.CHAIN'
6996       include 'COMMON.NAMES'
6997       include 'COMMON.IOUNITS'
6998       include 'COMMON.FFIELD'
6999       include 'COMMON.CONTROL'
7000       logical lprn
7001 C Set lprn=.true. for debugging
7002       lprn=.false.
7003 c      lprn=.true.
7004 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7005       esccor=0.0D0
7006       do i=itau_start,itau_end
7007         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7008         esccor_ii=0.0D0
7009         isccori=isccortyp(itype(i-2))
7010         isccori1=isccortyp(itype(i-1))
7011         phii=phi(i)
7012         do intertyp=1,3 !intertyp
7013 cc Added 09 May 2012 (Adasko)
7014 cc  Intertyp means interaction type of backbone mainchain correlation:
7015 c   1 = SC...Ca...Ca...Ca
7016 c   2 = Ca...Ca...Ca...SC
7017 c   3 = SC...Ca...Ca...SCi
7018         gloci=0.0D0
7019         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7020      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7021      &      (itype(i-1).eq.ntyp1)))
7022      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7023      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7024      &     .or.(itype(i).eq.ntyp1)))
7025      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7026      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7027      &      (itype(i-3).eq.ntyp1)))) cycle
7028         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7029         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7030      & cycle
7031        do j=1,nterm_sccor(isccori,isccori1)
7032           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7033           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7034           cosphi=dcos(j*tauangle(intertyp,i))
7035           sinphi=dsin(j*tauangle(intertyp,i))
7036            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7037            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7038          enddo
7039 C      write (iout,*)"EBACK_SC_COR",esccor,i
7040 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7041 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7042 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7043         if (lprn)
7044      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7045      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7046      &  (v1sccor(j,1,itori,itori1),j=1,6)
7047      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7048 c        gsccor_loc(i-3)=gloci
7049        enddo !intertyp
7050       enddo
7051       return
7052       end
7053 #ifdef FOURBODY
7054 c------------------------------------------------------------------------------
7055       subroutine multibody(ecorr)
7056 C This subroutine calculates multi-body contributions to energy following
7057 C the idea of Skolnick et al. If side chains I and J make a contact and
7058 C at the same time side chains I+1 and J+1 make a contact, an extra
7059 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7060       implicit real*8 (a-h,o-z)
7061       include 'DIMENSIONS'
7062       include 'COMMON.IOUNITS'
7063       include 'COMMON.DERIV'
7064       include 'COMMON.INTERACT'
7065       include 'COMMON.CONTACTS'
7066       include 'COMMON.CONTMAT'
7067       include 'COMMON.CORRMAT'
7068       double precision gx(3),gx1(3)
7069       logical lprn
7070
7071 C Set lprn=.true. for debugging
7072       lprn=.false.
7073
7074       if (lprn) then
7075         write (iout,'(a)') 'Contact function values:'
7076         do i=nnt,nct-2
7077           write (iout,'(i2,20(1x,i2,f10.5))')
7078      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7079         enddo
7080       endif
7081       ecorr=0.0D0
7082       do i=nnt,nct
7083         do j=1,3
7084           gradcorr(j,i)=0.0D0
7085           gradxorr(j,i)=0.0D0
7086         enddo
7087       enddo
7088       do i=nnt,nct-2
7089
7090         DO ISHIFT = 3,4
7091
7092         i1=i+ishift
7093         num_conti=num_cont(i)
7094         num_conti1=num_cont(i1)
7095         do jj=1,num_conti
7096           j=jcont(jj,i)
7097           do kk=1,num_conti1
7098             j1=jcont(kk,i1)
7099             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7100 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7101 cd   &                   ' ishift=',ishift
7102 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7103 C The system gains extra energy.
7104               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7105             endif   ! j1==j+-ishift
7106           enddo     ! kk
7107         enddo       ! jj
7108
7109         ENDDO ! ISHIFT
7110
7111       enddo         ! i
7112       return
7113       end
7114 c------------------------------------------------------------------------------
7115       double precision function esccorr(i,j,k,l,jj,kk)
7116       implicit real*8 (a-h,o-z)
7117       include 'DIMENSIONS'
7118       include 'COMMON.IOUNITS'
7119       include 'COMMON.DERIV'
7120       include 'COMMON.INTERACT'
7121       include 'COMMON.CONTACTS'
7122       include 'COMMON.CONTMAT'
7123       include 'COMMON.CORRMAT'
7124       double precision gx(3),gx1(3)
7125       logical lprn
7126       lprn=.false.
7127       eij=facont(jj,i)
7128       ekl=facont(kk,k)
7129 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7130 C Calculate the multi-body contribution to energy.
7131 C Calculate multi-body contributions to the gradient.
7132 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7133 cd   & k,l,(gacont(m,kk,k),m=1,3)
7134       do m=1,3
7135         gx(m) =ekl*gacont(m,jj,i)
7136         gx1(m)=eij*gacont(m,kk,k)
7137         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7138         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7139         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7140         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7141       enddo
7142       do m=i,j-1
7143         do ll=1,3
7144           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7145         enddo
7146       enddo
7147       do m=k,l-1
7148         do ll=1,3
7149           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7150         enddo
7151       enddo
7152       esccorr=-eij*ekl
7153       return
7154       end
7155 c------------------------------------------------------------------------------
7156       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7157 C This subroutine calculates multi-body contributions to hydrogen-bonding
7158       implicit real*8 (a-h,o-z)
7159       include 'DIMENSIONS'
7160       include 'DIMENSIONS.ZSCOPT'
7161       include 'COMMON.IOUNITS'
7162       include 'COMMON.FFIELD'
7163       include 'COMMON.DERIV'
7164       include 'COMMON.INTERACT'
7165       include 'COMMON.CONTACTS'
7166       include 'COMMON.CONTMAT'
7167       include 'COMMON.CORRMAT'
7168       double precision gx(3),gx1(3)
7169       logical lprn,ldone
7170
7171 C Set lprn=.true. for debugging
7172       lprn=.false.
7173       if (lprn) then
7174         write (iout,'(a)') 'Contact function values:'
7175         do i=nnt,nct-2
7176           write (iout,'(2i3,50(1x,i2,f5.2))')
7177      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7178      &    j=1,num_cont_hb(i))
7179         enddo
7180       endif
7181       ecorr=0.0D0
7182 C Remove the loop below after debugging !!!
7183       do i=nnt,nct
7184         do j=1,3
7185           gradcorr(j,i)=0.0D0
7186           gradxorr(j,i)=0.0D0
7187         enddo
7188       enddo
7189 C Calculate the local-electrostatic correlation terms
7190       do i=iatel_s,iatel_e+1
7191         i1=i+1
7192         num_conti=num_cont_hb(i)
7193         num_conti1=num_cont_hb(i+1)
7194         do jj=1,num_conti
7195           j=jcont_hb(jj,i)
7196           do kk=1,num_conti1
7197             j1=jcont_hb(kk,i1)
7198 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7199 c     &         ' jj=',jj,' kk=',kk
7200             if (j1.eq.j+1 .or. j1.eq.j-1) then
7201 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7202 C The system gains extra energy.
7203               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7204               n_corr=n_corr+1
7205             else if (j1.eq.j) then
7206 C Contacts I-J and I-(J+1) occur simultaneously.
7207 C The system loses extra energy.
7208 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7209             endif
7210           enddo ! kk
7211           do kk=1,num_conti
7212             j1=jcont_hb(kk,i)
7213 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7214 c    &         ' jj=',jj,' kk=',kk
7215             if (j1.eq.j+1) then
7216 C Contacts I-J and (I+1)-J occur simultaneously.
7217 C The system loses extra energy.
7218 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7219             endif ! j1==j+1
7220           enddo ! kk
7221         enddo ! jj
7222       enddo ! i
7223       return
7224       end
7225 c------------------------------------------------------------------------------
7226       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7227      &  n_corr1)
7228 C This subroutine calculates multi-body contributions to hydrogen-bonding
7229       implicit real*8 (a-h,o-z)
7230       include 'DIMENSIONS'
7231       include 'DIMENSIONS.ZSCOPT'
7232       include 'COMMON.IOUNITS'
7233 #ifdef MPI
7234       include "mpif.h"
7235 #endif
7236       include 'COMMON.FFIELD'
7237       include 'COMMON.DERIV'
7238       include 'COMMON.LOCAL'
7239       include 'COMMON.INTERACT'
7240       include 'COMMON.CONTACTS'
7241       include 'COMMON.CONTMAT'
7242       include 'COMMON.CORRMAT'
7243       include 'COMMON.CHAIN'
7244       include 'COMMON.CONTROL'
7245       include 'COMMON.SHIELD'
7246       double precision gx(3),gx1(3)
7247       integer num_cont_hb_old(maxres)
7248       logical lprn,ldone
7249       double precision eello4,eello5,eelo6,eello_turn6
7250       external eello4,eello5,eello6,eello_turn6
7251 C Set lprn=.true. for debugging
7252       lprn=.false.
7253       eturn6=0.0d0
7254       if (lprn) then
7255         write (iout,'(a)') 'Contact function values:'
7256         do i=nnt,nct-2
7257           write (iout,'(2i3,50(1x,i2,5f6.3))')
7258      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7259      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7260         enddo
7261       endif
7262       ecorr=0.0D0
7263       ecorr5=0.0d0
7264       ecorr6=0.0d0
7265 C Remove the loop below after debugging !!!
7266       do i=nnt,nct
7267         do j=1,3
7268           gradcorr(j,i)=0.0D0
7269           gradxorr(j,i)=0.0D0
7270         enddo
7271       enddo
7272 C Calculate the dipole-dipole interaction energies
7273       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7274       do i=iatel_s,iatel_e+1
7275         num_conti=num_cont_hb(i)
7276         do jj=1,num_conti
7277           j=jcont_hb(jj,i)
7278 #ifdef MOMENT
7279           call dipole(i,j,jj)
7280 #endif
7281         enddo
7282       enddo
7283       endif
7284 C Calculate the local-electrostatic correlation terms
7285 c                write (iout,*) "gradcorr5 in eello5 before loop"
7286 c                do iii=1,nres
7287 c                  write (iout,'(i5,3f10.5)')
7288 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7289 c                enddo
7290       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7291 c        write (iout,*) "corr loop i",i
7292         i1=i+1
7293         num_conti=num_cont_hb(i)
7294         num_conti1=num_cont_hb(i+1)
7295         do jj=1,num_conti
7296           j=jcont_hb(jj,i)
7297           jp=iabs(j)
7298           do kk=1,num_conti1
7299             j1=jcont_hb(kk,i1)
7300             jp1=iabs(j1)
7301 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7302 c     &         ' jj=',jj,' kk=',kk
7303 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7304             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7305      &          .or. j.lt.0 .and. j1.gt.0) .and.
7306      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7307 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7308 C The system gains extra energy.
7309               n_corr=n_corr+1
7310               sqd1=dsqrt(d_cont(jj,i))
7311               sqd2=dsqrt(d_cont(kk,i1))
7312               sred_geom = sqd1*sqd2
7313               IF (sred_geom.lt.cutoff_corr) THEN
7314                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7315      &            ekont,fprimcont)
7316 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7317 cd     &         ' jj=',jj,' kk=',kk
7318                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7319                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7320                 do l=1,3
7321                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7322                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7323                 enddo
7324                 n_corr1=n_corr1+1
7325 cd               write (iout,*) 'sred_geom=',sred_geom,
7326 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7327 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7328 cd               write (iout,*) "g_contij",g_contij
7329 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7330 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7331                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7332                 if (wcorr4.gt.0.0d0)
7333      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7334 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7335                   if (energy_dec.and.wcorr4.gt.0.0d0)
7336      1                 write (iout,'(a6,4i5,0pf7.3)')
7337      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7338 c                write (iout,*) "gradcorr5 before eello5"
7339 c                do iii=1,nres
7340 c                  write (iout,'(i5,3f10.5)')
7341 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7342 c                enddo
7343                 if (wcorr5.gt.0.0d0)
7344      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7345 c                write (iout,*) "gradcorr5 after eello5"
7346 c                do iii=1,nres
7347 c                  write (iout,'(i5,3f10.5)')
7348 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7349 c                enddo
7350                   if (energy_dec.and.wcorr5.gt.0.0d0)
7351      1                 write (iout,'(a6,4i5,0pf7.3)')
7352      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7353 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7354 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7355                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7356      &               .or. wturn6.eq.0.0d0))then
7357 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7358                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7359                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7360      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7361 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7362 cd     &            'ecorr6=',ecorr6
7363 cd                write (iout,'(4e15.5)') sred_geom,
7364 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7365 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7366 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7367                 else if (wturn6.gt.0.0d0
7368      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7369 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7370                   eturn6=eturn6+eello_turn6(i,jj,kk)
7371                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7372      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7373 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7374                 endif
7375               ENDIF
7376 1111          continue
7377             endif
7378           enddo ! kk
7379         enddo ! jj
7380       enddo ! i
7381       do i=1,nres
7382         num_cont_hb(i)=num_cont_hb_old(i)
7383       enddo
7384 c                write (iout,*) "gradcorr5 in eello5"
7385 c                do iii=1,nres
7386 c                  write (iout,'(i5,3f10.5)')
7387 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7388 c                enddo
7389       return
7390       end
7391 c------------------------------------------------------------------------------
7392       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7393       implicit real*8 (a-h,o-z)
7394       include 'DIMENSIONS'
7395       include 'DIMENSIONS.ZSCOPT'
7396       include 'COMMON.IOUNITS'
7397       include 'COMMON.DERIV'
7398       include 'COMMON.INTERACT'
7399       include 'COMMON.CONTACTS'
7400       include 'COMMON.CONTMAT'
7401       include 'COMMON.CORRMAT'
7402       include 'COMMON.SHIELD'
7403       include 'COMMON.CONTROL'
7404       double precision gx(3),gx1(3)
7405       logical lprn
7406       lprn=.false.
7407 C      print *,"wchodze",fac_shield(i),shield_mode
7408       eij=facont_hb(jj,i)
7409       ekl=facont_hb(kk,k)
7410       ees0pij=ees0p(jj,i)
7411       ees0pkl=ees0p(kk,k)
7412       ees0mij=ees0m(jj,i)
7413       ees0mkl=ees0m(kk,k)
7414       ekont=eij*ekl
7415       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7416 C*
7417 C     & fac_shield(i)**2*fac_shield(j)**2
7418 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7419 C Following 4 lines for diagnostics.
7420 cd    ees0pkl=0.0D0
7421 cd    ees0pij=1.0D0
7422 cd    ees0mkl=0.0D0
7423 cd    ees0mij=1.0D0
7424 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7425 c     & 'Contacts ',i,j,
7426 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7427 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7428 c     & 'gradcorr_long'
7429 C Calculate the multi-body contribution to energy.
7430 C      ecorr=ecorr+ekont*ees
7431 C Calculate multi-body contributions to the gradient.
7432       coeffpees0pij=coeffp*ees0pij
7433       coeffmees0mij=coeffm*ees0mij
7434       coeffpees0pkl=coeffp*ees0pkl
7435       coeffmees0mkl=coeffm*ees0mkl
7436       do ll=1,3
7437 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7438         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7439      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7440      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7441         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7442      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7443      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7444 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7445         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7446      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7447      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7448         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7449      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7450      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7451         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7452      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7453      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7454         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7455         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7456         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7457      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7458      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7459         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7460         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7461 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7462       enddo
7463 c      write (iout,*)
7464 cgrad      do m=i+1,j-1
7465 cgrad        do ll=1,3
7466 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7467 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7468 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7469 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7470 cgrad        enddo
7471 cgrad      enddo
7472 cgrad      do m=k+1,l-1
7473 cgrad        do ll=1,3
7474 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7475 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7476 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7477 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7478 cgrad        enddo
7479 cgrad      enddo
7480 c      write (iout,*) "ehbcorr",ekont*ees
7481 C      print *,ekont,ees,i,k
7482       ehbcorr=ekont*ees
7483 C now gradient over shielding
7484 C      return
7485       if (shield_mode.gt.0) then
7486        j=ees0plist(jj,i)
7487        l=ees0plist(kk,k)
7488 C        print *,i,j,fac_shield(i),fac_shield(j),
7489 C     &fac_shield(k),fac_shield(l)
7490         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7491      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7492           do ilist=1,ishield_list(i)
7493            iresshield=shield_list(ilist,i)
7494            do m=1,3
7495            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7496 C     &      *2.0
7497            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7498      &              rlocshield
7499      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7500             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7501      &+rlocshield
7502            enddo
7503           enddo
7504           do ilist=1,ishield_list(j)
7505            iresshield=shield_list(ilist,j)
7506            do m=1,3
7507            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7508 C     &     *2.0
7509            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7510      &              rlocshield
7511      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7512            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7513      &     +rlocshield
7514            enddo
7515           enddo
7516
7517           do ilist=1,ishield_list(k)
7518            iresshield=shield_list(ilist,k)
7519            do m=1,3
7520            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7521 C     &     *2.0
7522            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7523      &              rlocshield
7524      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7525            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7526      &     +rlocshield
7527            enddo
7528           enddo
7529           do ilist=1,ishield_list(l)
7530            iresshield=shield_list(ilist,l)
7531            do m=1,3
7532            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7533 C     &     *2.0
7534            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7535      &              rlocshield
7536      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7537            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7538      &     +rlocshield
7539            enddo
7540           enddo
7541 C          print *,gshieldx(m,iresshield)
7542           do m=1,3
7543             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7544      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7545             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7546      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7547             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7548      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7549             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7550      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7551
7552             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7553      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7554             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7555      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7556             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7557      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7558             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7559      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7560
7561            enddo
7562       endif
7563       endif
7564       return
7565       end
7566 #ifdef MOMENT
7567 C---------------------------------------------------------------------------
7568       subroutine dipole(i,j,jj)
7569       implicit real*8 (a-h,o-z)
7570       include 'DIMENSIONS'
7571       include 'DIMENSIONS.ZSCOPT'
7572       include 'COMMON.IOUNITS'
7573       include 'COMMON.CHAIN'
7574       include 'COMMON.FFIELD'
7575       include 'COMMON.DERIV'
7576       include 'COMMON.INTERACT'
7577       include 'COMMON.CONTACTS'
7578       include 'COMMON.CONTMAT'
7579       include 'COMMON.CORRMAT'
7580       include 'COMMON.TORSION'
7581       include 'COMMON.VAR'
7582       include 'COMMON.GEO'
7583       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7584      &  auxmat(2,2)
7585       iti1 = itortyp(itype(i+1))
7586       if (j.lt.nres-1) then
7587         itj1 = itype2loc(itype(j+1))
7588       else
7589         itj1=nloctyp
7590       endif
7591       do iii=1,2
7592         dipi(iii,1)=Ub2(iii,i)
7593         dipderi(iii)=Ub2der(iii,i)
7594         dipi(iii,2)=b1(iii,i+1)
7595         dipj(iii,1)=Ub2(iii,j)
7596         dipderj(iii)=Ub2der(iii,j)
7597         dipj(iii,2)=b1(iii,j+1)
7598       enddo
7599       kkk=0
7600       do iii=1,2
7601         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7602         do jjj=1,2
7603           kkk=kkk+1
7604           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7605         enddo
7606       enddo
7607       do kkk=1,5
7608         do lll=1,3
7609           mmm=0
7610           do iii=1,2
7611             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7612      &        auxvec(1))
7613             do jjj=1,2
7614               mmm=mmm+1
7615               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7616             enddo
7617           enddo
7618         enddo
7619       enddo
7620       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7621       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7622       do iii=1,2
7623         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7624       enddo
7625       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7626       do iii=1,2
7627         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7628       enddo
7629       return
7630       end
7631 #endif
7632 C---------------------------------------------------------------------------
7633       subroutine calc_eello(i,j,k,l,jj,kk)
7634 C
7635 C This subroutine computes matrices and vectors needed to calculate
7636 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7637 C
7638       implicit real*8 (a-h,o-z)
7639       include 'DIMENSIONS'
7640       include 'DIMENSIONS.ZSCOPT'
7641       include 'COMMON.IOUNITS'
7642       include 'COMMON.CHAIN'
7643       include 'COMMON.DERIV'
7644       include 'COMMON.INTERACT'
7645       include 'COMMON.CONTACTS'
7646       include 'COMMON.CONTMAT'
7647       include 'COMMON.CORRMAT'
7648       include 'COMMON.TORSION'
7649       include 'COMMON.VAR'
7650       include 'COMMON.GEO'
7651       include 'COMMON.FFIELD'
7652       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7653      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7654       logical lprn
7655       common /kutas/ lprn
7656 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7657 cd     & ' jj=',jj,' kk=',kk
7658 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7659 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7660 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7661       do iii=1,2
7662         do jjj=1,2
7663           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7664           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7665         enddo
7666       enddo
7667       call transpose2(aa1(1,1),aa1t(1,1))
7668       call transpose2(aa2(1,1),aa2t(1,1))
7669       do kkk=1,5
7670         do lll=1,3
7671           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7672      &      aa1tder(1,1,lll,kkk))
7673           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7674      &      aa2tder(1,1,lll,kkk))
7675         enddo
7676       enddo
7677       if (l.eq.j+1) then
7678 C parallel orientation of the two CA-CA-CA frames.
7679         if (i.gt.1) then
7680           iti=itype2loc(itype(i))
7681         else
7682           iti=nloctyp
7683         endif
7684         itk1=itype2loc(itype(k+1))
7685         itj=itype2loc(itype(j))
7686         if (l.lt.nres-1) then
7687           itl1=itype2loc(itype(l+1))
7688         else
7689           itl1=nloctyp
7690         endif
7691 C A1 kernel(j+1) A2T
7692 cd        do iii=1,2
7693 cd          write (iout,'(3f10.5,5x,3f10.5)')
7694 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7695 cd        enddo
7696         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7697      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7698      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7699 C Following matrices are needed only for 6-th order cumulants
7700         IF (wcorr6.gt.0.0d0) THEN
7701         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7702      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7703      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7704         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7705      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7706      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7707      &   ADtEAderx(1,1,1,1,1,1))
7708         lprn=.false.
7709         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7710      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7711      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7712      &   ADtEA1derx(1,1,1,1,1,1))
7713         ENDIF
7714 C End 6-th order cumulants
7715 cd        lprn=.false.
7716 cd        if (lprn) then
7717 cd        write (2,*) 'In calc_eello6'
7718 cd        do iii=1,2
7719 cd          write (2,*) 'iii=',iii
7720 cd          do kkk=1,5
7721 cd            write (2,*) 'kkk=',kkk
7722 cd            do jjj=1,2
7723 cd              write (2,'(3(2f10.5),5x)')
7724 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7725 cd            enddo
7726 cd          enddo
7727 cd        enddo
7728 cd        endif
7729         call transpose2(EUgder(1,1,k),auxmat(1,1))
7730         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7731         call transpose2(EUg(1,1,k),auxmat(1,1))
7732         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7733         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7734         do iii=1,2
7735           do kkk=1,5
7736             do lll=1,3
7737               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7738      &          EAEAderx(1,1,lll,kkk,iii,1))
7739             enddo
7740           enddo
7741         enddo
7742 C A1T kernel(i+1) A2
7743         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7744      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7745      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7746 C Following matrices are needed only for 6-th order cumulants
7747         IF (wcorr6.gt.0.0d0) THEN
7748         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7749      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7750      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7751         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7752      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7753      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7754      &   ADtEAderx(1,1,1,1,1,2))
7755         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7756      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7757      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7758      &   ADtEA1derx(1,1,1,1,1,2))
7759         ENDIF
7760 C End 6-th order cumulants
7761         call transpose2(EUgder(1,1,l),auxmat(1,1))
7762         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7763         call transpose2(EUg(1,1,l),auxmat(1,1))
7764         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7765         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7766         do iii=1,2
7767           do kkk=1,5
7768             do lll=1,3
7769               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7770      &          EAEAderx(1,1,lll,kkk,iii,2))
7771             enddo
7772           enddo
7773         enddo
7774 C AEAb1 and AEAb2
7775 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7776 C They are needed only when the fifth- or the sixth-order cumulants are
7777 C indluded.
7778         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7779         call transpose2(AEA(1,1,1),auxmat(1,1))
7780         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7781         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7782         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7783         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7784         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7785         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7786         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7787         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7788         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7789         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7790         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7791         call transpose2(AEA(1,1,2),auxmat(1,1))
7792         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7793         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7794         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7795         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7796         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7797         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7798         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7799         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7800         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7801         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7802         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7803 C Calculate the Cartesian derivatives of the vectors.
7804         do iii=1,2
7805           do kkk=1,5
7806             do lll=1,3
7807               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7808               call matvec2(auxmat(1,1),b1(1,i),
7809      &          AEAb1derx(1,lll,kkk,iii,1,1))
7810               call matvec2(auxmat(1,1),Ub2(1,i),
7811      &          AEAb2derx(1,lll,kkk,iii,1,1))
7812               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7813      &          AEAb1derx(1,lll,kkk,iii,2,1))
7814               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7815      &          AEAb2derx(1,lll,kkk,iii,2,1))
7816               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7817               call matvec2(auxmat(1,1),b1(1,j),
7818      &          AEAb1derx(1,lll,kkk,iii,1,2))
7819               call matvec2(auxmat(1,1),Ub2(1,j),
7820      &          AEAb2derx(1,lll,kkk,iii,1,2))
7821               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7822      &          AEAb1derx(1,lll,kkk,iii,2,2))
7823               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7824      &          AEAb2derx(1,lll,kkk,iii,2,2))
7825             enddo
7826           enddo
7827         enddo
7828         ENDIF
7829 C End vectors
7830       else
7831 C Antiparallel orientation of the two CA-CA-CA frames.
7832         if (i.gt.1) then
7833           iti=itype2loc(itype(i))
7834         else
7835           iti=nloctyp
7836         endif
7837         itk1=itype2loc(itype(k+1))
7838         itl=itype2loc(itype(l))
7839         itj=itype2loc(itype(j))
7840         if (j.lt.nres-1) then
7841           itj1=itype2loc(itype(j+1))
7842         else
7843           itj1=nloctyp
7844         endif
7845 C A2 kernel(j-1)T A1T
7846         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7847      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7848      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7849 C Following matrices are needed only for 6-th order cumulants
7850         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7851      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7852         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7853      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7854      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7855         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7856      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7857      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7858      &   ADtEAderx(1,1,1,1,1,1))
7859         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7860      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7861      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7862      &   ADtEA1derx(1,1,1,1,1,1))
7863         ENDIF
7864 C End 6-th order cumulants
7865         call transpose2(EUgder(1,1,k),auxmat(1,1))
7866         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7867         call transpose2(EUg(1,1,k),auxmat(1,1))
7868         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7869         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7870         do iii=1,2
7871           do kkk=1,5
7872             do lll=1,3
7873               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7874      &          EAEAderx(1,1,lll,kkk,iii,1))
7875             enddo
7876           enddo
7877         enddo
7878 C A2T kernel(i+1)T A1
7879         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7880      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7881      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7882 C Following matrices are needed only for 6-th order cumulants
7883         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7884      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7885         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7886      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7887      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7888         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7889      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7890      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7891      &   ADtEAderx(1,1,1,1,1,2))
7892         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7893      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7894      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7895      &   ADtEA1derx(1,1,1,1,1,2))
7896         ENDIF
7897 C End 6-th order cumulants
7898         call transpose2(EUgder(1,1,j),auxmat(1,1))
7899         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7900         call transpose2(EUg(1,1,j),auxmat(1,1))
7901         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7902         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7903         do iii=1,2
7904           do kkk=1,5
7905             do lll=1,3
7906               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7907      &          EAEAderx(1,1,lll,kkk,iii,2))
7908             enddo
7909           enddo
7910         enddo
7911 C AEAb1 and AEAb2
7912 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7913 C They are needed only when the fifth- or the sixth-order cumulants are
7914 C indluded.
7915         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7916      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7917         call transpose2(AEA(1,1,1),auxmat(1,1))
7918         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7919         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7920         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7921         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7922         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7923         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7924         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7925         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7926         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7927         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7928         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7929         call transpose2(AEA(1,1,2),auxmat(1,1))
7930         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7931         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7932         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7933         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7934         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7935         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7936         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7937         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7938         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7939         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7940         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7941 C Calculate the Cartesian derivatives of the vectors.
7942         do iii=1,2
7943           do kkk=1,5
7944             do lll=1,3
7945               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7946               call matvec2(auxmat(1,1),b1(1,i),
7947      &          AEAb1derx(1,lll,kkk,iii,1,1))
7948               call matvec2(auxmat(1,1),Ub2(1,i),
7949      &          AEAb2derx(1,lll,kkk,iii,1,1))
7950               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7951      &          AEAb1derx(1,lll,kkk,iii,2,1))
7952               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7953      &          AEAb2derx(1,lll,kkk,iii,2,1))
7954               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7955               call matvec2(auxmat(1,1),b1(1,l),
7956      &          AEAb1derx(1,lll,kkk,iii,1,2))
7957               call matvec2(auxmat(1,1),Ub2(1,l),
7958      &          AEAb2derx(1,lll,kkk,iii,1,2))
7959               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7960      &          AEAb1derx(1,lll,kkk,iii,2,2))
7961               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7962      &          AEAb2derx(1,lll,kkk,iii,2,2))
7963             enddo
7964           enddo
7965         enddo
7966         ENDIF
7967 C End vectors
7968       endif
7969       return
7970       end
7971 C---------------------------------------------------------------------------
7972       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7973      &  KK,KKderg,AKA,AKAderg,AKAderx)
7974       implicit none
7975       integer nderg
7976       logical transp
7977       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7978      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7979      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7980       integer iii,kkk,lll
7981       integer jjj,mmm
7982       logical lprn
7983       common /kutas/ lprn
7984       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7985       do iii=1,nderg
7986         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7987      &    AKAderg(1,1,iii))
7988       enddo
7989 cd      if (lprn) write (2,*) 'In kernel'
7990       do kkk=1,5
7991 cd        if (lprn) write (2,*) 'kkk=',kkk
7992         do lll=1,3
7993           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7994      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7995 cd          if (lprn) then
7996 cd            write (2,*) 'lll=',lll
7997 cd            write (2,*) 'iii=1'
7998 cd            do jjj=1,2
7999 cd              write (2,'(3(2f10.5),5x)')
8000 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8001 cd            enddo
8002 cd          endif
8003           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8004      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8005 cd          if (lprn) then
8006 cd            write (2,*) 'lll=',lll
8007 cd            write (2,*) 'iii=2'
8008 cd            do jjj=1,2
8009 cd              write (2,'(3(2f10.5),5x)')
8010 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8011 cd            enddo
8012 cd          endif
8013         enddo
8014       enddo
8015       return
8016       end
8017 C---------------------------------------------------------------------------
8018       double precision function eello4(i,j,k,l,jj,kk)
8019       implicit real*8 (a-h,o-z)
8020       include 'DIMENSIONS'
8021       include 'DIMENSIONS.ZSCOPT'
8022       include 'COMMON.IOUNITS'
8023       include 'COMMON.CHAIN'
8024       include 'COMMON.DERIV'
8025       include 'COMMON.INTERACT'
8026       include 'COMMON.CONTACTS'
8027       include 'COMMON.CONTMAT'
8028       include 'COMMON.CORRMAT'
8029       include 'COMMON.TORSION'
8030       include 'COMMON.VAR'
8031       include 'COMMON.GEO'
8032       double precision pizda(2,2),ggg1(3),ggg2(3)
8033 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8034 cd        eello4=0.0d0
8035 cd        return
8036 cd      endif
8037 cd      print *,'eello4:',i,j,k,l,jj,kk
8038 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8039 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8040 cold      eij=facont_hb(jj,i)
8041 cold      ekl=facont_hb(kk,k)
8042 cold      ekont=eij*ekl
8043       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8044       if (calc_grad) then
8045 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8046       gcorr_loc(k-1)=gcorr_loc(k-1)
8047      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8048       if (l.eq.j+1) then
8049         gcorr_loc(l-1)=gcorr_loc(l-1)
8050      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8051       else
8052         gcorr_loc(j-1)=gcorr_loc(j-1)
8053      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8054       endif
8055       do iii=1,2
8056         do kkk=1,5
8057           do lll=1,3
8058             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8059      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8060 cd            derx(lll,kkk,iii)=0.0d0
8061           enddo
8062         enddo
8063       enddo
8064 cd      gcorr_loc(l-1)=0.0d0
8065 cd      gcorr_loc(j-1)=0.0d0
8066 cd      gcorr_loc(k-1)=0.0d0
8067 cd      eel4=1.0d0
8068 cd      write (iout,*)'Contacts have occurred for peptide groups',
8069 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8070 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8071       if (j.lt.nres-1) then
8072         j1=j+1
8073         j2=j-1
8074       else
8075         j1=j-1
8076         j2=j-2
8077       endif
8078       if (l.lt.nres-1) then
8079         l1=l+1
8080         l2=l-1
8081       else
8082         l1=l-1
8083         l2=l-2
8084       endif
8085       do ll=1,3
8086 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8087 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8088         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8089         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8090 cgrad        ghalf=0.5d0*ggg1(ll)
8091         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8092         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8093         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8094         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8095         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8096         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8097 cgrad        ghalf=0.5d0*ggg2(ll)
8098         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8099         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8100         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8101         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8102         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8103         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8104       enddo
8105 cgrad      do m=i+1,j-1
8106 cgrad        do ll=1,3
8107 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cgrad      do m=k+1,l-1
8111 cgrad        do ll=1,3
8112 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8113 cgrad        enddo
8114 cgrad      enddo
8115 cgrad      do m=i+2,j2
8116 cgrad        do ll=1,3
8117 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8118 cgrad        enddo
8119 cgrad      enddo
8120 cgrad      do m=k+2,l2
8121 cgrad        do ll=1,3
8122 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8123 cgrad        enddo
8124 cgrad      enddo
8125 cd      do iii=1,nres-3
8126 cd        write (2,*) iii,gcorr_loc(iii)
8127 cd      enddo
8128       endif ! calc_grad
8129       eello4=ekont*eel4
8130 cd      write (2,*) 'ekont',ekont
8131 cd      write (iout,*) 'eello4',ekont*eel4
8132       return
8133       end
8134 C---------------------------------------------------------------------------
8135       double precision function eello5(i,j,k,l,jj,kk)
8136       implicit real*8 (a-h,o-z)
8137       include 'DIMENSIONS'
8138       include 'DIMENSIONS.ZSCOPT'
8139       include 'COMMON.IOUNITS'
8140       include 'COMMON.CHAIN'
8141       include 'COMMON.DERIV'
8142       include 'COMMON.INTERACT'
8143       include 'COMMON.CONTACTS'
8144       include 'COMMON.CONTMAT'
8145       include 'COMMON.CORRMAT'
8146       include 'COMMON.TORSION'
8147       include 'COMMON.VAR'
8148       include 'COMMON.GEO'
8149       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8150       double precision ggg1(3),ggg2(3)
8151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8152 C                                                                              C
8153 C                            Parallel chains                                   C
8154 C                                                                              C
8155 C          o             o                   o             o                   C
8156 C         /l\           / \             \   / \           / \   /              C
8157 C        /   \         /   \             \ /   \         /   \ /               C
8158 C       j| o |l1       | o |              o| o |         | o |o                C
8159 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8160 C      \i/   \         /   \ /             /   \         /   \                 C
8161 C       o    k1             o                                                  C
8162 C         (I)          (II)                (III)          (IV)                 C
8163 C                                                                              C
8164 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8165 C                                                                              C
8166 C                            Antiparallel chains                               C
8167 C                                                                              C
8168 C          o             o                   o             o                   C
8169 C         /j\           / \             \   / \           / \   /              C
8170 C        /   \         /   \             \ /   \         /   \ /               C
8171 C      j1| o |l        | o |              o| o |         | o |o                C
8172 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8173 C      \i/   \         /   \ /             /   \         /   \                 C
8174 C       o     k1            o                                                  C
8175 C         (I)          (II)                (III)          (IV)                 C
8176 C                                                                              C
8177 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8178 C                                                                              C
8179 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8180 C                                                                              C
8181 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8182 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8183 cd        eello5=0.0d0
8184 cd        return
8185 cd      endif
8186 cd      write (iout,*)
8187 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8188 cd     &   ' and',k,l
8189       itk=itype2loc(itype(k))
8190       itl=itype2loc(itype(l))
8191       itj=itype2loc(itype(j))
8192       eello5_1=0.0d0
8193       eello5_2=0.0d0
8194       eello5_3=0.0d0
8195       eello5_4=0.0d0
8196 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8197 cd     &   eel5_3_num,eel5_4_num)
8198       do iii=1,2
8199         do kkk=1,5
8200           do lll=1,3
8201             derx(lll,kkk,iii)=0.0d0
8202           enddo
8203         enddo
8204       enddo
8205 cd      eij=facont_hb(jj,i)
8206 cd      ekl=facont_hb(kk,k)
8207 cd      ekont=eij*ekl
8208 cd      write (iout,*)'Contacts have occurred for peptide groups',
8209 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8210 cd      goto 1111
8211 C Contribution from the graph I.
8212 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8213 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8214       call transpose2(EUg(1,1,k),auxmat(1,1))
8215       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8216       vv(1)=pizda(1,1)-pizda(2,2)
8217       vv(2)=pizda(1,2)+pizda(2,1)
8218       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8219      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8220       if (calc_grad) then
8221 C Explicit gradient in virtual-dihedral angles.
8222       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8223      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8224      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8225       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8226       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8227       vv(1)=pizda(1,1)-pizda(2,2)
8228       vv(2)=pizda(1,2)+pizda(2,1)
8229       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8230      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8231      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8232       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8233       vv(1)=pizda(1,1)-pizda(2,2)
8234       vv(2)=pizda(1,2)+pizda(2,1)
8235       if (l.eq.j+1) then
8236         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8237      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8238      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8239       else
8240         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8241      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8242      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8243       endif
8244 C Cartesian gradient
8245       do iii=1,2
8246         do kkk=1,5
8247           do lll=1,3
8248             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8249      &        pizda(1,1))
8250             vv(1)=pizda(1,1)-pizda(2,2)
8251             vv(2)=pizda(1,2)+pizda(2,1)
8252             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8253      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8254      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8255           enddo
8256         enddo
8257       enddo
8258       endif ! calc_grad
8259 c      goto 1112
8260 c1111  continue
8261 C Contribution from graph II
8262       call transpose2(EE(1,1,k),auxmat(1,1))
8263       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8264       vv(1)=pizda(1,1)+pizda(2,2)
8265       vv(2)=pizda(2,1)-pizda(1,2)
8266       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8267      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8268       if (calc_grad) then
8269 C Explicit gradient in virtual-dihedral angles.
8270       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8271      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8272       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8273       vv(1)=pizda(1,1)+pizda(2,2)
8274       vv(2)=pizda(2,1)-pizda(1,2)
8275       if (l.eq.j+1) then
8276         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8277      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8278      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8279       else
8280         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8281      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8282      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8283       endif
8284 C Cartesian gradient
8285       do iii=1,2
8286         do kkk=1,5
8287           do lll=1,3
8288             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8289      &        pizda(1,1))
8290             vv(1)=pizda(1,1)+pizda(2,2)
8291             vv(2)=pizda(2,1)-pizda(1,2)
8292             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8293      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8294      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8295           enddo
8296         enddo
8297       enddo
8298       endif ! calc_grad
8299 cd      goto 1112
8300 cd1111  continue
8301       if (l.eq.j+1) then
8302 cd        goto 1110
8303 C Parallel orientation
8304 C Contribution from graph III
8305         call transpose2(EUg(1,1,l),auxmat(1,1))
8306         call matmat2(AEA(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         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8310      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8311         if (calc_grad) then
8312 C Explicit gradient in virtual-dihedral angles.
8313         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8314      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8315      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8316         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8317         vv(1)=pizda(1,1)-pizda(2,2)
8318         vv(2)=pizda(1,2)+pizda(2,1)
8319         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8320      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8321      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8322         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8323         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8324         vv(1)=pizda(1,1)-pizda(2,2)
8325         vv(2)=pizda(1,2)+pizda(2,1)
8326         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8327      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8328      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8329 C Cartesian gradient
8330         do iii=1,2
8331           do kkk=1,5
8332             do lll=1,3
8333               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8334      &          pizda(1,1))
8335               vv(1)=pizda(1,1)-pizda(2,2)
8336               vv(2)=pizda(1,2)+pizda(2,1)
8337               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8338      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8339      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8340             enddo
8341           enddo
8342         enddo
8343 cd        goto 1112
8344 C Contribution from graph IV
8345 cd1110    continue
8346         call transpose2(EE(1,1,l),auxmat(1,1))
8347         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8348         vv(1)=pizda(1,1)+pizda(2,2)
8349         vv(2)=pizda(2,1)-pizda(1,2)
8350         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8351      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8352 C Explicit gradient in virtual-dihedral angles.
8353         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8354      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8355         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8356         vv(1)=pizda(1,1)+pizda(2,2)
8357         vv(2)=pizda(2,1)-pizda(1,2)
8358         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8359      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8360      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8361 C Cartesian gradient
8362         do iii=1,2
8363           do kkk=1,5
8364             do lll=1,3
8365               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8366      &          pizda(1,1))
8367               vv(1)=pizda(1,1)+pizda(2,2)
8368               vv(2)=pizda(2,1)-pizda(1,2)
8369               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8370      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8371      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8372             enddo
8373           enddo
8374         enddo
8375         endif ! calc_grad
8376       else
8377 C Antiparallel orientation
8378 C Contribution from graph III
8379 c        goto 1110
8380         call transpose2(EUg(1,1,j),auxmat(1,1))
8381         call matmat2(AEA(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         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8385      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8386         if (calc_grad) then
8387 C Explicit gradient in virtual-dihedral angles.
8388         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8389      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8390      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8391         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8392         vv(1)=pizda(1,1)-pizda(2,2)
8393         vv(2)=pizda(1,2)+pizda(2,1)
8394         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8395      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8396      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8397         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8398         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8399         vv(1)=pizda(1,1)-pizda(2,2)
8400         vv(2)=pizda(1,2)+pizda(2,1)
8401         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8402      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8403      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8404 C Cartesian gradient
8405         do iii=1,2
8406           do kkk=1,5
8407             do lll=1,3
8408               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8409      &          pizda(1,1))
8410               vv(1)=pizda(1,1)-pizda(2,2)
8411               vv(2)=pizda(1,2)+pizda(2,1)
8412               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8413      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8414      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8415             enddo
8416           enddo
8417         enddo
8418         endif ! calc_grad
8419 cd        goto 1112
8420 C Contribution from graph IV
8421 1110    continue
8422         call transpose2(EE(1,1,j),auxmat(1,1))
8423         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8424         vv(1)=pizda(1,1)+pizda(2,2)
8425         vv(2)=pizda(2,1)-pizda(1,2)
8426         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8427      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8428         if (calc_grad) then
8429 C Explicit gradient in virtual-dihedral angles.
8430         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8431      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8432         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8433         vv(1)=pizda(1,1)+pizda(2,2)
8434         vv(2)=pizda(2,1)-pizda(1,2)
8435         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8436      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8437      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8438 C Cartesian gradient
8439         do iii=1,2
8440           do kkk=1,5
8441             do lll=1,3
8442               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8443      &          pizda(1,1))
8444               vv(1)=pizda(1,1)+pizda(2,2)
8445               vv(2)=pizda(2,1)-pizda(1,2)
8446               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8447      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8448      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8449             enddo
8450           enddo
8451         enddo
8452         endif ! calc_grad
8453       endif
8454 1112  continue
8455       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8456 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8457 cd        write (2,*) 'ijkl',i,j,k,l
8458 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8459 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8460 cd      endif
8461 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8462 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8463 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8464 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8465       if (calc_grad) then
8466       if (j.lt.nres-1) then
8467         j1=j+1
8468         j2=j-1
8469       else
8470         j1=j-1
8471         j2=j-2
8472       endif
8473       if (l.lt.nres-1) then
8474         l1=l+1
8475         l2=l-1
8476       else
8477         l1=l-1
8478         l2=l-2
8479       endif
8480 cd      eij=1.0d0
8481 cd      ekl=1.0d0
8482 cd      ekont=1.0d0
8483 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8484 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8485 C        summed up outside the subrouine as for the other subroutines
8486 C        handling long-range interactions. The old code is commented out
8487 C        with "cgrad" to keep track of changes.
8488       do ll=1,3
8489 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8490 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8491         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8492         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8493 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8494 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8495 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8496 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8497 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8498 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8499 c     &   gradcorr5ij,
8500 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8501 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8502 cgrad        ghalf=0.5d0*ggg1(ll)
8503 cd        ghalf=0.0d0
8504         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8505         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8506         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8507         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8508         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8509         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8510 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8511 cgrad        ghalf=0.5d0*ggg2(ll)
8512 cd        ghalf=0.0d0
8513         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8514         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8515         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8516         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8517         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8518         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8519       enddo
8520       endif ! calc_grad
8521 cd      goto 1112
8522 cgrad      do m=i+1,j-1
8523 cgrad        do ll=1,3
8524 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8525 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8526 cgrad        enddo
8527 cgrad      enddo
8528 cgrad      do m=k+1,l-1
8529 cgrad        do ll=1,3
8530 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8531 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8532 cgrad        enddo
8533 cgrad      enddo
8534 c1112  continue
8535 cgrad      do m=i+2,j2
8536 cgrad        do ll=1,3
8537 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8538 cgrad        enddo
8539 cgrad      enddo
8540 cgrad      do m=k+2,l2
8541 cgrad        do ll=1,3
8542 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8543 cgrad        enddo
8544 cgrad      enddo
8545 cd      do iii=1,nres-3
8546 cd        write (2,*) iii,g_corr5_loc(iii)
8547 cd      enddo
8548       eello5=ekont*eel5
8549 cd      write (2,*) 'ekont',ekont
8550 cd      write (iout,*) 'eello5',ekont*eel5
8551       return
8552       end
8553 c--------------------------------------------------------------------------
8554       double precision function eello6(i,j,k,l,jj,kk)
8555       implicit real*8 (a-h,o-z)
8556       include 'DIMENSIONS'
8557       include 'DIMENSIONS.ZSCOPT'
8558       include 'COMMON.IOUNITS'
8559       include 'COMMON.CHAIN'
8560       include 'COMMON.DERIV'
8561       include 'COMMON.INTERACT'
8562       include 'COMMON.CONTACTS'
8563       include 'COMMON.CONTMAT'
8564       include 'COMMON.CORRMAT'
8565       include 'COMMON.TORSION'
8566       include 'COMMON.VAR'
8567       include 'COMMON.GEO'
8568       include 'COMMON.FFIELD'
8569       double precision ggg1(3),ggg2(3)
8570 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8571 cd        eello6=0.0d0
8572 cd        return
8573 cd      endif
8574 cd      write (iout,*)
8575 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8576 cd     &   ' and',k,l
8577       eello6_1=0.0d0
8578       eello6_2=0.0d0
8579       eello6_3=0.0d0
8580       eello6_4=0.0d0
8581       eello6_5=0.0d0
8582       eello6_6=0.0d0
8583 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8584 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8585       do iii=1,2
8586         do kkk=1,5
8587           do lll=1,3
8588             derx(lll,kkk,iii)=0.0d0
8589           enddo
8590         enddo
8591       enddo
8592 cd      eij=facont_hb(jj,i)
8593 cd      ekl=facont_hb(kk,k)
8594 cd      ekont=eij*ekl
8595 cd      eij=1.0d0
8596 cd      ekl=1.0d0
8597 cd      ekont=1.0d0
8598       if (l.eq.j+1) then
8599         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8600         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8601         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8602         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8603         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8604         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8605       else
8606         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8607         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8608         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8609         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8610         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8611           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8612         else
8613           eello6_5=0.0d0
8614         endif
8615         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8616       endif
8617 C If turn contributions are considered, they will be handled separately.
8618       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8619 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8620 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8621 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8622 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8623 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8624 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8625 cd      goto 1112
8626       if (calc_grad) then
8627       if (j.lt.nres-1) then
8628         j1=j+1
8629         j2=j-1
8630       else
8631         j1=j-1
8632         j2=j-2
8633       endif
8634       if (l.lt.nres-1) then
8635         l1=l+1
8636         l2=l-1
8637       else
8638         l1=l-1
8639         l2=l-2
8640       endif
8641       do ll=1,3
8642 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8643 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8644 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8645 cgrad        ghalf=0.5d0*ggg1(ll)
8646 cd        ghalf=0.0d0
8647         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8648         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8649         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8650         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8651         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8652         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8653         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8654         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8655 cgrad        ghalf=0.5d0*ggg2(ll)
8656 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8657 cd        ghalf=0.0d0
8658         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8659         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8660         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8661         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8662         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8663         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8664       enddo
8665       endif ! calc_grad
8666 cd      goto 1112
8667 cgrad      do m=i+1,j-1
8668 cgrad        do ll=1,3
8669 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8670 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8671 cgrad        enddo
8672 cgrad      enddo
8673 cgrad      do m=k+1,l-1
8674 cgrad        do ll=1,3
8675 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8676 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8677 cgrad        enddo
8678 cgrad      enddo
8679 cgrad1112  continue
8680 cgrad      do m=i+2,j2
8681 cgrad        do ll=1,3
8682 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8683 cgrad        enddo
8684 cgrad      enddo
8685 cgrad      do m=k+2,l2
8686 cgrad        do ll=1,3
8687 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8688 cgrad        enddo
8689 cgrad      enddo
8690 cd      do iii=1,nres-3
8691 cd        write (2,*) iii,g_corr6_loc(iii)
8692 cd      enddo
8693       eello6=ekont*eel6
8694 cd      write (2,*) 'ekont',ekont
8695 cd      write (iout,*) 'eello6',ekont*eel6
8696       return
8697       end
8698 c--------------------------------------------------------------------------
8699       double precision function eello6_graph1(i,j,k,l,imat,swap)
8700       implicit real*8 (a-h,o-z)
8701       include 'DIMENSIONS'
8702       include 'DIMENSIONS.ZSCOPT'
8703       include 'COMMON.IOUNITS'
8704       include 'COMMON.CHAIN'
8705       include 'COMMON.DERIV'
8706       include 'COMMON.INTERACT'
8707       include 'COMMON.CONTACTS'
8708       include 'COMMON.CONTMAT'
8709       include 'COMMON.CORRMAT'
8710       include 'COMMON.TORSION'
8711       include 'COMMON.VAR'
8712       include 'COMMON.GEO'
8713       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8714       logical swap
8715       logical lprn
8716       common /kutas/ lprn
8717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8718 C                                                                              C
8719 C      Parallel       Antiparallel                                             C
8720 C                                                                              C
8721 C          o             o                                                     C
8722 C         /l\           /j\                                                    C
8723 C        /   \         /   \                                                   C
8724 C       /| o |         | o |\                                                  C
8725 C     \ j|/k\|  /   \  |/k\|l /                                                C
8726 C      \ /   \ /     \ /   \ /                                                 C
8727 C       o     o       o     o                                                  C
8728 C       i             i                                                        C
8729 C                                                                              C
8730 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8731       itk=itype2loc(itype(k))
8732       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8733       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8734       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8735       call transpose2(EUgC(1,1,k),auxmat(1,1))
8736       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8737       vv1(1)=pizda1(1,1)-pizda1(2,2)
8738       vv1(2)=pizda1(1,2)+pizda1(2,1)
8739       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8740       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8741       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8742       s5=scalar2(vv(1),Dtobr2(1,i))
8743 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8744       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8745       if (calc_grad) then
8746       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8747      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8748      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8749      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8750      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8751      & +scalar2(vv(1),Dtobr2der(1,i)))
8752       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8753       vv1(1)=pizda1(1,1)-pizda1(2,2)
8754       vv1(2)=pizda1(1,2)+pizda1(2,1)
8755       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8756       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8757       if (l.eq.j+1) then
8758         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8759      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8760      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8761      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8762      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8763       else
8764         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8765      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8766      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8767      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8768      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8769       endif
8770       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8771       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8772       vv1(1)=pizda1(1,1)-pizda1(2,2)
8773       vv1(2)=pizda1(1,2)+pizda1(2,1)
8774       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8775      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8776      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8777      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8778       do iii=1,2
8779         if (swap) then
8780           ind=3-iii
8781         else
8782           ind=iii
8783         endif
8784         do kkk=1,5
8785           do lll=1,3
8786             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8787             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8788             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8789             call transpose2(EUgC(1,1,k),auxmat(1,1))
8790             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8791      &        pizda1(1,1))
8792             vv1(1)=pizda1(1,1)-pizda1(2,2)
8793             vv1(2)=pizda1(1,2)+pizda1(2,1)
8794             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8795             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8796      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8797             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8798      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8799             s5=scalar2(vv(1),Dtobr2(1,i))
8800             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8801           enddo
8802         enddo
8803       enddo
8804       endif ! calc_grad
8805       return
8806       end
8807 c----------------------------------------------------------------------------
8808       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8809       implicit real*8 (a-h,o-z)
8810       include 'DIMENSIONS'
8811       include 'DIMENSIONS.ZSCOPT'
8812       include 'COMMON.IOUNITS'
8813       include 'COMMON.CHAIN'
8814       include 'COMMON.DERIV'
8815       include 'COMMON.INTERACT'
8816       include 'COMMON.CONTACTS'
8817       include 'COMMON.CONTMAT'
8818       include 'COMMON.CORRMAT'
8819       include 'COMMON.TORSION'
8820       include 'COMMON.VAR'
8821       include 'COMMON.GEO'
8822       logical swap
8823       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8824      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8825       logical lprn
8826       common /kutas/ lprn
8827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8828 C                                                                              C
8829 C      Parallel       Antiparallel                                             C
8830 C                                                                              C
8831 C          o             o                                                     C
8832 C     \   /l\           /j\   /                                                C
8833 C      \ /   \         /   \ /                                                 C
8834 C       o| o |         | o |o                                                  C
8835 C     \ j|/k\|      \  |/k\|l                                                  C
8836 C      \ /   \       \ /   \                                                   C
8837 C       o             o                                                        C
8838 C       i             i                                                        C
8839 C                                                                              C
8840 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8841 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8842 C AL 7/4/01 s1 would occur in the sixth-order moment,
8843 C           but not in a cluster cumulant
8844 #ifdef MOMENT
8845       s1=dip(1,jj,i)*dip(1,kk,k)
8846 #endif
8847       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8848       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8849       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8850       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8851       call transpose2(EUg(1,1,k),auxmat(1,1))
8852       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8853       vv(1)=pizda(1,1)-pizda(2,2)
8854       vv(2)=pizda(1,2)+pizda(2,1)
8855       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8856 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8857 #ifdef MOMENT
8858       eello6_graph2=-(s1+s2+s3+s4)
8859 #else
8860       eello6_graph2=-(s2+s3+s4)
8861 #endif
8862 c      eello6_graph2=-s3
8863 C Derivatives in gamma(i-1)
8864       if (calc_grad) then
8865       if (i.gt.1) then
8866 #ifdef MOMENT
8867         s1=dipderg(1,jj,i)*dip(1,kk,k)
8868 #endif
8869         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8870         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8871         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8872         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8873 #ifdef MOMENT
8874         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8875 #else
8876         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8877 #endif
8878 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8879       endif
8880 C Derivatives in gamma(k-1)
8881 #ifdef MOMENT
8882       s1=dip(1,jj,i)*dipderg(1,kk,k)
8883 #endif
8884       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8885       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8886       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8887       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8888       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8889       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8890       vv(1)=pizda(1,1)-pizda(2,2)
8891       vv(2)=pizda(1,2)+pizda(2,1)
8892       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8893 #ifdef MOMENT
8894       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8895 #else
8896       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8897 #endif
8898 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8899 C Derivatives in gamma(j-1) or gamma(l-1)
8900       if (j.gt.1) then
8901 #ifdef MOMENT
8902         s1=dipderg(3,jj,i)*dip(1,kk,k)
8903 #endif
8904         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8905         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8906         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8907         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8908         vv(1)=pizda(1,1)-pizda(2,2)
8909         vv(2)=pizda(1,2)+pizda(2,1)
8910         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8911 #ifdef MOMENT
8912         if (swap) then
8913           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8914         else
8915           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8916         endif
8917 #endif
8918         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8919 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8920       endif
8921 C Derivatives in gamma(l-1) or gamma(j-1)
8922       if (l.gt.1) then
8923 #ifdef MOMENT
8924         s1=dip(1,jj,i)*dipderg(3,kk,k)
8925 #endif
8926         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8927         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8928         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8929         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8930         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8931         vv(1)=pizda(1,1)-pizda(2,2)
8932         vv(2)=pizda(1,2)+pizda(2,1)
8933         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8934 #ifdef MOMENT
8935         if (swap) then
8936           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8937         else
8938           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8939         endif
8940 #endif
8941         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8942 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8943       endif
8944 C Cartesian derivatives.
8945       if (lprn) then
8946         write (2,*) 'In eello6_graph2'
8947         do iii=1,2
8948           write (2,*) 'iii=',iii
8949           do kkk=1,5
8950             write (2,*) 'kkk=',kkk
8951             do jjj=1,2
8952               write (2,'(3(2f10.5),5x)')
8953      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8954             enddo
8955           enddo
8956         enddo
8957       endif
8958       do iii=1,2
8959         do kkk=1,5
8960           do lll=1,3
8961 #ifdef MOMENT
8962             if (iii.eq.1) then
8963               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8964             else
8965               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8966             endif
8967 #endif
8968             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8969      &        auxvec(1))
8970             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8971             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8972      &        auxvec(1))
8973             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8974             call transpose2(EUg(1,1,k),auxmat(1,1))
8975             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8976      &        pizda(1,1))
8977             vv(1)=pizda(1,1)-pizda(2,2)
8978             vv(2)=pizda(1,2)+pizda(2,1)
8979             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8980 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8981 #ifdef MOMENT
8982             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8983 #else
8984             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8985 #endif
8986             if (swap) then
8987               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8988             else
8989               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8990             endif
8991           enddo
8992         enddo
8993       enddo
8994       endif ! calc_grad
8995       return
8996       end
8997 c----------------------------------------------------------------------------
8998       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8999       implicit real*8 (a-h,o-z)
9000       include 'DIMENSIONS'
9001       include 'DIMENSIONS.ZSCOPT'
9002       include 'COMMON.IOUNITS'
9003       include 'COMMON.CHAIN'
9004       include 'COMMON.DERIV'
9005       include 'COMMON.INTERACT'
9006       include 'COMMON.CONTACTS'
9007       include 'COMMON.CONTMAT'
9008       include 'COMMON.CORRMAT'
9009       include 'COMMON.TORSION'
9010       include 'COMMON.VAR'
9011       include 'COMMON.GEO'
9012       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9013       logical swap
9014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9015 C                                                                              C
9016 C      Parallel       Antiparallel                                             C
9017 C                                                                              C
9018 C          o             o                                                     C
9019 C         /l\   /   \   /j\                                                    C
9020 C        /   \ /     \ /   \                                                   C
9021 C       /| o |o       o| o |\                                                  C
9022 C       j|/k\|  /      |/k\|l /                                                C
9023 C        /   \ /       /   \ /                                                 C
9024 C       /     o       /     o                                                  C
9025 C       i             i                                                        C
9026 C                                                                              C
9027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9028 C
9029 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9030 C           energy moment and not to the cluster cumulant.
9031       iti=itortyp(itype(i))
9032       if (j.lt.nres-1) then
9033         itj1=itype2loc(itype(j+1))
9034       else
9035         itj1=nloctyp
9036       endif
9037       itk=itype2loc(itype(k))
9038       itk1=itype2loc(itype(k+1))
9039       if (l.lt.nres-1) then
9040         itl1=itype2loc(itype(l+1))
9041       else
9042         itl1=nloctyp
9043       endif
9044 #ifdef MOMENT
9045       s1=dip(4,jj,i)*dip(4,kk,k)
9046 #endif
9047       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9048       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9049       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9050       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9051       call transpose2(EE(1,1,k),auxmat(1,1))
9052       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9053       vv(1)=pizda(1,1)+pizda(2,2)
9054       vv(2)=pizda(2,1)-pizda(1,2)
9055       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9056 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9057 cd     & "sum",-(s2+s3+s4)
9058 #ifdef MOMENT
9059       eello6_graph3=-(s1+s2+s3+s4)
9060 #else
9061       eello6_graph3=-(s2+s3+s4)
9062 #endif
9063 c      eello6_graph3=-s4
9064 C Derivatives in gamma(k-1)
9065       if (calc_grad) then
9066       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9067       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9068       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9069       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9070 C Derivatives in gamma(l-1)
9071       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9072       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9073       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9074       vv(1)=pizda(1,1)+pizda(2,2)
9075       vv(2)=pizda(2,1)-pizda(1,2)
9076       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9077       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9078 C Cartesian derivatives.
9079       do iii=1,2
9080         do kkk=1,5
9081           do lll=1,3
9082 #ifdef MOMENT
9083             if (iii.eq.1) then
9084               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9085             else
9086               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9087             endif
9088 #endif
9089             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9090      &        auxvec(1))
9091             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9092             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9093      &        auxvec(1))
9094             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9095             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9096      &        pizda(1,1))
9097             vv(1)=pizda(1,1)+pizda(2,2)
9098             vv(2)=pizda(2,1)-pizda(1,2)
9099             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9100 #ifdef MOMENT
9101             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9102 #else
9103             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9104 #endif
9105             if (swap) then
9106               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9107             else
9108               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9109             endif
9110 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9111           enddo
9112         enddo
9113       enddo
9114       endif ! calc_grad
9115       return
9116       end
9117 c----------------------------------------------------------------------------
9118       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9119       implicit real*8 (a-h,o-z)
9120       include 'DIMENSIONS'
9121       include 'DIMENSIONS.ZSCOPT'
9122       include 'COMMON.IOUNITS'
9123       include 'COMMON.CHAIN'
9124       include 'COMMON.DERIV'
9125       include 'COMMON.INTERACT'
9126       include 'COMMON.CONTACTS'
9127       include 'COMMON.CONTMAT'
9128       include 'COMMON.CORRMAT'
9129       include 'COMMON.TORSION'
9130       include 'COMMON.VAR'
9131       include 'COMMON.GEO'
9132       include 'COMMON.FFIELD'
9133       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9134      & auxvec1(2),auxmat1(2,2)
9135       logical swap
9136 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9137 C                                                                              C
9138 C      Parallel       Antiparallel                                             C
9139 C                                                                              C
9140 C          o             o                                                     C
9141 C         /l\   /   \   /j\                                                    C
9142 C        /   \ /     \ /   \                                                   C
9143 C       /| o |o       o| o |\                                                  C
9144 C     \ j|/k\|      \  |/k\|l                                                  C
9145 C      \ /   \       \ /   \                                                   C
9146 C       o     \       o     \                                                  C
9147 C       i             i                                                        C
9148 C                                                                              C
9149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9150 C
9151 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9152 C           energy moment and not to the cluster cumulant.
9153 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9154       iti=itype2loc(itype(i))
9155       itj=itype2loc(itype(j))
9156       if (j.lt.nres-1) then
9157         itj1=itype2loc(itype(j+1))
9158       else
9159         itj1=nloctyp
9160       endif
9161       itk=itype2loc(itype(k))
9162       if (k.lt.nres-1) then
9163         itk1=itype2loc(itype(k+1))
9164       else
9165         itk1=nloctyp
9166       endif
9167       itl=itype2loc(itype(l))
9168       if (l.lt.nres-1) then
9169         itl1=itype2loc(itype(l+1))
9170       else
9171         itl1=nloctyp
9172       endif
9173 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9174 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9175 cd     & ' itl',itl,' itl1',itl1
9176 #ifdef MOMENT
9177       if (imat.eq.1) then
9178         s1=dip(3,jj,i)*dip(3,kk,k)
9179       else
9180         s1=dip(2,jj,j)*dip(2,kk,l)
9181       endif
9182 #endif
9183       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9184       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9185       if (j.eq.l+1) then
9186         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9187         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9188       else
9189         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9190         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9191       endif
9192       call transpose2(EUg(1,1,k),auxmat(1,1))
9193       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9194       vv(1)=pizda(1,1)-pizda(2,2)
9195       vv(2)=pizda(2,1)+pizda(1,2)
9196       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9197 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9198 #ifdef MOMENT
9199       eello6_graph4=-(s1+s2+s3+s4)
9200 #else
9201       eello6_graph4=-(s2+s3+s4)
9202 #endif
9203 C Derivatives in gamma(i-1)
9204       if (calc_grad) then
9205       if (i.gt.1) then
9206 #ifdef MOMENT
9207         if (imat.eq.1) then
9208           s1=dipderg(2,jj,i)*dip(3,kk,k)
9209         else
9210           s1=dipderg(4,jj,j)*dip(2,kk,l)
9211         endif
9212 #endif
9213         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9214         if (j.eq.l+1) then
9215           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9216           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9217         else
9218           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9219           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9220         endif
9221         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9222         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9223 cd          write (2,*) 'turn6 derivatives'
9224 #ifdef MOMENT
9225           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9226 #else
9227           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9228 #endif
9229         else
9230 #ifdef MOMENT
9231           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9232 #else
9233           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9234 #endif
9235         endif
9236       endif
9237 C Derivatives in gamma(k-1)
9238 #ifdef MOMENT
9239       if (imat.eq.1) then
9240         s1=dip(3,jj,i)*dipderg(2,kk,k)
9241       else
9242         s1=dip(2,jj,j)*dipderg(4,kk,l)
9243       endif
9244 #endif
9245       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9246       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9247       if (j.eq.l+1) then
9248         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9249         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9250       else
9251         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9252         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9253       endif
9254       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9255       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9256       vv(1)=pizda(1,1)-pizda(2,2)
9257       vv(2)=pizda(2,1)+pizda(1,2)
9258       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9259       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9260 #ifdef MOMENT
9261         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9262 #else
9263         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9264 #endif
9265       else
9266 #ifdef MOMENT
9267         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9268 #else
9269         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9270 #endif
9271       endif
9272 C Derivatives in gamma(j-1) or gamma(l-1)
9273       if (l.eq.j+1 .and. l.gt.1) then
9274         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9275         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9276         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9277         vv(1)=pizda(1,1)-pizda(2,2)
9278         vv(2)=pizda(2,1)+pizda(1,2)
9279         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9280         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9281       else if (j.gt.1) then
9282         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9283         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9284         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9285         vv(1)=pizda(1,1)-pizda(2,2)
9286         vv(2)=pizda(2,1)+pizda(1,2)
9287         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9288         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9289           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9290         else
9291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9292         endif
9293       endif
9294 C Cartesian derivatives.
9295       do iii=1,2
9296         do kkk=1,5
9297           do lll=1,3
9298 #ifdef MOMENT
9299             if (iii.eq.1) then
9300               if (imat.eq.1) then
9301                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9302               else
9303                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9304               endif
9305             else
9306               if (imat.eq.1) then
9307                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9308               else
9309                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9310               endif
9311             endif
9312 #endif
9313             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9314      &        auxvec(1))
9315             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9316             if (j.eq.l+1) then
9317               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9318      &          b1(1,j+1),auxvec(1))
9319               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9320             else
9321               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9322      &          b1(1,l+1),auxvec(1))
9323               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9324             endif
9325             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9326      &        pizda(1,1))
9327             vv(1)=pizda(1,1)-pizda(2,2)
9328             vv(2)=pizda(2,1)+pizda(1,2)
9329             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9330             if (swap) then
9331               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9332 #ifdef MOMENT
9333                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9334      &             -(s1+s2+s4)
9335 #else
9336                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9337      &             -(s2+s4)
9338 #endif
9339                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9340               else
9341 #ifdef MOMENT
9342                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9343 #else
9344                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9345 #endif
9346                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9347               endif
9348             else
9349 #ifdef MOMENT
9350               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9351 #else
9352               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9353 #endif
9354               if (l.eq.j+1) then
9355                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9356               else
9357                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9358               endif
9359             endif
9360           enddo
9361         enddo
9362       enddo
9363       endif ! calc_grad
9364       return
9365       end
9366 c----------------------------------------------------------------------------
9367       double precision function eello_turn6(i,jj,kk)
9368       implicit real*8 (a-h,o-z)
9369       include 'DIMENSIONS'
9370       include 'DIMENSIONS.ZSCOPT'
9371       include 'COMMON.IOUNITS'
9372       include 'COMMON.CHAIN'
9373       include 'COMMON.DERIV'
9374       include 'COMMON.INTERACT'
9375       include 'COMMON.CONTACTS'
9376       include 'COMMON.CONTMAT'
9377       include 'COMMON.CORRMAT'
9378       include 'COMMON.TORSION'
9379       include 'COMMON.VAR'
9380       include 'COMMON.GEO'
9381       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9382      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9383      &  ggg1(3),ggg2(3)
9384       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9385      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9386 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9387 C           the respective energy moment and not to the cluster cumulant.
9388       s1=0.0d0
9389       s8=0.0d0
9390       s13=0.0d0
9391 c
9392       eello_turn6=0.0d0
9393       j=i+4
9394       k=i+1
9395       l=i+3
9396       iti=itype2loc(itype(i))
9397       itk=itype2loc(itype(k))
9398       itk1=itype2loc(itype(k+1))
9399       itl=itype2loc(itype(l))
9400       itj=itype2loc(itype(j))
9401 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9402 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9403 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9404 cd        eello6=0.0d0
9405 cd        return
9406 cd      endif
9407 cd      write (iout,*)
9408 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9409 cd     &   ' and',k,l
9410 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9411       do iii=1,2
9412         do kkk=1,5
9413           do lll=1,3
9414             derx_turn(lll,kkk,iii)=0.0d0
9415           enddo
9416         enddo
9417       enddo
9418 cd      eij=1.0d0
9419 cd      ekl=1.0d0
9420 cd      ekont=1.0d0
9421       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9422 cd      eello6_5=0.0d0
9423 cd      write (2,*) 'eello6_5',eello6_5
9424 #ifdef MOMENT
9425       call transpose2(AEA(1,1,1),auxmat(1,1))
9426       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9427       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9428       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9429 #endif
9430       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9431       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9432       s2 = scalar2(b1(1,k),vtemp1(1))
9433 #ifdef MOMENT
9434       call transpose2(AEA(1,1,2),atemp(1,1))
9435       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9436       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9437       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9438 #endif
9439       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9440       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9441       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9442 #ifdef MOMENT
9443       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9444       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9445       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9446       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9447       ss13 = scalar2(b1(1,k),vtemp4(1))
9448       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9449 #endif
9450 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9451 c      s1=0.0d0
9452 c      s2=0.0d0
9453 c      s8=0.0d0
9454 c      s12=0.0d0
9455 c      s13=0.0d0
9456       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9457 C Derivatives in gamma(i+2)
9458       if (calc_grad) then
9459       s1d =0.0d0
9460       s8d =0.0d0
9461 #ifdef MOMENT
9462       call transpose2(AEA(1,1,1),auxmatd(1,1))
9463       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9464       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9465       call transpose2(AEAderg(1,1,2),atempd(1,1))
9466       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9467       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9468 #endif
9469       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9470       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9471       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9472 c      s1d=0.0d0
9473 c      s2d=0.0d0
9474 c      s8d=0.0d0
9475 c      s12d=0.0d0
9476 c      s13d=0.0d0
9477       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9478 C Derivatives in gamma(i+3)
9479 #ifdef MOMENT
9480       call transpose2(AEA(1,1,1),auxmatd(1,1))
9481       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9482       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9483       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9484 #endif
9485       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9486       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9487       s2d = scalar2(b1(1,k),vtemp1d(1))
9488 #ifdef MOMENT
9489       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9490       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9491 #endif
9492       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9493 #ifdef MOMENT
9494       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9495       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9496       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9497 #endif
9498 c      s1d=0.0d0
9499 c      s2d=0.0d0
9500 c      s8d=0.0d0
9501 c      s12d=0.0d0
9502 c      s13d=0.0d0
9503 #ifdef MOMENT
9504       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9505      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9506 #else
9507       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9508      &               -0.5d0*ekont*(s2d+s12d)
9509 #endif
9510 C Derivatives in gamma(i+4)
9511       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9512       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9513       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9514 #ifdef MOMENT
9515       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9516       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9517       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9518 #endif
9519 c      s1d=0.0d0
9520 c      s2d=0.0d0
9521 c      s8d=0.0d0
9522 C      s12d=0.0d0
9523 c      s13d=0.0d0
9524 #ifdef MOMENT
9525       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9526 #else
9527       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9528 #endif
9529 C Derivatives in gamma(i+5)
9530 #ifdef MOMENT
9531       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9532       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9533       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9534 #endif
9535       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9536       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9537       s2d = scalar2(b1(1,k),vtemp1d(1))
9538 #ifdef MOMENT
9539       call transpose2(AEA(1,1,2),atempd(1,1))
9540       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9541       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9542 #endif
9543       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9544       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9545 #ifdef MOMENT
9546       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9547       ss13d = scalar2(b1(1,k),vtemp4d(1))
9548       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9549 #endif
9550 c      s1d=0.0d0
9551 c      s2d=0.0d0
9552 c      s8d=0.0d0
9553 c      s12d=0.0d0
9554 c      s13d=0.0d0
9555 #ifdef MOMENT
9556       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9557      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9558 #else
9559       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9560      &               -0.5d0*ekont*(s2d+s12d)
9561 #endif
9562 C Cartesian derivatives
9563       do iii=1,2
9564         do kkk=1,5
9565           do lll=1,3
9566 #ifdef MOMENT
9567             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9568             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9569             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9570 #endif
9571             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9572             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9573      &          vtemp1d(1))
9574             s2d = scalar2(b1(1,k),vtemp1d(1))
9575 #ifdef MOMENT
9576             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9577             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9578             s8d = -(atempd(1,1)+atempd(2,2))*
9579      &           scalar2(cc(1,1,l),vtemp2(1))
9580 #endif
9581             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9582      &           auxmatd(1,1))
9583             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9584             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9585 c      s1d=0.0d0
9586 c      s2d=0.0d0
9587 c      s8d=0.0d0
9588 c      s12d=0.0d0
9589 c      s13d=0.0d0
9590 #ifdef MOMENT
9591             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9592      &        - 0.5d0*(s1d+s2d)
9593 #else
9594             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9595      &        - 0.5d0*s2d
9596 #endif
9597 #ifdef MOMENT
9598             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9599      &        - 0.5d0*(s8d+s12d)
9600 #else
9601             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9602      &        - 0.5d0*s12d
9603 #endif
9604           enddo
9605         enddo
9606       enddo
9607 #ifdef MOMENT
9608       do kkk=1,5
9609         do lll=1,3
9610           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9611      &      achuj_tempd(1,1))
9612           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9613           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9614           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9615           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9616           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9617      &      vtemp4d(1))
9618           ss13d = scalar2(b1(1,k),vtemp4d(1))
9619           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9620           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9621         enddo
9622       enddo
9623 #endif
9624 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9625 cd     &  16*eel_turn6_num
9626 cd      goto 1112
9627       if (j.lt.nres-1) then
9628         j1=j+1
9629         j2=j-1
9630       else
9631         j1=j-1
9632         j2=j-2
9633       endif
9634       if (l.lt.nres-1) then
9635         l1=l+1
9636         l2=l-1
9637       else
9638         l1=l-1
9639         l2=l-2
9640       endif
9641       do ll=1,3
9642 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9643 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9644 cgrad        ghalf=0.5d0*ggg1(ll)
9645 cd        ghalf=0.0d0
9646         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9647         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9648         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9649      &    +ekont*derx_turn(ll,2,1)
9650         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9651         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9652      &    +ekont*derx_turn(ll,4,1)
9653         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9654         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9655         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9656 cgrad        ghalf=0.5d0*ggg2(ll)
9657 cd        ghalf=0.0d0
9658         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9659      &    +ekont*derx_turn(ll,2,2)
9660         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9661         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9662      &    +ekont*derx_turn(ll,4,2)
9663         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9664         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9665         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9666       enddo
9667 cd      goto 1112
9668 cgrad      do m=i+1,j-1
9669 cgrad        do ll=1,3
9670 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9671 cgrad        enddo
9672 cgrad      enddo
9673 cgrad      do m=k+1,l-1
9674 cgrad        do ll=1,3
9675 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9676 cgrad        enddo
9677 cgrad      enddo
9678 cgrad1112  continue
9679 cgrad      do m=i+2,j2
9680 cgrad        do ll=1,3
9681 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9682 cgrad        enddo
9683 cgrad      enddo
9684 cgrad      do m=k+2,l2
9685 cgrad        do ll=1,3
9686 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9687 cgrad        enddo
9688 cgrad      enddo
9689 cd      do iii=1,nres-3
9690 cd        write (2,*) iii,g_corr6_loc(iii)
9691 cd      enddo
9692       endif ! calc_grad
9693       eello_turn6=ekont*eel_turn6
9694 cd      write (2,*) 'ekont',ekont
9695 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9696       return
9697       end
9698 #endif
9699 crc-------------------------------------------------
9700 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9701       subroutine Eliptransfer(eliptran)
9702       implicit real*8 (a-h,o-z)
9703       include 'DIMENSIONS'
9704       include 'DIMENSIONS.ZSCOPT'
9705       include 'COMMON.GEO'
9706       include 'COMMON.VAR'
9707       include 'COMMON.LOCAL'
9708       include 'COMMON.CHAIN'
9709       include 'COMMON.DERIV'
9710       include 'COMMON.INTERACT'
9711       include 'COMMON.IOUNITS'
9712       include 'COMMON.CALC'
9713       include 'COMMON.CONTROL'
9714       include 'COMMON.SPLITELE'
9715       include 'COMMON.SBRIDGE'
9716 C this is done by Adasko
9717 C      print *,"wchodze"
9718 C structure of box:
9719 C      water
9720 C--bordliptop-- buffore starts
9721 C--bufliptop--- here true lipid starts
9722 C      lipid
9723 C--buflipbot--- lipid ends buffore starts
9724 C--bordlipbot--buffore ends
9725       eliptran=0.0
9726       do i=1,nres
9727 C       do i=1,1
9728         if (itype(i).eq.ntyp1) cycle
9729
9730         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9731         if (positi.le.0) positi=positi+boxzsize
9732 C        print *,i
9733 C first for peptide groups
9734 c for each residue check if it is in lipid or lipid water border area
9735        if ((positi.gt.bordlipbot)
9736      &.and.(positi.lt.bordliptop)) then
9737 C the energy transfer exist
9738         if (positi.lt.buflipbot) then
9739 C what fraction I am in
9740          fracinbuf=1.0d0-
9741      &        ((positi-bordlipbot)/lipbufthick)
9742 C lipbufthick is thickenes of lipid buffore
9743          sslip=sscalelip(fracinbuf)
9744          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9745          eliptran=eliptran+sslip*pepliptran
9746          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9747          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9748 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9749         elseif (positi.gt.bufliptop) then
9750          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9751          sslip=sscalelip(fracinbuf)
9752          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9753          eliptran=eliptran+sslip*pepliptran
9754          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9755          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9756 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9757 C          print *, "doing sscalefor top part"
9758 C         print *,i,sslip,fracinbuf,ssgradlip
9759         else
9760          eliptran=eliptran+pepliptran
9761 C         print *,"I am in true lipid"
9762         endif
9763 C       else
9764 C       eliptran=elpitran+0.0 ! I am in water
9765        endif
9766        enddo
9767 C       print *, "nic nie bylo w lipidzie?"
9768 C now multiply all by the peptide group transfer factor
9769 C       eliptran=eliptran*pepliptran
9770 C now the same for side chains
9771 CV       do i=1,1
9772        do i=1,nres
9773         if (itype(i).eq.ntyp1) cycle
9774         positi=(mod(c(3,i+nres),boxzsize))
9775         if (positi.le.0) positi=positi+boxzsize
9776 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9777 c for each residue check if it is in lipid or lipid water border area
9778 C       respos=mod(c(3,i+nres),boxzsize)
9779 C       print *,positi,bordlipbot,buflipbot
9780        if ((positi.gt.bordlipbot)
9781      & .and.(positi.lt.bordliptop)) then
9782 C the energy transfer exist
9783         if (positi.lt.buflipbot) then
9784          fracinbuf=1.0d0-
9785      &     ((positi-bordlipbot)/lipbufthick)
9786 C lipbufthick is thickenes of lipid buffore
9787          sslip=sscalelip(fracinbuf)
9788          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9789          eliptran=eliptran+sslip*liptranene(itype(i))
9790          gliptranx(3,i)=gliptranx(3,i)
9791      &+ssgradlip*liptranene(itype(i))
9792          gliptranc(3,i-1)= gliptranc(3,i-1)
9793      &+ssgradlip*liptranene(itype(i))
9794 C         print *,"doing sccale for lower part"
9795         elseif (positi.gt.bufliptop) then
9796          fracinbuf=1.0d0-
9797      &((bordliptop-positi)/lipbufthick)
9798          sslip=sscalelip(fracinbuf)
9799          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9800          eliptran=eliptran+sslip*liptranene(itype(i))
9801          gliptranx(3,i)=gliptranx(3,i)
9802      &+ssgradlip*liptranene(itype(i))
9803          gliptranc(3,i-1)= gliptranc(3,i-1)
9804      &+ssgradlip*liptranene(itype(i))
9805 C          print *, "doing sscalefor top part",sslip,fracinbuf
9806         else
9807          eliptran=eliptran+liptranene(itype(i))
9808 C         print *,"I am in true lipid"
9809         endif
9810         endif ! if in lipid or buffor
9811 C       else
9812 C       eliptran=elpitran+0.0 ! I am in water
9813        enddo
9814        return
9815        end
9816
9817
9818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9819
9820       SUBROUTINE MATVEC2(A1,V1,V2)
9821       implicit real*8 (a-h,o-z)
9822       include 'DIMENSIONS'
9823       DIMENSION A1(2,2),V1(2),V2(2)
9824 c      DO 1 I=1,2
9825 c        VI=0.0
9826 c        DO 3 K=1,2
9827 c    3     VI=VI+A1(I,K)*V1(K)
9828 c        Vaux(I)=VI
9829 c    1 CONTINUE
9830
9831       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9832       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9833
9834       v2(1)=vaux1
9835       v2(2)=vaux2
9836       END
9837 C---------------------------------------
9838       SUBROUTINE MATMAT2(A1,A2,A3)
9839       implicit real*8 (a-h,o-z)
9840       include 'DIMENSIONS'
9841       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9842 c      DIMENSION AI3(2,2)
9843 c        DO  J=1,2
9844 c          A3IJ=0.0
9845 c          DO K=1,2
9846 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9847 c          enddo
9848 c          A3(I,J)=A3IJ
9849 c       enddo
9850 c      enddo
9851
9852       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9853       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9854       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9855       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9856
9857       A3(1,1)=AI3_11
9858       A3(2,1)=AI3_21
9859       A3(1,2)=AI3_12
9860       A3(2,2)=AI3_22
9861       END
9862
9863 c-------------------------------------------------------------------------
9864       double precision function scalar2(u,v)
9865       implicit none
9866       double precision u(2),v(2)
9867       double precision sc
9868       integer i
9869       scalar2=u(1)*v(1)+u(2)*v(2)
9870       return
9871       end
9872
9873 C-----------------------------------------------------------------------------
9874
9875       subroutine transpose2(a,at)
9876       implicit none
9877       double precision a(2,2),at(2,2)
9878       at(1,1)=a(1,1)
9879       at(1,2)=a(2,1)
9880       at(2,1)=a(1,2)
9881       at(2,2)=a(2,2)
9882       return
9883       end
9884 c--------------------------------------------------------------------------
9885       subroutine transpose(n,a,at)
9886       implicit none
9887       integer n,i,j
9888       double precision a(n,n),at(n,n)
9889       do i=1,n
9890         do j=1,n
9891           at(j,i)=a(i,j)
9892         enddo
9893       enddo
9894       return
9895       end
9896 C---------------------------------------------------------------------------
9897       subroutine prodmat3(a1,a2,kk,transp,prod)
9898       implicit none
9899       integer i,j
9900       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9901       logical transp
9902 crc      double precision auxmat(2,2),prod_(2,2)
9903
9904       if (transp) then
9905 crc        call transpose2(kk(1,1),auxmat(1,1))
9906 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9907 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9908
9909            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9910      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9911            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9912      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9913            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9914      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9915            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9916      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9917
9918       else
9919 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9920 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9921
9922            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9923      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9924            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9925      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9926            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9927      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9928            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9929      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9930
9931       endif
9932 c      call transpose2(a2(1,1),a2t(1,1))
9933
9934 crc      print *,transp
9935 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9936 crc      print *,((prod(i,j),i=1,2),j=1,2)
9937
9938       return
9939       end
9940 C-----------------------------------------------------------------------------
9941       double precision function scalar(u,v)
9942       implicit none
9943       double precision u(3),v(3)
9944       double precision sc
9945       integer i
9946       sc=0.0d0
9947       do i=1,3
9948         sc=sc+u(i)*v(i)
9949       enddo
9950       scalar=sc
9951       return
9952       end
9953 C-----------------------------------------------------------------------
9954       double precision function sscale(r)
9955       double precision r,gamm
9956       include "COMMON.SPLITELE"
9957       if(r.lt.r_cut-rlamb) then
9958         sscale=1.0d0
9959       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9960         gamm=(r-(r_cut-rlamb))/rlamb
9961         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9962       else
9963         sscale=0d0
9964       endif
9965       return
9966       end
9967 C-----------------------------------------------------------------------
9968 C-----------------------------------------------------------------------
9969       double precision function sscagrad(r)
9970       double precision r,gamm
9971       include "COMMON.SPLITELE"
9972       if(r.lt.r_cut-rlamb) then
9973         sscagrad=0.0d0
9974       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9975         gamm=(r-(r_cut-rlamb))/rlamb
9976         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9977       else
9978         sscagrad=0.0d0
9979       endif
9980       return
9981       end
9982 C-----------------------------------------------------------------------
9983 C-----------------------------------------------------------------------
9984       double precision function sscalelip(r)
9985       double precision r,gamm
9986       include "COMMON.SPLITELE"
9987 C      if(r.lt.r_cut-rlamb) then
9988 C        sscale=1.0d0
9989 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9990 C        gamm=(r-(r_cut-rlamb))/rlamb
9991         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9992 C      else
9993 C        sscale=0d0
9994 C      endif
9995       return
9996       end
9997 C-----------------------------------------------------------------------
9998       double precision function sscagradlip(r)
9999       double precision r,gamm
10000       include "COMMON.SPLITELE"
10001 C     if(r.lt.r_cut-rlamb) then
10002 C        sscagrad=0.0d0
10003 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10004 C        gamm=(r-(r_cut-rlamb))/rlamb
10005         sscagradlip=r*(6*r-6.0d0)
10006 C      else
10007 C        sscagrad=0.0d0
10008 C      endif
10009       return
10010       end
10011
10012 C-----------------------------------------------------------------------
10013        subroutine set_shield_fac
10014       implicit real*8 (a-h,o-z)
10015       include 'DIMENSIONS'
10016       include 'DIMENSIONS.ZSCOPT'
10017       include 'COMMON.CHAIN'
10018       include 'COMMON.DERIV'
10019       include 'COMMON.IOUNITS'
10020       include 'COMMON.SHIELD'
10021       include 'COMMON.INTERACT'
10022 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10023       double precision div77_81/0.974996043d0/,
10024      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10025
10026 C the vector between center of side_chain and peptide group
10027        double precision pep_side(3),long,side_calf(3),
10028      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10029      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10030 C the line belowe needs to be changed for FGPROC>1
10031       do i=1,nres-1
10032       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10033       ishield_list(i)=0
10034 Cif there two consequtive dummy atoms there is no peptide group between them
10035 C the line below has to be changed for FGPROC>1
10036       VolumeTotal=0.0
10037       do k=1,nres
10038        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10039        dist_pep_side=0.0
10040        dist_side_calf=0.0
10041        do j=1,3
10042 C first lets set vector conecting the ithe side-chain with kth side-chain
10043       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10044 C      pep_side(j)=2.0d0
10045 C and vector conecting the side-chain with its proper calfa
10046       side_calf(j)=c(j,k+nres)-c(j,k)
10047 C      side_calf(j)=2.0d0
10048       pept_group(j)=c(j,i)-c(j,i+1)
10049 C lets have their lenght
10050       dist_pep_side=pep_side(j)**2+dist_pep_side
10051       dist_side_calf=dist_side_calf+side_calf(j)**2
10052       dist_pept_group=dist_pept_group+pept_group(j)**2
10053       enddo
10054        dist_pep_side=dsqrt(dist_pep_side)
10055        dist_pept_group=dsqrt(dist_pept_group)
10056        dist_side_calf=dsqrt(dist_side_calf)
10057       do j=1,3
10058         pep_side_norm(j)=pep_side(j)/dist_pep_side
10059         side_calf_norm(j)=dist_side_calf
10060       enddo
10061 C now sscale fraction
10062        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10063 C       print *,buff_shield,"buff"
10064 C now sscale
10065         if (sh_frac_dist.le.0.0) cycle
10066 C If we reach here it means that this side chain reaches the shielding sphere
10067 C Lets add him to the list for gradient
10068         ishield_list(i)=ishield_list(i)+1
10069 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10070 C this list is essential otherwise problem would be O3
10071         shield_list(ishield_list(i),i)=k
10072 C Lets have the sscale value
10073         if (sh_frac_dist.gt.1.0) then
10074          scale_fac_dist=1.0d0
10075          do j=1,3
10076          sh_frac_dist_grad(j)=0.0d0
10077          enddo
10078         else
10079          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10080      &                   *(2.0*sh_frac_dist-3.0d0)
10081          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10082      &                  /dist_pep_side/buff_shield*0.5
10083 C remember for the final gradient multiply sh_frac_dist_grad(j)
10084 C for side_chain by factor -2 !
10085          do j=1,3
10086          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10087 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10088 C     &                    sh_frac_dist_grad(j)
10089          enddo
10090         endif
10091 C        if ((i.eq.3).and.(k.eq.2)) then
10092 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10093 C     & ,"TU"
10094 C        endif
10095
10096 C this is what is now we have the distance scaling now volume...
10097       short=short_r_sidechain(itype(k))
10098       long=long_r_sidechain(itype(k))
10099       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10100 C now costhet_grad
10101 C       costhet=0.0d0
10102        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10103 C       costhet_fac=0.0d0
10104        do j=1,3
10105          costhet_grad(j)=costhet_fac*pep_side(j)
10106        enddo
10107 C remember for the final gradient multiply costhet_grad(j)
10108 C for side_chain by factor -2 !
10109 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10110 C pep_side0pept_group is vector multiplication
10111       pep_side0pept_group=0.0
10112       do j=1,3
10113       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10114       enddo
10115       cosalfa=(pep_side0pept_group/
10116      & (dist_pep_side*dist_side_calf))
10117       fac_alfa_sin=1.0-cosalfa**2
10118       fac_alfa_sin=dsqrt(fac_alfa_sin)
10119       rkprim=fac_alfa_sin*(long-short)+short
10120 C now costhet_grad
10121        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10122        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10123
10124        do j=1,3
10125          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10126      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10127      &*(long-short)/fac_alfa_sin*cosalfa/
10128      &((dist_pep_side*dist_side_calf))*
10129      &((side_calf(j))-cosalfa*
10130      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10131
10132         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10133      &*(long-short)/fac_alfa_sin*cosalfa
10134      &/((dist_pep_side*dist_side_calf))*
10135      &(pep_side(j)-
10136      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10137        enddo
10138
10139       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10140      &                    /VSolvSphere_div
10141      &                    *wshield
10142 C now the gradient...
10143 C grad_shield is gradient of Calfa for peptide groups
10144 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10145 C     &               costhet,cosphi
10146 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10147 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10148       do j=1,3
10149       grad_shield(j,i)=grad_shield(j,i)
10150 C gradient po skalowaniu
10151      &                +(sh_frac_dist_grad(j)
10152 C  gradient po costhet
10153      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10154      &-scale_fac_dist*(cosphi_grad_long(j))
10155      &/(1.0-cosphi) )*div77_81
10156      &*VofOverlap
10157 C grad_shield_side is Cbeta sidechain gradient
10158       grad_shield_side(j,ishield_list(i),i)=
10159      &        (sh_frac_dist_grad(j)*(-2.0d0)
10160      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10161      &       +scale_fac_dist*(cosphi_grad_long(j))
10162      &        *2.0d0/(1.0-cosphi))
10163      &        *div77_81*VofOverlap
10164
10165        grad_shield_loc(j,ishield_list(i),i)=
10166      &   scale_fac_dist*cosphi_grad_loc(j)
10167      &        *2.0d0/(1.0-cosphi)
10168      &        *div77_81*VofOverlap
10169       enddo
10170       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10171       enddo
10172       fac_shield(i)=VolumeTotal*div77_81+div4_81
10173 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10174       enddo
10175       return
10176       end
10177 C--------------------------------------------------------------------------
10178 C first for shielding is setting of function of side-chains
10179        subroutine set_shield_fac2
10180       implicit real*8 (a-h,o-z)
10181       include 'DIMENSIONS'
10182       include 'DIMENSIONS.ZSCOPT'
10183       include 'COMMON.CHAIN'
10184       include 'COMMON.DERIV'
10185       include 'COMMON.IOUNITS'
10186       include 'COMMON.SHIELD'
10187       include 'COMMON.INTERACT'
10188 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10189       double precision div77_81/0.974996043d0/,
10190      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10191
10192 C the vector between center of side_chain and peptide group
10193        double precision pep_side(3),long,side_calf(3),
10194      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10195      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10196 C the line belowe needs to be changed for FGPROC>1
10197       do i=1,nres-1
10198       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10199       ishield_list(i)=0
10200 Cif there two consequtive dummy atoms there is no peptide group between them
10201 C the line below has to be changed for FGPROC>1
10202       VolumeTotal=0.0
10203       do k=1,nres
10204        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10205        dist_pep_side=0.0
10206        dist_side_calf=0.0
10207        do j=1,3
10208 C first lets set vector conecting the ithe side-chain with kth side-chain
10209       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10210 C      pep_side(j)=2.0d0
10211 C and vector conecting the side-chain with its proper calfa
10212       side_calf(j)=c(j,k+nres)-c(j,k)
10213 C      side_calf(j)=2.0d0
10214       pept_group(j)=c(j,i)-c(j,i+1)
10215 C lets have their lenght
10216       dist_pep_side=pep_side(j)**2+dist_pep_side
10217       dist_side_calf=dist_side_calf+side_calf(j)**2
10218       dist_pept_group=dist_pept_group+pept_group(j)**2
10219       enddo
10220        dist_pep_side=dsqrt(dist_pep_side)
10221        dist_pept_group=dsqrt(dist_pept_group)
10222        dist_side_calf=dsqrt(dist_side_calf)
10223       do j=1,3
10224         pep_side_norm(j)=pep_side(j)/dist_pep_side
10225         side_calf_norm(j)=dist_side_calf
10226       enddo
10227 C now sscale fraction
10228        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10229 C       print *,buff_shield,"buff"
10230 C now sscale
10231         if (sh_frac_dist.le.0.0) cycle
10232 C If we reach here it means that this side chain reaches the shielding sphere
10233 C Lets add him to the list for gradient
10234         ishield_list(i)=ishield_list(i)+1
10235 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10236 C this list is essential otherwise problem would be O3
10237         shield_list(ishield_list(i),i)=k
10238 C Lets have the sscale value
10239         if (sh_frac_dist.gt.1.0) then
10240          scale_fac_dist=1.0d0
10241          do j=1,3
10242          sh_frac_dist_grad(j)=0.0d0
10243          enddo
10244         else
10245          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10246      &                   *(2.0d0*sh_frac_dist-3.0d0)
10247          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10248      &                  /dist_pep_side/buff_shield*0.5d0
10249 C remember for the final gradient multiply sh_frac_dist_grad(j)
10250 C for side_chain by factor -2 !
10251          do j=1,3
10252          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10253 C         sh_frac_dist_grad(j)=0.0d0
10254 C         scale_fac_dist=1.0d0
10255 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10256 C     &                    sh_frac_dist_grad(j)
10257          enddo
10258         endif
10259 C this is what is now we have the distance scaling now volume...
10260       short=short_r_sidechain(itype(k))
10261       long=long_r_sidechain(itype(k))
10262       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10263       sinthet=short/dist_pep_side*costhet
10264 C now costhet_grad
10265 C       costhet=0.6d0
10266 C       sinthet=0.8
10267        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10268 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10269 C     &             -short/dist_pep_side**2/costhet)
10270 C       costhet_fac=0.0d0
10271        do j=1,3
10272          costhet_grad(j)=costhet_fac*pep_side(j)
10273        enddo
10274 C remember for the final gradient multiply costhet_grad(j)
10275 C for side_chain by factor -2 !
10276 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10277 C pep_side0pept_group is vector multiplication
10278       pep_side0pept_group=0.0d0
10279       do j=1,3
10280       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10281       enddo
10282       cosalfa=(pep_side0pept_group/
10283      & (dist_pep_side*dist_side_calf))
10284       fac_alfa_sin=1.0d0-cosalfa**2
10285       fac_alfa_sin=dsqrt(fac_alfa_sin)
10286       rkprim=fac_alfa_sin*(long-short)+short
10287 C      rkprim=short
10288
10289 C now costhet_grad
10290        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10291 C       cosphi=0.6
10292        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10293        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10294      &      dist_pep_side**2)
10295 C       sinphi=0.8
10296        do j=1,3
10297          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10298      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10299      &*(long-short)/fac_alfa_sin*cosalfa/
10300      &((dist_pep_side*dist_side_calf))*
10301      &((side_calf(j))-cosalfa*
10302      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10303 C       cosphi_grad_long(j)=0.0d0
10304         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10305      &*(long-short)/fac_alfa_sin*cosalfa
10306      &/((dist_pep_side*dist_side_calf))*
10307      &(pep_side(j)-
10308      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10309 C       cosphi_grad_loc(j)=0.0d0
10310        enddo
10311 C      print *,sinphi,sinthet
10312       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10313      &                    /VSolvSphere_div
10314 C     &                    *wshield
10315 C now the gradient...
10316       do j=1,3
10317       grad_shield(j,i)=grad_shield(j,i)
10318 C gradient po skalowaniu
10319      &                +(sh_frac_dist_grad(j)*VofOverlap
10320 C  gradient po costhet
10321      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10322      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10323      &       sinphi/sinthet*costhet*costhet_grad(j)
10324      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10325      & )*wshield
10326 C grad_shield_side is Cbeta sidechain gradient
10327       grad_shield_side(j,ishield_list(i),i)=
10328      &        (sh_frac_dist_grad(j)*(-2.0d0)
10329      &        *VofOverlap
10330      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10331      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10332      &       sinphi/sinthet*costhet*costhet_grad(j)
10333      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10334      &       )*wshield
10335
10336        grad_shield_loc(j,ishield_list(i),i)=
10337      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10338      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10339      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10340      &        ))
10341      &        *wshield
10342       enddo
10343       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10344       enddo
10345       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10346 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10347 c     &  " wshield",wshield
10348 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10349       enddo
10350       return
10351       end
10352 C--------------------------------------------------------------------------
10353       double precision function tschebyshev(m,n,x,y)
10354       implicit none
10355       include "DIMENSIONS"
10356       integer i,m,n
10357       double precision x(n),y,yy(0:maxvar),aux
10358 c Tschebyshev polynomial. Note that the first term is omitted
10359 c m=0: the constant term is included
10360 c m=1: the constant term is not included
10361       yy(0)=1.0d0
10362       yy(1)=y
10363       do i=2,n
10364         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10365       enddo
10366       aux=0.0d0
10367       do i=m,n
10368         aux=aux+x(i)*yy(i)
10369       enddo
10370       tschebyshev=aux
10371       return
10372       end
10373 C--------------------------------------------------------------------------
10374       double precision function gradtschebyshev(m,n,x,y)
10375       implicit none
10376       include "DIMENSIONS"
10377       integer i,m,n
10378       double precision x(n+1),y,yy(0:maxvar),aux
10379 c Tschebyshev polynomial. Note that the first term is omitted
10380 c m=0: the constant term is included
10381 c m=1: the constant term is not included
10382       yy(0)=1.0d0
10383       yy(1)=2.0d0*y
10384       do i=2,n
10385         yy(i)=2*y*yy(i-1)-yy(i-2)
10386       enddo
10387       aux=0.0d0
10388       do i=m,n
10389         aux=aux+x(i+1)*yy(i)*(i+1)
10390 C        print *, x(i+1),yy(i),i
10391       enddo
10392       gradtschebyshev=aux
10393       return
10394       end
10395 c----------------------------------------------------------------------------
10396       double precision function sscale2(r,r_cut,r0,rlamb)
10397       implicit none
10398       double precision r,gamm,r_cut,r0,rlamb,rr
10399       rr = dabs(r-r0)
10400 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10401 c      write (2,*) "rr",rr
10402       if(rr.lt.r_cut-rlamb) then
10403         sscale2=1.0d0
10404       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10405         gamm=(rr-(r_cut-rlamb))/rlamb
10406         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10407       else
10408         sscale2=0d0
10409       endif
10410       return
10411       end
10412 C-----------------------------------------------------------------------
10413       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10414       implicit none
10415       double precision r,gamm,r_cut,r0,rlamb,rr
10416       rr = dabs(r-r0)
10417       if(rr.lt.r_cut-rlamb) then
10418         sscalgrad2=0.0d0
10419       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10420         gamm=(rr-(r_cut-rlamb))/rlamb
10421         if (r.ge.r0) then
10422           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10423         else
10424           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10425         endif
10426       else
10427         sscalgrad2=0.0d0
10428       endif
10429       return
10430       end
10431 c----------------------------------------------------------------------------
10432       subroutine e_saxs(Esaxs_constr)
10433       implicit none
10434       include 'DIMENSIONS'
10435       include 'DIMENSIONS.ZSCOPT'
10436       include 'DIMENSIONS.FREE'
10437 #ifdef MPI
10438       include "mpif.h"
10439       include "COMMON.SETUP"
10440       integer IERR
10441 #endif
10442       include 'COMMON.SBRIDGE'
10443       include 'COMMON.CHAIN'
10444       include 'COMMON.GEO'
10445       include 'COMMON.LOCAL'
10446       include 'COMMON.INTERACT'
10447       include 'COMMON.VAR'
10448       include 'COMMON.IOUNITS'
10449       include 'COMMON.DERIV'
10450       include 'COMMON.CONTROL'
10451       include 'COMMON.NAMES'
10452       include 'COMMON.FFIELD'
10453       include 'COMMON.LANGEVIN'
10454       include 'COMMON.SAXS'
10455 c
10456       double precision Esaxs_constr
10457       integer i,iint,j,k,l
10458       double precision PgradC(maxSAXS,3,maxres),
10459      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10460 #ifdef MPI
10461       double precision PgradC_(maxSAXS,3,maxres),
10462      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10463 #endif
10464       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10465      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10466      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10467      & auxX,auxX1,CACAgrad,Cnorm
10468       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10469       double precision dist
10470       external dist
10471 c  SAXS restraint penalty function
10472 #ifdef DEBUG
10473       write(iout,*) "------- SAXS penalty function start -------"
10474       write (iout,*) "nsaxs",nsaxs
10475       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10476       write (iout,*) "Psaxs"
10477       do i=1,nsaxs
10478         write (iout,'(i5,e15.5)') i, Psaxs(i)
10479       enddo
10480 #endif
10481       Esaxs_constr = 0.0d0
10482       do k=1,nsaxs
10483         Pcalc(k)=0.0d0
10484         do j=1,nres
10485           do l=1,3
10486             PgradC(k,l,j)=0.0d0
10487             PgradX(k,l,j)=0.0d0
10488           enddo
10489         enddo
10490       enddo
10491       do i=iatsc_s,iatsc_e
10492        if (itype(i).eq.ntyp1) cycle
10493        do iint=1,nint_gr(i)
10494          do j=istart(i,iint),iend(i,iint)
10495            if (itype(j).eq.ntyp1) cycle
10496 #ifdef ALLSAXS
10497            dijCACA=dist(i,j)
10498            dijCASC=dist(i,j+nres)
10499            dijSCCA=dist(i+nres,j)
10500            dijSCSC=dist(i+nres,j+nres)
10501            sigma2CACA=2.0d0/(pstok**2)
10502            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10503            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10504            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10505            do k=1,nsaxs
10506              dk = distsaxs(k)
10507              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10508              if (itype(j).ne.10) then
10509              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10510              else
10511              endif
10512              expCASC = 0.0d0
10513              if (itype(i).ne.10) then
10514              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10515              else
10516              expSCCA = 0.0d0
10517              endif
10518              if (itype(i).ne.10 .and. itype(j).ne.10) then
10519              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10520              else
10521              expSCSC = 0.0d0
10522              endif
10523              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10524 #ifdef DEBUG
10525              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10526 #endif
10527              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10528              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10529              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10530              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10531              do l=1,3
10532 c CA CA
10533                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10534                PgradC(k,l,i) = PgradC(k,l,i)-aux
10535                PgradC(k,l,j) = PgradC(k,l,j)+aux
10536 c CA SC
10537                if (itype(j).ne.10) then
10538                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10539                PgradC(k,l,i) = PgradC(k,l,i)-aux
10540                PgradC(k,l,j) = PgradC(k,l,j)+aux
10541                PgradX(k,l,j) = PgradX(k,l,j)+aux
10542                endif
10543 c SC CA
10544                if (itype(i).ne.10) then
10545                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10546                PgradX(k,l,i) = PgradX(k,l,i)-aux
10547                PgradC(k,l,i) = PgradC(k,l,i)-aux
10548                PgradC(k,l,j) = PgradC(k,l,j)+aux
10549                endif
10550 c SC SC
10551                if (itype(i).ne.10 .and. itype(j).ne.10) then
10552                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10553                PgradC(k,l,i) = PgradC(k,l,i)-aux
10554                PgradC(k,l,j) = PgradC(k,l,j)+aux
10555                PgradX(k,l,i) = PgradX(k,l,i)-aux
10556                PgradX(k,l,j) = PgradX(k,l,j)+aux
10557                endif
10558              enddo ! l
10559            enddo ! k
10560 #else
10561            dijCACA=dist(i,j)
10562            sigma2CACA=scal_rad**2*0.25d0/
10563      &        (restok(itype(j))**2+restok(itype(i))**2)
10564
10565            IF (saxs_cutoff.eq.0) THEN
10566            do k=1,nsaxs
10567              dk = distsaxs(k)
10568              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10569              Pcalc(k) = Pcalc(k)+expCACA
10570              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10571              do l=1,3
10572                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10573                PgradC(k,l,i) = PgradC(k,l,i)-aux
10574                PgradC(k,l,j) = PgradC(k,l,j)+aux
10575              enddo ! l
10576            enddo ! k
10577            ELSE
10578            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10579            do k=1,nsaxs
10580              dk = distsaxs(k)
10581 c             write (2,*) "ijk",i,j,k
10582              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10583              if (sss2.eq.0.0d0) cycle
10584              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10585              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10586              Pcalc(k) = Pcalc(k)+expCACA
10587 #ifdef DEBUG
10588              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10589 #endif
10590              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10591      &             ssgrad2*expCACA/sss2
10592              do l=1,3
10593 c CA CA
10594                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10595                PgradC(k,l,i) = PgradC(k,l,i)+aux
10596                PgradC(k,l,j) = PgradC(k,l,j)-aux
10597              enddo ! l
10598            enddo ! k
10599            ENDIF
10600 #endif
10601          enddo ! j
10602        enddo ! iint
10603       enddo ! i
10604 #ifdef MPI
10605       if (nfgtasks.gt.1) then
10606         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10607      &    MPI_SUM,king,FG_COMM,IERR)
10608         if (fg_rank.eq.king) then
10609           do k=1,nsaxs
10610             Pcalc(k) = Pcalc_(k)
10611           enddo
10612         endif
10613         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10614      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10615         if (fg_rank.eq.king) then
10616           do i=1,nres
10617             do l=1,3
10618               do k=1,nsaxs
10619                 PgradC(k,l,i) = PgradC_(k,l,i)
10620               enddo
10621             enddo
10622           enddo
10623         endif
10624 #ifdef ALLSAXS
10625         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10626      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10627         if (fg_rank.eq.king) then
10628           do i=1,nres
10629             do l=1,3
10630               do k=1,nsaxs
10631                 PgradX(k,l,i) = PgradX_(k,l,i)
10632               enddo
10633             enddo
10634           enddo
10635         endif
10636 #endif
10637       endif
10638 #endif
10639 #ifdef MPI
10640       if (fg_rank.eq.king) then
10641 #endif
10642       Cnorm = 0.0d0
10643       do k=1,nsaxs
10644         Cnorm = Cnorm + Pcalc(k)
10645       enddo
10646       Esaxs_constr = dlog(Cnorm)-wsaxs0
10647       do k=1,nsaxs
10648         if (Pcalc(k).gt.0.0d0)
10649      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10650 #ifdef DEBUG
10651         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10652 #endif
10653       enddo
10654 #ifdef DEBUG
10655       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10656 #endif
10657       do i=nnt,nct
10658         do l=1,3
10659           auxC=0.0d0
10660           auxC1=0.0d0
10661           auxX=0.0d0
10662           auxX1=0.d0
10663           do k=1,nsaxs
10664             if (Pcalc(k).gt.0)
10665      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10666             auxC1 = auxC1+PgradC(k,l,i)
10667 #ifdef ALLSAXS
10668             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10669             auxX1 = auxX1+PgradX(k,l,i)
10670 #endif
10671           enddo
10672           gsaxsC(l,i) = auxC - auxC1/Cnorm
10673 #ifdef ALLSAXS
10674           gsaxsX(l,i) = auxX - auxX1/Cnorm
10675 #endif
10676 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10677 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10678         enddo
10679       enddo
10680 #ifdef MPI
10681       endif
10682 #endif
10683       return
10684       end
10685 c----------------------------------------------------------------------------
10686       subroutine e_saxsC(Esaxs_constr)
10687       implicit none
10688       include 'DIMENSIONS'
10689       include 'DIMENSIONS.ZSCOPT'
10690       include 'DIMENSIONS.FREE'
10691 #ifdef MPI
10692       include "mpif.h"
10693       include "COMMON.SETUP"
10694       integer IERR
10695 #endif
10696       include 'COMMON.SBRIDGE'
10697       include 'COMMON.CHAIN'
10698       include 'COMMON.GEO'
10699       include 'COMMON.LOCAL'
10700       include 'COMMON.INTERACT'
10701       include 'COMMON.VAR'
10702       include 'COMMON.IOUNITS'
10703       include 'COMMON.DERIV'
10704       include 'COMMON.CONTROL'
10705       include 'COMMON.NAMES'
10706       include 'COMMON.FFIELD'
10707       include 'COMMON.LANGEVIN'
10708       include 'COMMON.SAXS'
10709 c
10710       double precision Esaxs_constr
10711       integer i,iint,j,k,l
10712       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10713 #ifdef MPI
10714       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10715 #endif
10716       double precision dk,dijCASPH,dijSCSPH,
10717      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10718      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10719      & auxX,auxX1,Cnorm
10720 c  SAXS restraint penalty function
10721 #ifdef DEBUG
10722       write(iout,*) "------- SAXS penalty function start -------"
10723       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10724      & " isaxs_end",isaxs_end
10725       write (iout,*) "nnt",nnt," ntc",nct
10726       do i=nnt,nct
10727         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10728      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10729       enddo
10730       do i=nnt,nct
10731         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10732       enddo
10733 #endif
10734       Esaxs_constr = 0.0d0
10735       logPtot=0.0d0
10736       do j=isaxs_start,isaxs_end
10737         Pcalc=0.0d0
10738         do i=1,nres
10739           do l=1,3
10740             PgradC(l,i)=0.0d0
10741             PgradX(l,i)=0.0d0
10742           enddo
10743         enddo
10744         do i=nnt,nct
10745           dijCASPH=0.0d0
10746           dijSCSPH=0.0d0
10747           do l=1,3
10748             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10749           enddo
10750           if (itype(i).ne.10) then
10751           do l=1,3
10752             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10753           enddo
10754           endif
10755           sigma2CA=2.0d0/pstok**2
10756           sigma2SC=4.0d0/restok(itype(i))**2
10757           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10758           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10759           Pcalc = Pcalc+expCASPH+expSCSPH
10760 #ifdef DEBUG
10761           write(*,*) "processor i j Pcalc",
10762      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10763 #endif
10764           CASPHgrad = sigma2CA*expCASPH
10765           SCSPHgrad = sigma2SC*expSCSPH
10766           do l=1,3
10767             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10768             PgradX(l,i) = PgradX(l,i) + aux
10769             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10770           enddo ! l
10771         enddo ! i
10772         do i=nnt,nct
10773           do l=1,3
10774             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10775             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10776           enddo
10777         enddo
10778         logPtot = logPtot - dlog(Pcalc)
10779 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10780 c     &    " logPtot",logPtot
10781       enddo ! j
10782 #ifdef MPI
10783       if (nfgtasks.gt.1) then
10784 c        write (iout,*) "logPtot before reduction",logPtot
10785         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10786      &    MPI_SUM,king,FG_COMM,IERR)
10787         logPtot = logPtot_
10788 c        write (iout,*) "logPtot after reduction",logPtot
10789         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10790      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10791         if (fg_rank.eq.king) then
10792           do i=1,nres
10793             do l=1,3
10794               gsaxsC(l,i) = gsaxsC_(l,i)
10795             enddo
10796           enddo
10797         endif
10798         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10800         if (fg_rank.eq.king) then
10801           do i=1,nres
10802             do l=1,3
10803               gsaxsX(l,i) = gsaxsX_(l,i)
10804             enddo
10805           enddo
10806         endif
10807       endif
10808 #endif
10809       Esaxs_constr = logPtot
10810       return
10811       end
10812