source/wham/src-M-SAXS-homology/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C      write(iout,*) 'po elektostatyce'
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 continue
  51       call vec_and_deriv
  52       if (shield_mode.eq.1) then
  53        call set_shield_fac
  54       else if  (shield_mode.eq.2) then
  55        call set_shield_fac2
  56       endif
  57       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  58 C            write(iout,*) 'po eelec'
  59
  60 C Calculate excluded-volume interaction energy between peptide groups
  61 C and side chains.
  62 C
  63       call escp(evdw2,evdw2_14)
  64 c
  65 c Calculate the bond-stretching energy
  66 c
  67
  68       call ebond(estr)
  69 C       write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79 C      print *,'Bend energy finished.'
  80       if (wang.gt.0d0) then
  81        if (tor_mode.eq.0) then
  82          call ebend(ebe)
  83        else
  84 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  85 C energy function
  86          call ebend_kcc(ebe)
  87        endif
  88       else
  89         ebe=0.0d0
  90       endif
  91       ethetacnstr=0.0d0
  92       if (with_theta_constr) call etheta_constr(ethetacnstr)
  93 c      call ebend(ebe,ethetacnstr)
  94 cd    print *,'Bend energy finished.'
  95 C
  96 C Calculate the SC local energy.
  97 C
  98       call esc(escloc)
  99 C       print *,'SCLOC energy finished.'
 100 C
 101 C Calculate the virtual-bond torsional energy.
 102 C
 103       if (wtor.gt.0.0d0) then
 104          if (tor_mode.eq.0) then
 105            call etor(etors,fact(1))
 106          else
 107 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 108 C energy function
 109            call etor_kcc(etors,fact(1))
 110          endif
 111       else
 112         etors=0.0d0
 113       endif
 114       edihcnstr=0.0d0
 115       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 116 c      print *,"Processor",myrank," computed Utor"
 117 C
 118 C 6/23/01 Calculate double-torsional energy
 119 C
 120       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 121         call etor_d(etors_d,fact(2))
 122       else
 123         etors_d=0
 124       endif
 125 c      print *,"Processor",myrank," computed Utord"
 126 C
 127       call eback_sc_corr(esccor)
 128
 129       if (wliptran.gt.0) then
 130         call Eliptransfer(eliptran)
 131       endif
 132
 133 C
 134 C 12/1/95 Multi-body terms
 135 C
 136       n_corr=0
 137       n_corr1=0
 138       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 139      &    .or. wturn6.gt.0.0d0) then
 140 c         write(iout,*)"calling multibody_eello"
 141          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 142 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 143 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 144       else
 145          ecorr=0.0d0
 146          ecorr5=0.0d0
 147          ecorr6=0.0d0
 148          eturn6=0.0d0
 149       endif
 150       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 151 c         write (iout,*) "Calling multibody_hbond"
 152          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 153       endif
 154 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 155       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 156         call e_saxs(Esaxs_constr)
 157 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 158       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 159         call e_saxsC(Esaxs_constr)
 160 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 161       else
 162         Esaxs_constr = 0.0d0
 163       endif
 164
 165 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 166       if (constr_homology.ge.1) then
 167         call e_modeller(ehomology_constr)
 168       else
 169         ehomology_constr=0.0d0
 170       endif
 171
 172 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 173 #ifdef DFA
 174 C     BARTEK for dfa test!
 175       if (wdfa_dist.gt.0) call edfad(edfadis)
 176 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 177       if (wdfa_tor.gt.0) call edfat(edfator)
 178 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 179       if (wdfa_nei.gt.0) call edfan(edfanei)
 180 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 181       if (wdfa_beta.gt.0) call edfab(edfabet)
 182 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 183 #endif
 184
 185 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 186 #ifdef SPLITELE
 187       if (shield_mode.gt.0) then
 188       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 189      & +welec*fact(1)*ees
 190      & +fact(1)*wvdwpp*evdw1
 191      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 192      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 193      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 194      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 195      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 196      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 197      & +wliptran*eliptran*esaxs_constr
 198      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 199      & +wdfa_beta*edfabet
 200       else
 201       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 202      & +wvdwpp*evdw1
 203      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 204      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 205      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 206      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 207      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 208      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 209      & +wliptran*eliptran+wsaxs*esaxs_constr
 210      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 211      & +wdfa_beta*edfabet
 212       endif
 213 #else
 214       if (shield_mode.gt.0) then
 215       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 216      & +welec*fact(1)*(ees+evdw1)
 217      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 218      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 219      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 220      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 221      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 222      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 223      & +wliptran*eliptran+wsaxs*esaxs_constr
 224      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 225      & +wdfa_beta*edfabet
 226       else
 227       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 228      & +welec*fact(1)*(ees+evdw1)
 229      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 230      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 231      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 232      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 233      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 234      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 235      & +wliptran*eliptran+wsaxs*esaxs_constr
 236      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 237      & +wdfa_beta*edfabet
 238       endif
 239 #endif
 240       energia(0)=etot
 241       energia(1)=evdw
 242 #ifdef SCP14
 243       energia(2)=evdw2-evdw2_14
 244       energia(17)=evdw2_14
 245 #else
 246       energia(2)=evdw2
 247       energia(17)=0.0d0
 248 #endif
 249 #ifdef SPLITELE
 250       energia(3)=ees
 251       energia(16)=evdw1
 252 #else
 253       energia(3)=ees+evdw1
 254       energia(16)=0.0d0
 255 #endif
 256       energia(4)=ecorr
 257       energia(5)=ecorr5
 258       energia(6)=ecorr6
 259       energia(7)=eel_loc
 260       energia(8)=eello_turn3
 261       energia(9)=eello_turn4
 262       energia(10)=eturn6
 263       energia(11)=ebe
 264       energia(12)=escloc
 265       energia(13)=etors
 266       energia(14)=etors_d
 267       energia(15)=ehpb
 268       energia(18)=estr
 269       energia(19)=esccor
 270       energia(20)=edihcnstr
 271       energia(21)=evdw_t
 272       energia(22)=eliptran
 273       energia(24)=ethetacnstr
 274       energia(26)=esaxs_constr
 275       energia(27)=ehomology_constr
 276       energia(28)=edfadis
 277       energia(29)=edfator
 278       energia(30)=edfanei
 279       energia(31)=edfabet
 280 c detecting NaNQ
 281 #ifdef ISNAN
 282 #ifdef AIX
 283       if (isnan(etot).ne.0) energia(0)=1.0d+99
 284 #else
 285       if (isnan(etot)) energia(0)=1.0d+99
 286 #endif
 287 #else
 288       i=0
 289 #ifdef WINPGI
 290       idumm=proc_proc(etot,i)
 291 #else
 292       call proc_proc(etot,i)
 293 #endif
 294       if(i.eq.1)energia(0)=1.0d+99
 295 #endif
 296 #ifdef MPL
 297 c     endif
 298 #endif
 299 #ifdef DEBUG
 300       call enerprint(energia,fact)
 301 #endif
 302       if (calc_grad) then
 303 C
 304 C Sum up the components of the Cartesian gradient.
 305 C
 306 #ifdef SPLITELE
 307       do i=1,nct
 308         do j=1,3
 309       if (shield_mode.eq.0) then
 310           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 311      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 312      &                wbond*gradb(j,i)+
 313      &                wstrain*ghpbc(j,i)+
 314      &                wcorr*fact(3)*gradcorr(j,i)+
 315      &                wel_loc*fact(2)*gel_loc(j,i)+
 316      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 317      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 318      &                wcorr5*fact(4)*gradcorr5(j,i)+
 319      &                wcorr6*fact(5)*gradcorr6(j,i)+
 320      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 321      &                wsccor*fact(2)*gsccorc(j,i)+
 322      &                wliptran*gliptranc(j,i)+
 323      &                wdfa_dist*gdfad(j,i)+
 324      &                wdfa_tor*gdfat(j,i)+
 325      &                wdfa_nei*gdfan(j,i)+
 326      &                wdfa_beta*gdfab(j,i)
 327           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 328      &                  wbond*gradbx(j,i)+
 329      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 330      &                  wsccor*fact(2)*gsccorx(j,i)
 331      &                 +wliptran*gliptranx(j,i)
 332         else
 333           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 334      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 335      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 336      &                wbond*gradb(j,i)+
 337      &                wstrain*ghpbc(j,i)+
 338      &                wcorr*fact(3)*gradcorr(j,i)+
 339      &                wel_loc*fact(2)*gel_loc(j,i)+
 340      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 341      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 342      &                wcorr5*fact(4)*gradcorr5(j,i)+
 343      &                wcorr6*fact(5)*gradcorr6(j,i)+
 344      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 345      &                wsccor*fact(2)*gsccorc(j,i)
 346      &               +wliptran*gliptranc(j,i)
 347      &                 +welec*gshieldc(j,i)
 348      &                 +welec*gshieldc_loc(j,i)
 349      &                 +wcorr*gshieldc_ec(j,i)
 350      &                 +wcorr*gshieldc_loc_ec(j,i)
 351      &                 +wturn3*gshieldc_t3(j,i)
 352      &                 +wturn3*gshieldc_loc_t3(j,i)
 353      &                 +wturn4*gshieldc_t4(j,i)
 354      &                 +wturn4*gshieldc_loc_t4(j,i)
 355      &                 +wel_loc*gshieldc_ll(j,i)
 356      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 357      &                wdfa_dist*gdfad(j,i)+
 358      &                wdfa_tor*gdfat(j,i)+
 359      &                wdfa_nei*gdfan(j,i)+
 360      &                wdfa_beta*gdfab(j,i)
 361           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 362      &                 +fact(1)*wscp*gradx_scp(j,i)+
 363      &                  wbond*gradbx(j,i)+
 364      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 365      &                  wsccor*fact(2)*gsccorx(j,i)
 366      &                 +wliptran*gliptranx(j,i)
 367      &                 +welec*gshieldx(j,i)
 368      &                 +wcorr*gshieldx_ec(j,i)
 369      &                 +wturn3*gshieldx_t3(j,i)
 370      &                 +wturn4*gshieldx_t4(j,i)
 371      &                 +wel_loc*gshieldx_ll(j,i)
 372         endif
 373         enddo
 374 #else
 375       do i=1,nct
 376         do j=1,3
 377                 if (shield_mode.eq.0) then
 378           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 379      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 380      &                wbond*gradb(j,i)+
 381      &                wcorr*fact(3)*gradcorr(j,i)+
 382      &                wel_loc*fact(2)*gel_loc(j,i)+
 383      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 384      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 385      &                wcorr5*fact(4)*gradcorr5(j,i)+
 386      &                wcorr6*fact(5)*gradcorr6(j,i)+
 387      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 388      &                wsccor*fact(2)*gsccorc(j,i)
 389      &               +wliptran*gliptranc(j,i)+
 390      &                wdfa_dist*gdfad(j,i)+
 391      &                wdfa_tor*gdfat(j,i)+
 392      &                wdfa_nei*gdfan(j,i)+
 393      &                wdfa_beta*gdfab(j,i)
 394
 395           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 396      &                  wbond*gradbx(j,i)+
 397      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 398      &                  wsccor*fact(1)*gsccorx(j,i)
 399      &                 +wliptran*gliptranx(j,i)
 400               else
 401           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 402      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 403      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 404      &                wbond*gradb(j,i)+
 405      &                wcorr*fact(3)*gradcorr(j,i)+
 406      &                wel_loc*fact(2)*gel_loc(j,i)+
 407      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 408      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 409      &                wcorr5*fact(4)*gradcorr5(j,i)+
 410      &                wcorr6*fact(5)*gradcorr6(j,i)+
 411      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 412      &                wsccor*fact(2)*gsccorc(j,i)
 413      &               +wliptran*gliptranc(j,i)
 414      &                 +welec*gshieldc(j,i)
 415      &                 +welec*gshieldc_loc(j,i)
 416      &                 +wcorr*gshieldc_ec(j,i)
 417      &                 +wcorr*gshieldc_loc_ec(j,i)
 418      &                 +wturn3*gshieldc_t3(j,i)
 419      &                 +wturn3*gshieldc_loc_t3(j,i)
 420      &                 +wturn4*gshieldc_t4(j,i)
 421      &                 +wturn4*gshieldc_loc_t4(j,i)
 422      &                 +wel_loc*gshieldc_ll(j,i)
 423      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 424      &                wdfa_dist*gdfad(j,i)+
 425      &                wdfa_tor*gdfat(j,i)+
 426      &                wdfa_nei*gdfan(j,i)+
 427      &                wdfa_beta*gdfab(j,i)
 428           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 429      &                  fact(1)*wscp*gradx_scp(j,i)+
 430      &                  wbond*gradbx(j,i)+
 431      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 432      &                  wsccor*fact(1)*gsccorx(j,i)
 433      &                 +wliptran*gliptranx(j,i)
 434      &                 +welec*gshieldx(j,i)
 435      &                 +wcorr*gshieldx_ec(j,i)
 436      &                 +wturn3*gshieldx_t3(j,i)
 437      &                 +wturn4*gshieldx_t4(j,i)
 438      &                 +wel_loc*gshieldx_ll(j,i)
 439
 440          endif
 441         enddo
 442 #endif
 443       enddo
 444
 445
 446       do i=1,nres-3
 447         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 448      &   +wcorr5*fact(4)*g_corr5_loc(i)
 449      &   +wcorr6*fact(5)*g_corr6_loc(i)
 450      &   +wturn4*fact(3)*gel_loc_turn4(i)
 451      &   +wturn3*fact(2)*gel_loc_turn3(i)
 452      &   +wturn6*fact(5)*gel_loc_turn6(i)
 453      &   +wel_loc*fact(2)*gel_loc_loc(i)
 454 c     &   +wsccor*fact(1)*gsccor_loc(i)
 455 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 456       enddo
 457       endif
 458       if (dyn_ss) call dyn_set_nss
 459       return
 460       end
 461 C------------------------------------------------------------------------
 462       subroutine enerprint(energia,fact)
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465       include 'DIMENSIONS.ZSCOPT'
 466       include 'COMMON.IOUNITS'
 467       include 'COMMON.FFIELD'
 468       include 'COMMON.SBRIDGE'
 469       include 'COMMON.CONTROL'
 470       double precision energia(0:max_ene),fact(6)
 471       etot=energia(0)
 472       evdw=energia(1)+fact(6)*energia(21)
 473 #ifdef SCP14
 474       evdw2=energia(2)+energia(17)
 475 #else
 476       evdw2=energia(2)
 477 #endif
 478       ees=energia(3)
 479 #ifdef SPLITELE
 480       evdw1=energia(16)
 481 #endif
 482       ecorr=energia(4)
 483       ecorr5=energia(5)
 484       ecorr6=energia(6)
 485       eel_loc=energia(7)
 486       eello_turn3=energia(8)
 487       eello_turn4=energia(9)
 488       eello_turn6=energia(10)
 489       ebe=energia(11)
 490       escloc=energia(12)
 491       etors=energia(13)
 492       etors_d=energia(14)
 493       ehpb=energia(15)
 494       esccor=energia(19)
 495       edihcnstr=energia(20)
 496       estr=energia(18)
 497       ethetacnstr=energia(24)
 498       eliptran=energia(22)
 499       esaxs=energia(26)
 500       ehomology_constr=energia(27)
 501 C     Bartek
 502       edfadis = energia(28)
 503       edfator = energia(29)
 504       edfanei = energia(30)
 505       edfabet = energia(31)
 506 #ifdef SPLITELE
 507       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 508      &  estr,wbond,ebe,wang,
 509      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 510      &  ecorr,wcorr,
 511      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 512      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
 513      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 514      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 515      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 516      &  edfabet,wdfa_beta,
 517      &  etot
 518    10 format (/'Virtual-chain energies:'//
 519      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 520      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 521      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 522      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 523      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 524      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 525      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 526      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 527      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 528      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 529      & ' (SS bridges & dist. cnstr.)'/
 530      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 531      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 532      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 533      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 534      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 535      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 536      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 537      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 538      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 539      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 540      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 541      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
 542      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 543      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 544      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
 545      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 546      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 547      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 548      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 549      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 550      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 551      & 'ETOT=  ',1pE16.6,' (total)')
 552
 553 #else
 554       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 555      &  estr,wbond,ebe,wang,
 556      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 557      &  ecorr,wcorr,
 558      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 559      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
 560      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 561      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 562      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 563      &  edfabet,wdfa_beta,
 564      &  etot
 565    10 format (/'Virtual-chain energies:'//
 566      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 567      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 568      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 569      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 570      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 571      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 572      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 573      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 574      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 575      & ' (SS bridges & dist. restr.)'/
 576      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 577      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 578      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 579      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 580      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 581      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 582      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 583      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 584      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 585      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 586      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 587      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
 588      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 589      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 590      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
 591      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 592      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 593      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 594      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 595      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 596      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 597      & 'ETOT=  ',1pE16.6,' (total)')
 598 #endif
 599       return
 600       end
 601 C-----------------------------------------------------------------------
 602       subroutine elj(evdw,evdw_t)
 603 C
 604 C This subroutine calculates the interaction energy of nonbonded side chains
 605 C assuming the LJ potential of interaction.
 606 C
 607       implicit real*8 (a-h,o-z)
 608       include 'DIMENSIONS'
 609       include 'DIMENSIONS.ZSCOPT'
 610       include "DIMENSIONS.COMPAR"
 611       parameter (accur=1.0d-10)
 612       include 'COMMON.GEO'
 613       include 'COMMON.VAR'
 614       include 'COMMON.LOCAL'
 615       include 'COMMON.CHAIN'
 616       include 'COMMON.DERIV'
 617       include 'COMMON.INTERACT'
 618       include 'COMMON.TORSION'
 619       include 'COMMON.ENEPS'
 620       include 'COMMON.SBRIDGE'
 621       include 'COMMON.NAMES'
 622       include 'COMMON.IOUNITS'
 623       include 'COMMON.CONTACTS'
 624       dimension gg(3)
 625       integer icant
 626       external icant
 627 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 628 c ROZNICA z cluster
 629       do i=1,210
 630         do j=1,2
 631           eneps_temp(j,i)=0.0d0
 632         enddo
 633       enddo
 634 cROZNICA
 635
 636       evdw=0.0D0
 637       evdw_t=0.0d0
 638       do i=iatsc_s,iatsc_e
 639         itypi=iabs(itype(i))
 640         if (itypi.eq.ntyp1) cycle
 641         itypi1=iabs(itype(i+1))
 642         xi=c(1,nres+i)
 643         yi=c(2,nres+i)
 644         zi=c(3,nres+i)
 645 C Change 12/1/95
 646         num_conti=0
 647 C
 648 C Calculate SC interaction energy.
 649 C
 650         do iint=1,nint_gr(i)
 651 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 652 cd   &                  'iend=',iend(i,iint)
 653           do j=istart(i,iint),iend(i,iint)
 654             itypj=iabs(itype(j))
 655             if (itypj.eq.ntyp1) cycle
 656             xj=c(1,nres+j)-xi
 657             yj=c(2,nres+j)-yi
 658             zj=c(3,nres+j)-zi
 659 C Change 12/1/95 to calculate four-body interactions
 660             rij=xj*xj+yj*yj+zj*zj
 661             rrij=1.0D0/rij
 662 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 663             eps0ij=eps(itypi,itypj)
 664             fac=rrij**expon2
 665             e1=fac*fac*aa
 666             e2=fac*bb
 667             evdwij=e1+e2
 668             ij=icant(itypi,itypj)
 669 c ROZNICA z cluster
 670             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 671             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 672 c
 673
 674 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 675 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 676 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 677 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 678 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 679 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 680             if (bb.gt.0.0d0) then
 681               evdw=evdw+evdwij
 682             else
 683               evdw_t=evdw_t+evdwij
 684             endif
 685             if (calc_grad) then
 686 C
 687 C Calculate the components of the gradient in DC and X
 688 C
 689             fac=-rrij*(e1+evdwij)
 690             gg(1)=xj*fac
 691             gg(2)=yj*fac
 692             gg(3)=zj*fac
 693             do k=1,3
 694               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 695               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 696             enddo
 697             do k=i,j-1
 698               do l=1,3
 699                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 700               enddo
 701             enddo
 702             endif
 703 C
 704 C 12/1/95, revised on 5/20/97
 705 C
 706 C Calculate the contact function. The ith column of the array JCONT will
 707 C contain the numbers of atoms that make contacts with the atom I (of numbers
 708 C greater than I). The arrays FACONT and GACONT will contain the values of
 709 C the contact function and its derivative.
 710 C
 711 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 712 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 713 C Uncomment next line, if the correlation interactions are contact function only
 714             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 715               rij=dsqrt(rij)
 716               sigij=sigma(itypi,itypj)
 717               r0ij=rs0(itypi,itypj)
 718 C
 719 C Check whether the SC's are not too far to make a contact.
 720 C
 721               rcut=1.5d0*r0ij
 722               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 723 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 724 C
 725               if (fcont.gt.0.0D0) then
 726 C If the SC-SC distance if close to sigma, apply spline.
 727 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 728 cAdam &             fcont1,fprimcont1)
 729 cAdam           fcont1=1.0d0-fcont1
 730 cAdam           if (fcont1.gt.0.0d0) then
 731 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 732 cAdam             fcont=fcont*fcont1
 733 cAdam           endif
 734 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 735 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 736 cga             do k=1,3
 737 cga               gg(k)=gg(k)*eps0ij
 738 cga             enddo
 739 cga             eps0ij=-evdwij*eps0ij
 740 C Uncomment for AL's type of SC correlation interactions.
 741 cadam           eps0ij=-evdwij
 742                 num_conti=num_conti+1
 743                 jcont(num_conti,i)=j
 744                 facont(num_conti,i)=fcont*eps0ij
 745                 fprimcont=eps0ij*fprimcont/rij
 746                 fcont=expon*fcont
 747 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 748 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 749 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 750 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 751                 gacont(1,num_conti,i)=-fprimcont*xj
 752                 gacont(2,num_conti,i)=-fprimcont*yj
 753                 gacont(3,num_conti,i)=-fprimcont*zj
 754 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 755 cd              write (iout,'(2i3,3f10.5)')
 756 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 757               endif
 758             endif
 759           enddo      ! j
 760         enddo        ! iint
 761 C Change 12/1/95
 762         num_cont(i)=num_conti
 763       enddo          ! i
 764       if (calc_grad) then
 765       do i=1,nct
 766         do j=1,3
 767           gvdwc(j,i)=expon*gvdwc(j,i)
 768           gvdwx(j,i)=expon*gvdwx(j,i)
 769         enddo
 770       enddo
 771       endif
 772 C******************************************************************************
 773 C
 774 C                              N O T E !!!
 775 C
 776 C To save time, the factor of EXPON has been extracted from ALL components
 777 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 778 C use!
 779 C
 780 C******************************************************************************
 781       return
 782       end
 783 C-----------------------------------------------------------------------------
 784       subroutine eljk(evdw,evdw_t)
 785 C
 786 C This subroutine calculates the interaction energy of nonbonded side chains
 787 C assuming the LJK potential of interaction.
 788 C
 789       implicit real*8 (a-h,o-z)
 790       include 'DIMENSIONS'
 791       include 'DIMENSIONS.ZSCOPT'
 792       include "DIMENSIONS.COMPAR"
 793       include 'COMMON.GEO'
 794       include 'COMMON.VAR'
 795       include 'COMMON.LOCAL'
 796       include 'COMMON.CHAIN'
 797       include 'COMMON.DERIV'
 798       include 'COMMON.INTERACT'
 799       include 'COMMON.ENEPS'
 800       include 'COMMON.IOUNITS'
 801       include 'COMMON.NAMES'
 802       dimension gg(3)
 803       logical scheck
 804       integer icant
 805       external icant
 806 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 807       do i=1,210
 808         do j=1,2
 809           eneps_temp(j,i)=0.0d0
 810         enddo
 811       enddo
 812       evdw=0.0D0
 813       evdw_t=0.0d0
 814       do i=iatsc_s,iatsc_e
 815         itypi=iabs(itype(i))
 816         if (itypi.eq.ntyp1) cycle
 817         itypi1=iabs(itype(i+1))
 818         xi=c(1,nres+i)
 819         yi=c(2,nres+i)
 820         zi=c(3,nres+i)
 821 C
 822 C Calculate SC interaction energy.
 823 C
 824         do iint=1,nint_gr(i)
 825           do j=istart(i,iint),iend(i,iint)
 826             itypj=iabs(itype(j))
 827             if (itypj.eq.ntyp1) cycle
 828             xj=c(1,nres+j)-xi
 829             yj=c(2,nres+j)-yi
 830             zj=c(3,nres+j)-zi
 831             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 832             fac_augm=rrij**expon
 833             e_augm=augm(itypi,itypj)*fac_augm
 834             r_inv_ij=dsqrt(rrij)
 835             rij=1.0D0/r_inv_ij
 836             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 837             fac=r_shift_inv**expon
 838             e1=fac*fac*aa
 839             e2=fac*bb
 840             evdwij=e_augm+e1+e2
 841             ij=icant(itypi,itypj)
 842             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 843      &        /dabs(eps(itypi,itypj))
 844             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 845 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 846 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 847 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 848 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 849 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 850 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 851 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 852             if (bb.gt.0.0d0) then
 853               evdw=evdw+evdwij
 854             else
 855               evdw_t=evdw_t+evdwij
 856             endif
 857             if (calc_grad) then
 858 C
 859 C Calculate the components of the gradient in DC and X
 860 C
 861             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 862             gg(1)=xj*fac
 863             gg(2)=yj*fac
 864             gg(3)=zj*fac
 865             do k=1,3
 866               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 867               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 868             enddo
 869             do k=i,j-1
 870               do l=1,3
 871                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 872               enddo
 873             enddo
 874             endif
 875           enddo      ! j
 876         enddo        ! iint
 877       enddo          ! i
 878       if (calc_grad) then
 879       do i=1,nct
 880         do j=1,3
 881           gvdwc(j,i)=expon*gvdwc(j,i)
 882           gvdwx(j,i)=expon*gvdwx(j,i)
 883         enddo
 884       enddo
 885       endif
 886       return
 887       end
 888 C-----------------------------------------------------------------------------
 889       subroutine ebp(evdw,evdw_t)
 890 C
 891 C This subroutine calculates the interaction energy of nonbonded side chains
 892 C assuming the Berne-Pechukas potential of interaction.
 893 C
 894       implicit real*8 (a-h,o-z)
 895       include 'DIMENSIONS'
 896       include 'DIMENSIONS.ZSCOPT'
 897       include "DIMENSIONS.COMPAR"
 898       include 'COMMON.GEO'
 899       include 'COMMON.VAR'
 900       include 'COMMON.LOCAL'
 901       include 'COMMON.CHAIN'
 902       include 'COMMON.DERIV'
 903       include 'COMMON.NAMES'
 904       include 'COMMON.INTERACT'
 905       include 'COMMON.ENEPS'
 906       include 'COMMON.IOUNITS'
 907       include 'COMMON.CALC'
 908       common /srutu/ icall
 909 c     double precision rrsave(maxdim)
 910       logical lprn
 911       integer icant
 912       external icant
 913       do i=1,210
 914         do j=1,2
 915           eneps_temp(j,i)=0.0d0
 916         enddo
 917       enddo
 918       evdw=0.0D0
 919       evdw_t=0.0d0
 920 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 921 c     if (icall.eq.0) then
 922 c       lprn=.true.
 923 c     else
 924         lprn=.false.
 925 c     endif
 926       ind=0
 927       do i=iatsc_s,iatsc_e
 928         itypi=iabs(itype(i))
 929         if (itypi.eq.ntyp1) cycle
 930         itypi1=iabs(itype(i+1))
 931         xi=c(1,nres+i)
 932         yi=c(2,nres+i)
 933         zi=c(3,nres+i)
 934         dxi=dc_norm(1,nres+i)
 935         dyi=dc_norm(2,nres+i)
 936         dzi=dc_norm(3,nres+i)
 937         dsci_inv=vbld_inv(i+nres)
 938 C
 939 C Calculate SC interaction energy.
 940 C
 941         do iint=1,nint_gr(i)
 942           do j=istart(i,iint),iend(i,iint)
 943             ind=ind+1
 944             itypj=iabs(itype(j))
 945             if (itypj.eq.ntyp1) cycle
 946             dscj_inv=vbld_inv(j+nres)
 947             chi1=chi(itypi,itypj)
 948             chi2=chi(itypj,itypi)
 949             chi12=chi1*chi2
 950             chip1=chip(itypi)
 951             chip2=chip(itypj)
 952             chip12=chip1*chip2
 953             alf1=alp(itypi)
 954             alf2=alp(itypj)
 955             alf12=0.5D0*(alf1+alf2)
 956 C For diagnostics only!!!
 957 c           chi1=0.0D0
 958 c           chi2=0.0D0
 959 c           chi12=0.0D0
 960 c           chip1=0.0D0
 961 c           chip2=0.0D0
 962 c           chip12=0.0D0
 963 c           alf1=0.0D0
 964 c           alf2=0.0D0
 965 c           alf12=0.0D0
 966             xj=c(1,nres+j)-xi
 967             yj=c(2,nres+j)-yi
 968             zj=c(3,nres+j)-zi
 969             dxj=dc_norm(1,nres+j)
 970             dyj=dc_norm(2,nres+j)
 971             dzj=dc_norm(3,nres+j)
 972             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 973 cd          if (icall.eq.0) then
 974 cd            rrsave(ind)=rrij
 975 cd          else
 976 cd            rrij=rrsave(ind)
 977 cd          endif
 978             rij=dsqrt(rrij)
 979 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 980             call sc_angular
 981 C Calculate whole angle-dependent part of epsilon and contributions
 982 C to its derivatives
 983             fac=(rrij*sigsq)**expon2
 984             e1=fac*fac*aa
 985             e2=fac*bb
 986             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 987             eps2der=evdwij*eps3rt
 988             eps3der=evdwij*eps2rt
 989             evdwij=evdwij*eps2rt*eps3rt
 990             ij=icant(itypi,itypj)
 991             aux=eps1*eps2rt**2*eps3rt**2
 992             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 993      &        /dabs(eps(itypi,itypj))
 994             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 995             if (bb.gt.0.0d0) then
 996               evdw=evdw+evdwij
 997             else
 998               evdw_t=evdw_t+evdwij
 999             endif
1000             if (calc_grad) then
1001             if (lprn) then
1002             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1003             epsi=bb**2/aa
1004             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1005      &        restyp(itypi),i,restyp(itypj),j,
1006      &        epsi,sigm,chi1,chi2,chip1,chip2,
1007      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1008      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1009      &        evdwij
1010             endif
1011 C Calculate gradient components.
1012             e1=e1*eps1*eps2rt**2*eps3rt**2
1013             fac=-expon*(e1+evdwij)
1014             sigder=fac/sigsq
1015             fac=rrij*fac
1016 C Calculate radial part of the gradient
1017             gg(1)=xj*fac
1018             gg(2)=yj*fac
1019             gg(3)=zj*fac
1020 C Calculate the angular part of the gradient and sum add the contributions
1021 C to the appropriate components of the Cartesian gradient.
1022             call sc_grad
1023             endif
1024           enddo      ! j
1025         enddo        ! iint
1026       enddo          ! i
1027 c     stop
1028       return
1029       end
1030 C-----------------------------------------------------------------------------
1031       subroutine egb(evdw,evdw_t)
1032 C
1033 C This subroutine calculates the interaction energy of nonbonded side chains
1034 C assuming the Gay-Berne potential of interaction.
1035 C
1036       implicit real*8 (a-h,o-z)
1037       include 'DIMENSIONS'
1038       include 'DIMENSIONS.ZSCOPT'
1039       include "DIMENSIONS.COMPAR"
1040       include 'COMMON.CONTROL'
1041       include 'COMMON.GEO'
1042       include 'COMMON.VAR'
1043       include 'COMMON.LOCAL'
1044       include 'COMMON.CHAIN'
1045       include 'COMMON.DERIV'
1046       include 'COMMON.NAMES'
1047       include 'COMMON.INTERACT'
1048       include 'COMMON.ENEPS'
1049       include 'COMMON.IOUNITS'
1050       include 'COMMON.CALC'
1051       include 'COMMON.SBRIDGE'
1052       logical lprn
1053       common /srutu/icall
1054       integer icant,xshift,yshift,zshift
1055       external icant
1056       do i=1,210
1057         do j=1,2
1058           eneps_temp(j,i)=0.0d0
1059         enddo
1060       enddo
1061 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       evdw_t=0.0d0
1064       lprn=.false.
1065 c      if (icall.gt.0) lprn=.true.
1066       ind=0
1067       do i=iatsc_s,iatsc_e
1068         itypi=iabs(itype(i))
1069         if (itypi.eq.ntyp1) cycle
1070         itypi1=iabs(itype(i+1))
1071         xi=c(1,nres+i)
1072         yi=c(2,nres+i)
1073         zi=c(3,nres+i)
1074 C returning the ith atom to box
1075           xi=mod(xi,boxxsize)
1076           if (xi.lt.0) xi=xi+boxxsize
1077           yi=mod(yi,boxysize)
1078           if (yi.lt.0) yi=yi+boxysize
1079           zi=mod(zi,boxzsize)
1080           if (zi.lt.0) zi=zi+boxzsize
1081        if ((zi.gt.bordlipbot)
1082      &.and.(zi.lt.bordliptop)) then
1083 C the energy transfer exist
1084         if (zi.lt.buflipbot) then
1085 C what fraction I am in
1086          fracinbuf=1.0d0-
1087      &        ((zi-bordlipbot)/lipbufthick)
1088 C lipbufthick is thickenes of lipid buffore
1089          sslipi=sscalelip(fracinbuf)
1090          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1091         elseif (zi.gt.bufliptop) then
1092          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1093          sslipi=sscalelip(fracinbuf)
1094          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1095         else
1096          sslipi=1.0d0
1097          ssgradlipi=0.0
1098         endif
1099        else
1100          sslipi=0.0d0
1101          ssgradlipi=0.0
1102        endif
1103
1104         dxi=dc_norm(1,nres+i)
1105         dyi=dc_norm(2,nres+i)
1106         dzi=dc_norm(3,nres+i)
1107         dsci_inv=vbld_inv(i+nres)
1108 C
1109 C Calculate SC interaction energy.
1110 C
1111         do iint=1,nint_gr(i)
1112           do j=istart(i,iint),iend(i,iint)
1113             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1114               call dyn_ssbond_ene(i,j,evdwij)
1115               evdw=evdw+evdwij
1116 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1117 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1118 C triple bond artifac removal
1119              do k=j+1,iend(i,iint)
1120 C search over all next residues
1121               if (dyn_ss_mask(k)) then
1122 C check if they are cysteins
1123 C              write(iout,*) 'k=',k
1124               call triple_ssbond_ene(i,j,k,evdwij)
1125 C call the energy function that removes the artifical triple disulfide
1126 C bond the soubroutine is located in ssMD.F
1127               evdw=evdw+evdwij
1128 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1129 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1130               endif!dyn_ss_mask(k)
1131              enddo! k
1132             ELSE
1133             ind=ind+1
1134             itypj=iabs(itype(j))
1135             if (itypj.eq.ntyp1) cycle
1136             dscj_inv=vbld_inv(j+nres)
1137             sig0ij=sigma(itypi,itypj)
1138             chi1=chi(itypi,itypj)
1139             chi2=chi(itypj,itypi)
1140             chi12=chi1*chi2
1141             chip1=chip(itypi)
1142             chip2=chip(itypj)
1143             chip12=chip1*chip2
1144             alf1=alp(itypi)
1145             alf2=alp(itypj)
1146             alf12=0.5D0*(alf1+alf2)
1147 C For diagnostics only!!!
1148 c           chi1=0.0D0
1149 c           chi2=0.0D0
1150 c           chi12=0.0D0
1151 c           chip1=0.0D0
1152 c           chip2=0.0D0
1153 c           chip12=0.0D0
1154 c           alf1=0.0D0
1155 c           alf2=0.0D0
1156 c           alf12=0.0D0
1157             xj=c(1,nres+j)
1158             yj=c(2,nres+j)
1159             zj=c(3,nres+j)
1160 C returning jth atom to box
1161           xj=mod(xj,boxxsize)
1162           if (xj.lt.0) xj=xj+boxxsize
1163           yj=mod(yj,boxysize)
1164           if (yj.lt.0) yj=yj+boxysize
1165           zj=mod(zj,boxzsize)
1166           if (zj.lt.0) zj=zj+boxzsize
1167        if ((zj.gt.bordlipbot)
1168      &.and.(zj.lt.bordliptop)) then
1169 C the energy transfer exist
1170         if (zj.lt.buflipbot) then
1171 C what fraction I am in
1172          fracinbuf=1.0d0-
1173      &        ((zj-bordlipbot)/lipbufthick)
1174 C lipbufthick is thickenes of lipid buffore
1175          sslipj=sscalelip(fracinbuf)
1176          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1177         elseif (zj.gt.bufliptop) then
1178          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1179          sslipj=sscalelip(fracinbuf)
1180          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1181         else
1182          sslipj=1.0d0
1183          ssgradlipj=0.0
1184         endif
1185        else
1186          sslipj=0.0d0
1187          ssgradlipj=0.0
1188        endif
1189       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1190      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1191       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1192      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1193 C       if (aa.ne.aa_aq(itypi,itypj)) then
1194
1195 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1196 C     & bb_aq(itypi,itypj)-bb,
1197 C     & sslipi,sslipj
1198 C         endif
1199
1200 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1201 C checking the distance
1202       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1203       xj_safe=xj
1204       yj_safe=yj
1205       zj_safe=zj
1206       subchap=0
1207 C finding the closest
1208       do xshift=-1,1
1209       do yshift=-1,1
1210       do zshift=-1,1
1211           xj=xj_safe+xshift*boxxsize
1212           yj=yj_safe+yshift*boxysize
1213           zj=zj_safe+zshift*boxzsize
1214           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1215           if(dist_temp.lt.dist_init) then
1216             dist_init=dist_temp
1217             xj_temp=xj
1218             yj_temp=yj
1219             zj_temp=zj
1220             subchap=1
1221           endif
1222        enddo
1223        enddo
1224        enddo
1225        if (subchap.eq.1) then
1226           xj=xj_temp-xi
1227           yj=yj_temp-yi
1228           zj=zj_temp-zi
1229        else
1230           xj=xj_safe-xi
1231           yj=yj_safe-yi
1232           zj=zj_safe-zi
1233        endif
1234
1235             dxj=dc_norm(1,nres+j)
1236             dyj=dc_norm(2,nres+j)
1237             dzj=dc_norm(3,nres+j)
1238 c            write (iout,*) i,j,xj,yj,zj
1239             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1240             rij=dsqrt(rrij)
1241             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1242             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1243             if (sss.le.0.0) cycle
1244 C Calculate angle-dependent terms of energy and contributions to their
1245 C derivatives.
1246
1247             call sc_angular
1248             sigsq=1.0D0/sigsq
1249             sig=sig0ij*dsqrt(sigsq)
1250             rij_shift=1.0D0/rij-sig+sig0ij
1251 C I hate to put IF's in the loops, but here don't have another choice!!!!
1252             if (rij_shift.le.0.0D0) then
1253               evdw=1.0D20
1254               return
1255             endif
1256             sigder=-sig*sigsq
1257 c---------------------------------------------------------------
1258             rij_shift=1.0D0/rij_shift
1259             fac=rij_shift**expon
1260             e1=fac*fac*aa
1261             e2=fac*bb
1262             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1263             eps2der=evdwij*eps3rt
1264             eps3der=evdwij*eps2rt
1265             evdwij=evdwij*eps2rt*eps3rt
1266             if (bb.gt.0) then
1267               evdw=evdw+evdwij*sss
1268             else
1269               evdw_t=evdw_t+evdwij*sss
1270             endif
1271             ij=icant(itypi,itypj)
1272             aux=eps1*eps2rt**2*eps3rt**2
1273             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1274      &        /dabs(eps(itypi,itypj))
1275             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1276 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1277 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1278 c     &         aux*e2/eps(itypi,itypj)
1279 c            if (lprn) then
1280             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1281             epsi=bb**2/aa
1282 c#define DEBUG
1283 #ifdef DEBUG
1284             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1285      &        restyp(itypi),i,restyp(itypj),j,
1286      &        epsi,sigm,chi1,chi2,chip1,chip2,
1287      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1288      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1289      &        evdwij
1290              write (iout,*) "partial sum", evdw, evdw_t
1291 #endif
1292 c#undef DEBUG
1293 c            endif
1294             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1295      &                        'evdw',i,j,evdwij
1296             if (calc_grad) then
1297 C Calculate gradient components.
1298             e1=e1*eps1*eps2rt**2*eps3rt**2
1299             fac=-expon*(e1+evdwij)*rij_shift
1300             sigder=fac*sigder
1301             fac=rij*fac
1302             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1303 C Calculate the radial part of the gradient
1304             gg(1)=xj*fac
1305             gg(2)=yj*fac
1306             gg(3)=zj*fac
1307 C Calculate angular part of the gradient.
1308             call sc_grad
1309             endif
1310 C            write(iout,*)  "partial sum", evdw, evdw_t
1311             ENDIF    ! dyn_ss
1312           enddo      ! j
1313         enddo        ! iint
1314       enddo          ! i
1315       return
1316       end
1317 C-----------------------------------------------------------------------------
1318       subroutine egbv(evdw,evdw_t)
1319 C
1320 C This subroutine calculates the interaction energy of nonbonded side chains
1321 C assuming the Gay-Berne-Vorobjev potential of interaction.
1322 C
1323       implicit real*8 (a-h,o-z)
1324       include 'DIMENSIONS'
1325       include 'DIMENSIONS.ZSCOPT'
1326       include "DIMENSIONS.COMPAR"
1327       include 'COMMON.GEO'
1328       include 'COMMON.VAR'
1329       include 'COMMON.LOCAL'
1330       include 'COMMON.CHAIN'
1331       include 'COMMON.DERIV'
1332       include 'COMMON.NAMES'
1333       include 'COMMON.INTERACT'
1334       include 'COMMON.ENEPS'
1335       include 'COMMON.IOUNITS'
1336       include 'COMMON.CALC'
1337       common /srutu/ icall
1338       logical lprn
1339       integer icant
1340       external icant
1341       do i=1,210
1342         do j=1,2
1343           eneps_temp(j,i)=0.0d0
1344         enddo
1345       enddo
1346       evdw=0.0D0
1347       evdw_t=0.0d0
1348 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1349       evdw=0.0D0
1350       lprn=.false.
1351 c      if (icall.gt.0) lprn=.true.
1352       ind=0
1353       do i=iatsc_s,iatsc_e
1354         itypi=iabs(itype(i))
1355         if (itypi.eq.ntyp1) cycle
1356         itypi1=iabs(itype(i+1))
1357         xi=c(1,nres+i)
1358         yi=c(2,nres+i)
1359         zi=c(3,nres+i)
1360         dxi=dc_norm(1,nres+i)
1361         dyi=dc_norm(2,nres+i)
1362         dzi=dc_norm(3,nres+i)
1363         dsci_inv=vbld_inv(i+nres)
1364 C
1365 C Calculate SC interaction energy.
1366 C
1367         do iint=1,nint_gr(i)
1368           do j=istart(i,iint),iend(i,iint)
1369             ind=ind+1
1370             itypj=iabs(itype(j))
1371             if (itypj.eq.ntyp1) cycle
1372             dscj_inv=vbld_inv(j+nres)
1373             sig0ij=sigma(itypi,itypj)
1374             r0ij=r0(itypi,itypj)
1375             chi1=chi(itypi,itypj)
1376             chi2=chi(itypj,itypi)
1377             chi12=chi1*chi2
1378             chip1=chip(itypi)
1379             chip2=chip(itypj)
1380             chip12=chip1*chip2
1381             alf1=alp(itypi)
1382             alf2=alp(itypj)
1383             alf12=0.5D0*(alf1+alf2)
1384 C For diagnostics only!!!
1385 c           chi1=0.0D0
1386 c           chi2=0.0D0
1387 c           chi12=0.0D0
1388 c           chip1=0.0D0
1389 c           chip2=0.0D0
1390 c           chip12=0.0D0
1391 c           alf1=0.0D0
1392 c           alf2=0.0D0
1393 c           alf12=0.0D0
1394             xj=c(1,nres+j)-xi
1395             yj=c(2,nres+j)-yi
1396             zj=c(3,nres+j)-zi
1397             dxj=dc_norm(1,nres+j)
1398             dyj=dc_norm(2,nres+j)
1399             dzj=dc_norm(3,nres+j)
1400             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1401             rij=dsqrt(rrij)
1402 C Calculate angle-dependent terms of energy and contributions to their
1403 C derivatives.
1404             call sc_angular
1405             sigsq=1.0D0/sigsq
1406             sig=sig0ij*dsqrt(sigsq)
1407             rij_shift=1.0D0/rij-sig+r0ij
1408 C I hate to put IF's in the loops, but here don't have another choice!!!!
1409             if (rij_shift.le.0.0D0) then
1410               evdw=1.0D20
1411               return
1412             endif
1413             sigder=-sig*sigsq
1414 c---------------------------------------------------------------
1415             rij_shift=1.0D0/rij_shift
1416             fac=rij_shift**expon
1417             e1=fac*fac*aa
1418             e2=fac*bb
1419             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1420             eps2der=evdwij*eps3rt
1421             eps3der=evdwij*eps2rt
1422             fac_augm=rrij**expon
1423             e_augm=augm(itypi,itypj)*fac_augm
1424             evdwij=evdwij*eps2rt*eps3rt
1425             if (bb.gt.0.0d0) then
1426               evdw=evdw+evdwij+e_augm
1427             else
1428               evdw_t=evdw_t+evdwij+e_augm
1429             endif
1430             ij=icant(itypi,itypj)
1431             aux=eps1*eps2rt**2*eps3rt**2
1432             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1433      &        /dabs(eps(itypi,itypj))
1434             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1435 c            eneps_temp(ij)=eneps_temp(ij)
1436 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1437 c            if (lprn) then
1438 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1439 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1440 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1441 c     &        restyp(itypi),i,restyp(itypj),j,
1442 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1443 c     &        chi1,chi2,chip1,chip2,
1444 c     &        eps1,eps2rt**2,eps3rt**2,
1445 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1446 c     &        evdwij+e_augm
1447 c            endif
1448             if (calc_grad) then
1449 C Calculate gradient components.
1450             e1=e1*eps1*eps2rt**2*eps3rt**2
1451             fac=-expon*(e1+evdwij)*rij_shift
1452             sigder=fac*sigder
1453             fac=rij*fac-2*expon*rrij*e_augm
1454 C Calculate the radial part of the gradient
1455             gg(1)=xj*fac
1456             gg(2)=yj*fac
1457             gg(3)=zj*fac
1458 C Calculate angular part of the gradient.
1459             call sc_grad
1460             endif
1461           enddo      ! j
1462         enddo        ! iint
1463       enddo          ! i
1464       return
1465       end
1466 C-----------------------------------------------------------------------------
1467       subroutine sc_angular
1468 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1469 C om12. Called by ebp, egb, and egbv.
1470       implicit none
1471       include 'COMMON.CALC'
1472       erij(1)=xj*rij
1473       erij(2)=yj*rij
1474       erij(3)=zj*rij
1475       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1476       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1477       om12=dxi*dxj+dyi*dyj+dzi*dzj
1478       chiom12=chi12*om12
1479 C Calculate eps1(om12) and its derivative in om12
1480       faceps1=1.0D0-om12*chiom12
1481       faceps1_inv=1.0D0/faceps1
1482       eps1=dsqrt(faceps1_inv)
1483 C Following variable is eps1*deps1/dom12
1484       eps1_om12=faceps1_inv*chiom12
1485 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1486 C and om12.
1487       om1om2=om1*om2
1488       chiom1=chi1*om1
1489       chiom2=chi2*om2
1490       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1491       sigsq=1.0D0-facsig*faceps1_inv
1492       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1493       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1494       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1495 C Calculate eps2 and its derivatives in om1, om2, and om12.
1496       chipom1=chip1*om1
1497       chipom2=chip2*om2
1498       chipom12=chip12*om12
1499       facp=1.0D0-om12*chipom12
1500       facp_inv=1.0D0/facp
1501       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1502 C Following variable is the square root of eps2
1503       eps2rt=1.0D0-facp1*facp_inv
1504 C Following three variables are the derivatives of the square root of eps
1505 C in om1, om2, and om12.
1506       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1507       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1508       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1509 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1510       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1511 C Calculate whole angle-dependent part of epsilon and contributions
1512 C to its derivatives
1513       return
1514       end
1515 C----------------------------------------------------------------------------
1516       subroutine sc_grad
1517       implicit real*8 (a-h,o-z)
1518       include 'DIMENSIONS'
1519       include 'DIMENSIONS.ZSCOPT'
1520       include 'COMMON.CHAIN'
1521       include 'COMMON.DERIV'
1522       include 'COMMON.CALC'
1523       double precision dcosom1(3),dcosom2(3)
1524       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1525       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1526       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1527      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1528       do k=1,3
1529         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1530         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1531       enddo
1532       do k=1,3
1533         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1534       enddo
1535       do k=1,3
1536         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1537      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1538      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1539         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1540      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1541      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1542       enddo
1543 C
1544 C Calculate the components of the gradient in DC and X
1545 C
1546       do k=i,j-1
1547         do l=1,3
1548           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1549         enddo
1550       enddo
1551       return
1552       end
1553 c------------------------------------------------------------------------------
1554       subroutine vec_and_deriv
1555       implicit real*8 (a-h,o-z)
1556       include 'DIMENSIONS'
1557       include 'DIMENSIONS.ZSCOPT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.GEO'
1560       include 'COMMON.VAR'
1561       include 'COMMON.LOCAL'
1562       include 'COMMON.CHAIN'
1563       include 'COMMON.VECTORS'
1564       include 'COMMON.DERIV'
1565       include 'COMMON.INTERACT'
1566       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1567 C Compute the local reference systems. For reference system (i), the
1568 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1569 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1570       do i=1,nres-1
1571 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1572           if (i.eq.nres-1) then
1573 C Case of the last full residue
1574 C Compute the Z-axis
1575             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1576             costh=dcos(pi-theta(nres))
1577             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1578 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1579 c     &         " uz",uz(:,i)
1580             do k=1,3
1581               uz(k,i)=fac*uz(k,i)
1582             enddo
1583             if (calc_grad) then
1584 C Compute the derivatives of uz
1585             uzder(1,1,1)= 0.0d0
1586             uzder(2,1,1)=-dc_norm(3,i-1)
1587             uzder(3,1,1)= dc_norm(2,i-1)
1588             uzder(1,2,1)= dc_norm(3,i-1)
1589             uzder(2,2,1)= 0.0d0
1590             uzder(3,2,1)=-dc_norm(1,i-1)
1591             uzder(1,3,1)=-dc_norm(2,i-1)
1592             uzder(2,3,1)= dc_norm(1,i-1)
1593             uzder(3,3,1)= 0.0d0
1594             uzder(1,1,2)= 0.0d0
1595             uzder(2,1,2)= dc_norm(3,i)
1596             uzder(3,1,2)=-dc_norm(2,i)
1597             uzder(1,2,2)=-dc_norm(3,i)
1598             uzder(2,2,2)= 0.0d0
1599             uzder(3,2,2)= dc_norm(1,i)
1600             uzder(1,3,2)= dc_norm(2,i)
1601             uzder(2,3,2)=-dc_norm(1,i)
1602             uzder(3,3,2)= 0.0d0
1603             endif ! calc_grad
1604 C Compute the Y-axis
1605             facy=fac
1606             do k=1,3
1607               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1608             enddo
1609             if (calc_grad) then
1610 C Compute the derivatives of uy
1611             do j=1,3
1612               do k=1,3
1613                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1614      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1615                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1616               enddo
1617               uyder(j,j,1)=uyder(j,j,1)-costh
1618               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1619             enddo
1620             do j=1,2
1621               do k=1,3
1622                 do l=1,3
1623                   uygrad(l,k,j,i)=uyder(l,k,j)
1624                   uzgrad(l,k,j,i)=uzder(l,k,j)
1625                 enddo
1626               enddo
1627             enddo
1628             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1629             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1630             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1631             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1632             endif
1633           else
1634 C Other residues
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(i+2))
1638             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1639             do k=1,3
1640               uz(k,i)=fac*uz(k,i)
1641             enddo
1642             if (calc_grad) then
1643 C Compute the derivatives of uz
1644             uzder(1,1,1)= 0.0d0
1645             uzder(2,1,1)=-dc_norm(3,i+1)
1646             uzder(3,1,1)= dc_norm(2,i+1)
1647             uzder(1,2,1)= dc_norm(3,i+1)
1648             uzder(2,2,1)= 0.0d0
1649             uzder(3,2,1)=-dc_norm(1,i+1)
1650             uzder(1,3,1)=-dc_norm(2,i+1)
1651             uzder(2,3,1)= dc_norm(1,i+1)
1652             uzder(3,3,1)= 0.0d0
1653             uzder(1,1,2)= 0.0d0
1654             uzder(2,1,2)= dc_norm(3,i)
1655             uzder(3,1,2)=-dc_norm(2,i)
1656             uzder(1,2,2)=-dc_norm(3,i)
1657             uzder(2,2,2)= 0.0d0
1658             uzder(3,2,2)= dc_norm(1,i)
1659             uzder(1,3,2)= dc_norm(2,i)
1660             uzder(2,3,2)=-dc_norm(1,i)
1661             uzder(3,3,2)= 0.0d0
1662             endif
1663 C Compute the Y-axis
1664             facy=fac
1665             do k=1,3
1666               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1667             enddo
1668             if (calc_grad) then
1669 C Compute the derivatives of uy
1670             do j=1,3
1671               do k=1,3
1672                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1673      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1674                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1675               enddo
1676               uyder(j,j,1)=uyder(j,j,1)-costh
1677               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1678             enddo
1679             do j=1,2
1680               do k=1,3
1681                 do l=1,3
1682                   uygrad(l,k,j,i)=uyder(l,k,j)
1683                   uzgrad(l,k,j,i)=uzder(l,k,j)
1684                 enddo
1685               enddo
1686             enddo
1687             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1688             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1689             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1690             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1691           endif
1692           endif
1693       enddo
1694       if (calc_grad) then
1695       do i=1,nres-1
1696         vbld_inv_temp(1)=vbld_inv(i+1)
1697         if (i.lt.nres-1) then
1698           vbld_inv_temp(2)=vbld_inv(i+2)
1699         else
1700           vbld_inv_temp(2)=vbld_inv(i)
1701         endif
1702         do j=1,2
1703           do k=1,3
1704             do l=1,3
1705               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1706               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1707             enddo
1708           enddo
1709         enddo
1710       enddo
1711       endif
1712       return
1713       end
1714 C--------------------------------------------------------------------------
1715       subroutine set_matrices
1716       implicit real*8 (a-h,o-z)
1717       include 'DIMENSIONS'
1718 #ifdef MPI
1719       include "mpif.h"
1720       integer IERR
1721       integer status(MPI_STATUS_SIZE)
1722 #endif
1723       include 'DIMENSIONS.ZSCOPT'
1724       include 'COMMON.IOUNITS'
1725       include 'COMMON.GEO'
1726       include 'COMMON.VAR'
1727       include 'COMMON.LOCAL'
1728       include 'COMMON.CHAIN'
1729       include 'COMMON.DERIV'
1730       include 'COMMON.INTERACT'
1731       include 'COMMON.CONTACTS'
1732       include 'COMMON.TORSION'
1733       include 'COMMON.VECTORS'
1734       include 'COMMON.FFIELD'
1735       double precision auxvec(2),auxmat(2,2)
1736 C
1737 C Compute the virtual-bond-torsional-angle dependent quantities needed
1738 C to calculate the el-loc multibody terms of various order.
1739 C
1740 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1741       do i=3,nres+1
1742         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1743           iti = itype2loc(itype(i-2))
1744         else
1745           iti=nloctyp
1746         endif
1747 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1748         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1749           iti1 = itype2loc(itype(i-1))
1750         else
1751           iti1=nloctyp
1752         endif
1753 #ifdef NEWCORR
1754         cost1=dcos(theta(i-1))
1755         sint1=dsin(theta(i-1))
1756         sint1sq=sint1*sint1
1757         sint1cub=sint1sq*sint1
1758         sint1cost1=2*sint1*cost1
1759 #ifdef DEBUG
1760         write (iout,*) "bnew1",i,iti
1761         write (iout,*) (bnew1(k,1,iti),k=1,3)
1762         write (iout,*) (bnew1(k,2,iti),k=1,3)
1763         write (iout,*) "bnew2",i,iti
1764         write (iout,*) (bnew2(k,1,iti),k=1,3)
1765         write (iout,*) (bnew2(k,2,iti),k=1,3)
1766 #endif
1767         do k=1,2
1768           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1769           b1(k,i-2)=sint1*b1k
1770           gtb1(k,i-2)=cost1*b1k-sint1sq*
1771      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1772           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1773           b2(k,i-2)=sint1*b2k
1774           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1775      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1776         enddo
1777         do k=1,2
1778           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1779           cc(1,k,i-2)=sint1sq*aux
1780           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1781      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1782           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1783           dd(1,k,i-2)=sint1sq*aux
1784           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1785      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1786         enddo
1787         cc(2,1,i-2)=cc(1,2,i-2)
1788         cc(2,2,i-2)=-cc(1,1,i-2)
1789         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1790         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1791         dd(2,1,i-2)=dd(1,2,i-2)
1792         dd(2,2,i-2)=-dd(1,1,i-2)
1793         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1794         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1795         do k=1,2
1796           do l=1,2
1797             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1798             EE(l,k,i-2)=sint1sq*aux
1799             if (calc_grad)
1800      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1801           enddo
1802         enddo
1803         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1804         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1805         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1806         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1807         if (calc_grad) then
1808         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1809         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1810         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1811         endif
1812 c        b1tilde(1,i-2)=b1(1,i-2)
1813 c        b1tilde(2,i-2)=-b1(2,i-2)
1814 c        b2tilde(1,i-2)=b2(1,i-2)
1815 c        b2tilde(2,i-2)=-b2(2,i-2)
1816 #ifdef DEBUG
1817         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1818         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1819         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1820         write (iout,*) 'theta=', theta(i-1)
1821 #endif
1822 #else
1823 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1824 c          iti = itype2loc(itype(i-2))
1825 c        else
1826 c          iti=nloctyp
1827 c        endif
1828 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1829 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1830 c          iti1 = itype2loc(itype(i-1))
1831 c        else
1832 c          iti1=nloctyp
1833 c        endif
1834         b1(1,i-2)=b(3,iti)
1835         b1(2,i-2)=b(5,iti)
1836         b2(1,i-2)=b(2,iti)
1837         b2(2,i-2)=b(4,iti)
1838         do k=1,2
1839           do l=1,2
1840            CC(k,l,i-2)=ccold(k,l,iti)
1841            DD(k,l,i-2)=ddold(k,l,iti)
1842            EE(k,l,i-2)=eeold(k,l,iti)
1843           enddo
1844         enddo
1845 #endif
1846         b1tilde(1,i-2)= b1(1,i-2)
1847         b1tilde(2,i-2)=-b1(2,i-2)
1848         b2tilde(1,i-2)= b2(1,i-2)
1849         b2tilde(2,i-2)=-b2(2,i-2)
1850 c
1851         Ctilde(1,1,i-2)= CC(1,1,i-2)
1852         Ctilde(1,2,i-2)= CC(1,2,i-2)
1853         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1854         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1855 c
1856         Dtilde(1,1,i-2)= DD(1,1,i-2)
1857         Dtilde(1,2,i-2)= DD(1,2,i-2)
1858         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1859         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1860 #ifdef DEBUG
1861         write(iout,*) "i",i," iti",iti
1862         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1863         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1864 #endif
1865       enddo
1866       do i=3,nres+1
1867         if (i .lt. nres+1) then
1868           sin1=dsin(phi(i))
1869           cos1=dcos(phi(i))
1870           sintab(i-2)=sin1
1871           costab(i-2)=cos1
1872           obrot(1,i-2)=cos1
1873           obrot(2,i-2)=sin1
1874           sin2=dsin(2*phi(i))
1875           cos2=dcos(2*phi(i))
1876           sintab2(i-2)=sin2
1877           costab2(i-2)=cos2
1878           obrot2(1,i-2)=cos2
1879           obrot2(2,i-2)=sin2
1880           Ug(1,1,i-2)=-cos1
1881           Ug(1,2,i-2)=-sin1
1882           Ug(2,1,i-2)=-sin1
1883           Ug(2,2,i-2)= cos1
1884           Ug2(1,1,i-2)=-cos2
1885           Ug2(1,2,i-2)=-sin2
1886           Ug2(2,1,i-2)=-sin2
1887           Ug2(2,2,i-2)= cos2
1888         else
1889           costab(i-2)=1.0d0
1890           sintab(i-2)=0.0d0
1891           obrot(1,i-2)=1.0d0
1892           obrot(2,i-2)=0.0d0
1893           obrot2(1,i-2)=0.0d0
1894           obrot2(2,i-2)=0.0d0
1895           Ug(1,1,i-2)=1.0d0
1896           Ug(1,2,i-2)=0.0d0
1897           Ug(2,1,i-2)=0.0d0
1898           Ug(2,2,i-2)=1.0d0
1899           Ug2(1,1,i-2)=0.0d0
1900           Ug2(1,2,i-2)=0.0d0
1901           Ug2(2,1,i-2)=0.0d0
1902           Ug2(2,2,i-2)=0.0d0
1903         endif
1904         if (i .gt. 3 .and. i .lt. nres+1) then
1905           obrot_der(1,i-2)=-sin1
1906           obrot_der(2,i-2)= cos1
1907           Ugder(1,1,i-2)= sin1
1908           Ugder(1,2,i-2)=-cos1
1909           Ugder(2,1,i-2)=-cos1
1910           Ugder(2,2,i-2)=-sin1
1911           dwacos2=cos2+cos2
1912           dwasin2=sin2+sin2
1913           obrot2_der(1,i-2)=-dwasin2
1914           obrot2_der(2,i-2)= dwacos2
1915           Ug2der(1,1,i-2)= dwasin2
1916           Ug2der(1,2,i-2)=-dwacos2
1917           Ug2der(2,1,i-2)=-dwacos2
1918           Ug2der(2,2,i-2)=-dwasin2
1919         else
1920           obrot_der(1,i-2)=0.0d0
1921           obrot_der(2,i-2)=0.0d0
1922           Ugder(1,1,i-2)=0.0d0
1923           Ugder(1,2,i-2)=0.0d0
1924           Ugder(2,1,i-2)=0.0d0
1925           Ugder(2,2,i-2)=0.0d0
1926           obrot2_der(1,i-2)=0.0d0
1927           obrot2_der(2,i-2)=0.0d0
1928           Ug2der(1,1,i-2)=0.0d0
1929           Ug2der(1,2,i-2)=0.0d0
1930           Ug2der(2,1,i-2)=0.0d0
1931           Ug2der(2,2,i-2)=0.0d0
1932         endif
1933 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1934         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1935           iti = itype2loc(itype(i-2))
1936         else
1937           iti=nloctyp
1938         endif
1939 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1940         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1941           iti1 = itype2loc(itype(i-1))
1942         else
1943           iti1=nloctyp
1944         endif
1945 cd        write (iout,*) '*******i',i,' iti1',iti
1946 cd        write (iout,*) 'b1',b1(:,iti)
1947 cd        write (iout,*) 'b2',b2(:,iti)
1948 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1949 c        if (i .gt. iatel_s+2) then
1950         if (i .gt. nnt+2) then
1951           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1952 #ifdef NEWCORR
1953           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1954 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1955 #endif
1956 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1957 c     &    EE(1,2,iti),EE(2,2,i)
1958           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1959           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1960 c          write(iout,*) "Macierz EUG",
1961 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1962 c     &    eug(2,2,i-2)
1963           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1964      &    then
1965           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1966           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1967           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1968           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1969           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1970           endif
1971         else
1972           do k=1,2
1973             Ub2(k,i-2)=0.0d0
1974             Ctobr(k,i-2)=0.0d0
1975             Dtobr2(k,i-2)=0.0d0
1976             do l=1,2
1977               EUg(l,k,i-2)=0.0d0
1978               CUg(l,k,i-2)=0.0d0
1979               DUg(l,k,i-2)=0.0d0
1980               DtUg2(l,k,i-2)=0.0d0
1981             enddo
1982           enddo
1983         endif
1984         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1985         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1986         do k=1,2
1987           muder(k,i-2)=Ub2der(k,i-2)
1988         enddo
1989 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1990         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1991           if (itype(i-1).le.ntyp) then
1992             iti1 = itype2loc(itype(i-1))
1993           else
1994             iti1=nloctyp
1995           endif
1996         else
1997           iti1=nloctyp
1998         endif
1999         do k=1,2
2000           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2001         enddo
2002 #ifdef MUOUT
2003         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2004      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2005      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2006      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2007      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2008      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2009 #endif
2010 cd        write (iout,*) 'mu1',mu1(:,i-2)
2011 cd        write (iout,*) 'mu2',mu2(:,i-2)
2012         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2013      &  then
2014         if (calc_grad) then
2015         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2016         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2017         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2018         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2019         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2020         endif
2021 C Vectors and matrices dependent on a single virtual-bond dihedral.
2022         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2023         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2024         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2025         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2026         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2027         if (calc_grad) then
2028         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2029         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2030         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2031         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2032         endif
2033         endif
2034       enddo
2035 C Matrices dependent on two consecutive virtual-bond dihedrals.
2036 C The order of matrices is from left to right.
2037       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2038      &then
2039       do i=2,nres-1
2040         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2041         if (calc_grad) then
2042         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2043         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2044         endif
2045         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2046         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2047         if (calc_grad) then
2048         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2049         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2050         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2051         endif
2052       enddo
2053       endif
2054       return
2055       end
2056 C--------------------------------------------------------------------------
2057       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2058 C
2059 C This subroutine calculates the average interaction energy and its gradient
2060 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2061 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2062 C The potential depends both on the distance of peptide-group centers and on
2063 C the orientation of the CA-CA virtual bonds.
2064 C
2065       implicit real*8 (a-h,o-z)
2066 #ifdef MPI
2067       include 'mpif.h'
2068 #endif
2069       include 'DIMENSIONS'
2070       include 'DIMENSIONS.ZSCOPT'
2071       include 'COMMON.CONTROL'
2072       include 'COMMON.IOUNITS'
2073       include 'COMMON.GEO'
2074       include 'COMMON.VAR'
2075       include 'COMMON.LOCAL'
2076       include 'COMMON.CHAIN'
2077       include 'COMMON.DERIV'
2078       include 'COMMON.INTERACT'
2079       include 'COMMON.CONTACTS'
2080       include 'COMMON.TORSION'
2081       include 'COMMON.VECTORS'
2082       include 'COMMON.FFIELD'
2083       include 'COMMON.TIME1'
2084       include 'COMMON.SPLITELE'
2085       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2086      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2087       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2088      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2089       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2090      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2091      &    num_conti,j1,j2
2092 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2093 #ifdef MOMENT
2094       double precision scal_el /1.0d0/
2095 #else
2096       double precision scal_el /0.5d0/
2097 #endif
2098 C 12/13/98
2099 C 13-go grudnia roku pamietnego...
2100       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2101      &                   0.0d0,1.0d0,0.0d0,
2102      &                   0.0d0,0.0d0,1.0d0/
2103 cd      write(iout,*) 'In EELEC'
2104 cd      do i=1,nloctyp
2105 cd        write(iout,*) 'Type',i
2106 cd        write(iout,*) 'B1',B1(:,i)
2107 cd        write(iout,*) 'B2',B2(:,i)
2108 cd        write(iout,*) 'CC',CC(:,:,i)
2109 cd        write(iout,*) 'DD',DD(:,:,i)
2110 cd        write(iout,*) 'EE',EE(:,:,i)
2111 cd      enddo
2112 cd      call check_vecgrad
2113 cd      stop
2114       if (icheckgrad.eq.1) then
2115         do i=1,nres-1
2116           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2117           do k=1,3
2118             dc_norm(k,i)=dc(k,i)*fac
2119           enddo
2120 c          write (iout,*) 'i',i,' fac',fac
2121         enddo
2122       endif
2123       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2124      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2125      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2126 c        call vec_and_deriv
2127 #ifdef TIMING
2128         time01=MPI_Wtime()
2129 #endif
2130         call set_matrices
2131 #ifdef TIMING
2132         time_mat=time_mat+MPI_Wtime()-time01
2133 #endif
2134       endif
2135 cd      do i=1,nres-1
2136 cd        write (iout,*) 'i=',i
2137 cd        do k=1,3
2138 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2139 cd        enddo
2140 cd        do k=1,3
2141 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2142 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2143 cd        enddo
2144 cd      enddo
2145       t_eelecij=0.0d0
2146       ees=0.0D0
2147       evdw1=0.0D0
2148       eel_loc=0.0d0
2149       eello_turn3=0.0d0
2150       eello_turn4=0.0d0
2151       ind=0
2152       do i=1,nres
2153         num_cont_hb(i)=0
2154       enddo
2155 cd      print '(a)','Enter EELEC'
2156 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2157       do i=1,nres
2158         gel_loc_loc(i)=0.0d0
2159         gcorr_loc(i)=0.0d0
2160       enddo
2161 c
2162 c
2163 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2164 C
2165 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2166 C
2167 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2168       do i=iturn3_start,iturn3_end
2169 c        if (i.le.1) cycle
2170 C        write(iout,*) "tu jest i",i
2171         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2172 C changes suggested by Ana to avoid out of bounds
2173 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2174 c     & .or.((i+4).gt.nres)
2175 c     & .or.((i-1).le.0)
2176 C end of changes by Ana
2177 C dobra zmiana wycofana
2178      &  .or. itype(i+2).eq.ntyp1
2179      &  .or. itype(i+3).eq.ntyp1) cycle
2180 C Adam: Instructions below will switch off existing interactions
2181 c        if(i.gt.1)then
2182 c          if(itype(i-1).eq.ntyp1)cycle
2183 c        end if
2184 c        if(i.LT.nres-3)then
2185 c          if (itype(i+4).eq.ntyp1) cycle
2186 c        end if
2187         dxi=dc(1,i)
2188         dyi=dc(2,i)
2189         dzi=dc(3,i)
2190         dx_normi=dc_norm(1,i)
2191         dy_normi=dc_norm(2,i)
2192         dz_normi=dc_norm(3,i)
2193         xmedi=c(1,i)+0.5d0*dxi
2194         ymedi=c(2,i)+0.5d0*dyi
2195         zmedi=c(3,i)+0.5d0*dzi
2196           xmedi=mod(xmedi,boxxsize)
2197           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2198           ymedi=mod(ymedi,boxysize)
2199           if (ymedi.lt.0) ymedi=ymedi+boxysize
2200           zmedi=mod(zmedi,boxzsize)
2201           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2202         num_conti=0
2203         call eelecij(i,i+2,ees,evdw1,eel_loc)
2204         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2205         num_cont_hb(i)=num_conti
2206       enddo
2207       do i=iturn4_start,iturn4_end
2208         if (i.lt.1) cycle
2209         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2210 C changes suggested by Ana to avoid out of bounds
2211 c     & .or.((i+5).gt.nres)
2212 c     & .or.((i-1).le.0)
2213 C end of changes suggested by Ana
2214      &    .or. itype(i+3).eq.ntyp1
2215      &    .or. itype(i+4).eq.ntyp1
2216 c     &    .or. itype(i+5).eq.ntyp1
2217 c     &    .or. itype(i).eq.ntyp1
2218 c     &    .or. itype(i-1).eq.ntyp1
2219      &                             ) cycle
2220         dxi=dc(1,i)
2221         dyi=dc(2,i)
2222         dzi=dc(3,i)
2223         dx_normi=dc_norm(1,i)
2224         dy_normi=dc_norm(2,i)
2225         dz_normi=dc_norm(3,i)
2226         xmedi=c(1,i)+0.5d0*dxi
2227         ymedi=c(2,i)+0.5d0*dyi
2228         zmedi=c(3,i)+0.5d0*dzi
2229 C Return atom into box, boxxsize is size of box in x dimension
2230 c  194   continue
2231 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2232 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2233 C Condition for being inside the proper box
2234 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2235 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2236 c        go to 194
2237 c        endif
2238 c  195   continue
2239 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2240 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2241 C Condition for being inside the proper box
2242 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2243 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2244 c        go to 195
2245 c        endif
2246 c  196   continue
2247 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2248 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2249 C Condition for being inside the proper box
2250 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2251 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2252 c        go to 196
2253 c        endif
2254           xmedi=mod(xmedi,boxxsize)
2255           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2256           ymedi=mod(ymedi,boxysize)
2257           if (ymedi.lt.0) ymedi=ymedi+boxysize
2258           zmedi=mod(zmedi,boxzsize)
2259           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2260
2261         num_conti=num_cont_hb(i)
2262 c        write(iout,*) "JESTEM W PETLI"
2263         call eelecij(i,i+3,ees,evdw1,eel_loc)
2264         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2265      &   call eturn4(i,eello_turn4)
2266         num_cont_hb(i)=num_conti
2267       enddo   ! i
2268 C Loop over all neighbouring boxes
2269 C      do xshift=-1,1
2270 C      do yshift=-1,1
2271 C      do zshift=-1,1
2272 c
2273 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2274 c
2275 CTU KURWA
2276       do i=iatel_s,iatel_e
2277 C        do i=75,75
2278 c        if (i.le.1) cycle
2279         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2280 C changes suggested by Ana to avoid out of bounds
2281 c     & .or.((i+2).gt.nres)
2282 c     & .or.((i-1).le.0)
2283 C end of changes by Ana
2284 c     &  .or. itype(i+2).eq.ntyp1
2285 c     &  .or. itype(i-1).eq.ntyp1
2286      &                ) cycle
2287         dxi=dc(1,i)
2288         dyi=dc(2,i)
2289         dzi=dc(3,i)
2290         dx_normi=dc_norm(1,i)
2291         dy_normi=dc_norm(2,i)
2292         dz_normi=dc_norm(3,i)
2293         xmedi=c(1,i)+0.5d0*dxi
2294         ymedi=c(2,i)+0.5d0*dyi
2295         zmedi=c(3,i)+0.5d0*dzi
2296           xmedi=mod(xmedi,boxxsize)
2297           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2298           ymedi=mod(ymedi,boxysize)
2299           if (ymedi.lt.0) ymedi=ymedi+boxysize
2300           zmedi=mod(zmedi,boxzsize)
2301           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2302 C          xmedi=xmedi+xshift*boxxsize
2303 C          ymedi=ymedi+yshift*boxysize
2304 C          zmedi=zmedi+zshift*boxzsize
2305
2306 C Return tom into box, boxxsize is size of box in x dimension
2307 c  164   continue
2308 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2309 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2310 C Condition for being inside the proper box
2311 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2312 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2313 c        go to 164
2314 c        endif
2315 c  165   continue
2316 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2317 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2318 C Condition for being inside the proper box
2319 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2320 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2321 c        go to 165
2322 c        endif
2323 c  166   continue
2324 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2325 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2326 cC Condition for being inside the proper box
2327 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2328 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2329 c        go to 166
2330 c        endif
2331
2332 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2333         num_conti=num_cont_hb(i)
2334 C I TU KURWA
2335         do j=ielstart(i),ielend(i)
2336 C          do j=16,17
2337 C          write (iout,*) i,j
2338 C         if (j.le.1) cycle
2339           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2340 C changes suggested by Ana to avoid out of bounds
2341 c     & .or.((j+2).gt.nres)
2342 c     & .or.((j-1).le.0)
2343 C end of changes by Ana
2344 c     & .or.itype(j+2).eq.ntyp1
2345 c     & .or.itype(j-1).eq.ntyp1
2346      &) cycle
2347           call eelecij(i,j,ees,evdw1,eel_loc)
2348         enddo ! j
2349         num_cont_hb(i)=num_conti
2350       enddo   ! i
2351 C     enddo   ! zshift
2352 C      enddo   ! yshift
2353 C      enddo   ! xshift
2354
2355 c      write (iout,*) "Number of loop steps in EELEC:",ind
2356 cd      do i=1,nres
2357 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2358 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2359 cd      enddo
2360 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2361 ccc      eel_loc=eel_loc+eello_turn3
2362 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2363       return
2364       end
2365 C-------------------------------------------------------------------------------
2366       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2367       implicit real*8 (a-h,o-z)
2368       include 'DIMENSIONS'
2369       include 'DIMENSIONS.ZSCOPT'
2370 #ifdef MPI
2371       include "mpif.h"
2372 #endif
2373       include 'COMMON.CONTROL'
2374       include 'COMMON.IOUNITS'
2375       include 'COMMON.GEO'
2376       include 'COMMON.VAR'
2377       include 'COMMON.LOCAL'
2378       include 'COMMON.CHAIN'
2379       include 'COMMON.DERIV'
2380       include 'COMMON.INTERACT'
2381       include 'COMMON.CONTACTS'
2382       include 'COMMON.TORSION'
2383       include 'COMMON.VECTORS'
2384       include 'COMMON.FFIELD'
2385       include 'COMMON.TIME1'
2386       include 'COMMON.SPLITELE'
2387       include 'COMMON.SHIELD'
2388       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2389      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2390       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2391      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2392      &    gmuij2(4),gmuji2(4)
2393       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2394      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2395      &    num_conti,j1,j2
2396 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2397 #ifdef MOMENT
2398       double precision scal_el /1.0d0/
2399 #else
2400       double precision scal_el /0.5d0/
2401 #endif
2402 C 12/13/98
2403 C 13-go grudnia roku pamietnego...
2404       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2405      &                   0.0d0,1.0d0,0.0d0,
2406      &                   0.0d0,0.0d0,1.0d0/
2407        integer xshift,yshift,zshift
2408 c          time00=MPI_Wtime()
2409 cd      write (iout,*) "eelecij",i,j
2410 c          ind=ind+1
2411           iteli=itel(i)
2412           itelj=itel(j)
2413           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2414           aaa=app(iteli,itelj)
2415           bbb=bpp(iteli,itelj)
2416           ael6i=ael6(iteli,itelj)
2417           ael3i=ael3(iteli,itelj)
2418           dxj=dc(1,j)
2419           dyj=dc(2,j)
2420           dzj=dc(3,j)
2421           dx_normj=dc_norm(1,j)
2422           dy_normj=dc_norm(2,j)
2423           dz_normj=dc_norm(3,j)
2424 C          xj=c(1,j)+0.5D0*dxj-xmedi
2425 C          yj=c(2,j)+0.5D0*dyj-ymedi
2426 C          zj=c(3,j)+0.5D0*dzj-zmedi
2427           xj=c(1,j)+0.5D0*dxj
2428           yj=c(2,j)+0.5D0*dyj
2429           zj=c(3,j)+0.5D0*dzj
2430           xj=mod(xj,boxxsize)
2431           if (xj.lt.0) xj=xj+boxxsize
2432           yj=mod(yj,boxysize)
2433           if (yj.lt.0) yj=yj+boxysize
2434           zj=mod(zj,boxzsize)
2435           if (zj.lt.0) zj=zj+boxzsize
2436           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2437       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2438       xj_safe=xj
2439       yj_safe=yj
2440       zj_safe=zj
2441       isubchap=0
2442       do xshift=-1,1
2443       do yshift=-1,1
2444       do zshift=-1,1
2445           xj=xj_safe+xshift*boxxsize
2446           yj=yj_safe+yshift*boxysize
2447           zj=zj_safe+zshift*boxzsize
2448           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2449           if(dist_temp.lt.dist_init) then
2450             dist_init=dist_temp
2451             xj_temp=xj
2452             yj_temp=yj
2453             zj_temp=zj
2454             isubchap=1
2455           endif
2456        enddo
2457        enddo
2458        enddo
2459        if (isubchap.eq.1) then
2460           xj=xj_temp-xmedi
2461           yj=yj_temp-ymedi
2462           zj=zj_temp-zmedi
2463        else
2464           xj=xj_safe-xmedi
2465           yj=yj_safe-ymedi
2466           zj=zj_safe-zmedi
2467        endif
2468 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2469 c  174   continue
2470 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2471 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2472 C Condition for being inside the proper box
2473 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2474 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2475 c        go to 174
2476 c        endif
2477 c  175   continue
2478 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2479 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2480 C Condition for being inside the proper box
2481 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2482 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2483 c        go to 175
2484 c        endif
2485 c  176   continue
2486 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2487 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2488 C Condition for being inside the proper box
2489 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2490 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2491 c        go to 176
2492 c        endif
2493 C        endif !endPBC condintion
2494 C        xj=xj-xmedi
2495 C        yj=yj-ymedi
2496 C        zj=zj-zmedi
2497           rij=xj*xj+yj*yj+zj*zj
2498
2499             sss=sscale(sqrt(rij))
2500             sssgrad=sscagrad(sqrt(rij))
2501 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2502 c     &       " rlamb",rlamb," sss",sss
2503 c            if (sss.gt.0.0d0) then
2504           rrmij=1.0D0/rij
2505           rij=dsqrt(rij)
2506           rmij=1.0D0/rij
2507           r3ij=rrmij*rmij
2508           r6ij=r3ij*r3ij
2509           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2510           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2511           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2512           fac=cosa-3.0D0*cosb*cosg
2513           ev1=aaa*r6ij*r6ij
2514 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2515           if (j.eq.i+2) ev1=scal_el*ev1
2516           ev2=bbb*r6ij
2517           fac3=ael6i*r6ij
2518           fac4=ael3i*r3ij
2519           evdwij=(ev1+ev2)
2520           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2521           el2=fac4*fac
2522 C MARYSIA
2523 C          eesij=(el1+el2)
2524 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2525           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2526           if (shield_mode.gt.0) then
2527 C          fac_shield(i)=0.4
2528 C          fac_shield(j)=0.6
2529           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2530           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2531           eesij=(el1+el2)
2532           ees=ees+eesij
2533           else
2534           fac_shield(i)=1.0
2535           fac_shield(j)=1.0
2536           eesij=(el1+el2)
2537           ees=ees+eesij
2538           endif
2539           evdw1=evdw1+evdwij*sss
2540 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2541 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2542 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2543 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2544
2545           if (energy_dec) then
2546               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2547      &'evdw1',i,j,evdwij
2548      &,iteli,itelj,aaa,evdw1,sss
2549               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2550      &fac_shield(i),fac_shield(j)
2551           endif
2552
2553 C
2554 C Calculate contributions to the Cartesian gradient.
2555 C
2556 #ifdef SPLITELE
2557           facvdw=-6*rrmij*(ev1+evdwij)*sss
2558           facel=-3*rrmij*(el1+eesij)
2559           fac1=fac
2560           erij(1)=xj*rmij
2561           erij(2)=yj*rmij
2562           erij(3)=zj*rmij
2563
2564 *
2565 * Radial derivatives. First process both termini of the fragment (i,j)
2566 *
2567           if (calc_grad) then
2568           ggg(1)=facel*xj
2569           ggg(2)=facel*yj
2570           ggg(3)=facel*zj
2571           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2572      &  (shield_mode.gt.0)) then
2573 C          print *,i,j
2574           do ilist=1,ishield_list(i)
2575            iresshield=shield_list(ilist,i)
2576            do k=1,3
2577            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2578      &      *2.0
2579            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2580      &              rlocshield
2581      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2582             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2583 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2584 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2585 C             if (iresshield.gt.i) then
2586 C               do ishi=i+1,iresshield-1
2587 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2588 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2589 C
2590 C              enddo
2591 C             else
2592 C               do ishi=iresshield,i
2593 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2594 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2595 C
2596 C               enddo
2597 C              endif
2598            enddo
2599           enddo
2600           do ilist=1,ishield_list(j)
2601            iresshield=shield_list(ilist,j)
2602            do k=1,3
2603            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2604      &     *2.0
2605            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2606      &              rlocshield
2607      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2608            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2609
2610 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2611 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2612 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2613 C             if (iresshield.gt.j) then
2614 C               do ishi=j+1,iresshield-1
2615 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2616 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2617 C
2618 C               enddo
2619 C            else
2620 C               do ishi=iresshield,j
2621 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2622 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2623 C               enddo
2624 C              endif
2625            enddo
2626           enddo
2627
2628           do k=1,3
2629             gshieldc(k,i)=gshieldc(k,i)+
2630      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2631             gshieldc(k,j)=gshieldc(k,j)+
2632      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2633             gshieldc(k,i-1)=gshieldc(k,i-1)+
2634      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2635             gshieldc(k,j-1)=gshieldc(k,j-1)+
2636      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2637
2638            enddo
2639            endif
2640 c          do k=1,3
2641 c            ghalf=0.5D0*ggg(k)
2642 c            gelc(k,i)=gelc(k,i)+ghalf
2643 c            gelc(k,j)=gelc(k,j)+ghalf
2644 c          enddo
2645 c 9/28/08 AL Gradient compotents will be summed only at the end
2646 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2647           do k=1,3
2648             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2649 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2650             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2651 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2652 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2653 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2654 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2655 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2656           enddo
2657 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2658
2659 *
2660 * Loop over residues i+1 thru j-1.
2661 *
2662 cgrad          do k=i+1,j-1
2663 cgrad            do l=1,3
2664 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2665 cgrad            enddo
2666 cgrad          enddo
2667           if (sss.gt.0.0) then
2668           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2669           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2670           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2671           else
2672           ggg(1)=0.0
2673           ggg(2)=0.0
2674           ggg(3)=0.0
2675           endif
2676 c          do k=1,3
2677 c            ghalf=0.5D0*ggg(k)
2678 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2679 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2680 c          enddo
2681 c 9/28/08 AL Gradient compotents will be summed only at the end
2682           do k=1,3
2683             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2684             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2685           enddo
2686 *
2687 * Loop over residues i+1 thru j-1.
2688 *
2689 cgrad          do k=i+1,j-1
2690 cgrad            do l=1,3
2691 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2692 cgrad            enddo
2693 cgrad          enddo
2694           endif ! calc_grad
2695 #else
2696 C MARYSIA
2697           facvdw=(ev1+evdwij)*sss
2698           facel=(el1+eesij)
2699           fac1=fac
2700           fac=-3*rrmij*(facvdw+facvdw+facel)
2701           erij(1)=xj*rmij
2702           erij(2)=yj*rmij
2703           erij(3)=zj*rmij
2704 *
2705 * Radial derivatives. First process both termini of the fragment (i,j)
2706 *
2707           if (calc_grad) then
2708           ggg(1)=fac*xj
2709 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2710           ggg(2)=fac*yj
2711 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2712           ggg(3)=fac*zj
2713 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2714 c          do k=1,3
2715 c            ghalf=0.5D0*ggg(k)
2716 c            gelc(k,i)=gelc(k,i)+ghalf
2717 c            gelc(k,j)=gelc(k,j)+ghalf
2718 c          enddo
2719 c 9/28/08 AL Gradient compotents will be summed only at the end
2720           do k=1,3
2721             gelc_long(k,j)=gelc(k,j)+ggg(k)
2722             gelc_long(k,i)=gelc(k,i)-ggg(k)
2723           enddo
2724 *
2725 * Loop over residues i+1 thru j-1.
2726 *
2727 cgrad          do k=i+1,j-1
2728 cgrad            do l=1,3
2729 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2730 cgrad            enddo
2731 cgrad          enddo
2732 c 9/28/08 AL Gradient compotents will be summed only at the end
2733           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2734           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2735           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2736           do k=1,3
2737             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2738             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2739           enddo
2740           endif ! calc_grad
2741 #endif
2742 *
2743 * Angular part
2744 *
2745           if (calc_grad) then
2746           ecosa=2.0D0*fac3*fac1+fac4
2747           fac4=-3.0D0*fac4
2748           fac3=-6.0D0*fac3
2749           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2750           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2751           do k=1,3
2752             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2753             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2754           enddo
2755 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2756 cd   &          (dcosg(k),k=1,3)
2757           do k=1,3
2758             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2759      &      fac_shield(i)**2*fac_shield(j)**2
2760           enddo
2761 c          do k=1,3
2762 c            ghalf=0.5D0*ggg(k)
2763 c            gelc(k,i)=gelc(k,i)+ghalf
2764 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2765 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2766 c            gelc(k,j)=gelc(k,j)+ghalf
2767 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2768 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2769 c          enddo
2770 cgrad          do k=i+1,j-1
2771 cgrad            do l=1,3
2772 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2773 cgrad            enddo
2774 cgrad          enddo
2775 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2776           do k=1,3
2777             gelc(k,i)=gelc(k,i)
2778      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2779      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2780      &           *fac_shield(i)**2*fac_shield(j)**2
2781             gelc(k,j)=gelc(k,j)
2782      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2783      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2784      &           *fac_shield(i)**2*fac_shield(j)**2
2785             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2786             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2787           enddo
2788 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2789
2790 C MARYSIA
2791 c          endif !sscale
2792           endif ! calc_grad
2793           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2794      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2795      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2796 C
2797 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2798 C   energy of a peptide unit is assumed in the form of a second-order
2799 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2800 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2801 C   are computed for EVERY pair of non-contiguous peptide groups.
2802 C
2803
2804           if (j.lt.nres-1) then
2805             j1=j+1
2806             j2=j-1
2807           else
2808             j1=j-1
2809             j2=j-2
2810           endif
2811           kkk=0
2812           lll=0
2813           do k=1,2
2814             do l=1,2
2815               kkk=kkk+1
2816               muij(kkk)=mu(k,i)*mu(l,j)
2817 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2818 #ifdef NEWCORR
2819              if (calc_grad) then
2820              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2821 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2822              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2823              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2824 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2825              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2826              endif
2827 #endif
2828             enddo
2829           enddo
2830 #ifdef DEBUG
2831           write (iout,*) 'EELEC: i',i,' j',j
2832           write (iout,*) 'j',j,' j1',j1,' j2',j2
2833           write(iout,*) 'muij',muij
2834           write (iout,*) "uy",uy(:,i)
2835           write (iout,*) "uz",uz(:,j)
2836           write (iout,*) "erij",erij
2837 #endif
2838           ury=scalar(uy(1,i),erij)
2839           urz=scalar(uz(1,i),erij)
2840           vry=scalar(uy(1,j),erij)
2841           vrz=scalar(uz(1,j),erij)
2842           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2843           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2844           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2845           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2846           fac=dsqrt(-ael6i)*r3ij
2847           a22=a22*fac
2848           a23=a23*fac
2849           a32=a32*fac
2850           a33=a33*fac
2851 cd          write (iout,'(4i5,4f10.5)')
2852 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2853 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2854 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2855 cd     &      uy(:,j),uz(:,j)
2856 cd          write (iout,'(4f10.5)')
2857 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2858 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2859 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2860 cd           write (iout,'(9f10.5/)')
2861 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2862 C Derivatives of the elements of A in virtual-bond vectors
2863           if (calc_grad) then
2864           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2865           do k=1,3
2866             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2867             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2868             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2869             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2870             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2871             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2872             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2873             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2874             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2875             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2876             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2877             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2878           enddo
2879 C Compute radial contributions to the gradient
2880           facr=-3.0d0*rrmij
2881           a22der=a22*facr
2882           a23der=a23*facr
2883           a32der=a32*facr
2884           a33der=a33*facr
2885           agg(1,1)=a22der*xj
2886           agg(2,1)=a22der*yj
2887           agg(3,1)=a22der*zj
2888           agg(1,2)=a23der*xj
2889           agg(2,2)=a23der*yj
2890           agg(3,2)=a23der*zj
2891           agg(1,3)=a32der*xj
2892           agg(2,3)=a32der*yj
2893           agg(3,3)=a32der*zj
2894           agg(1,4)=a33der*xj
2895           agg(2,4)=a33der*yj
2896           agg(3,4)=a33der*zj
2897 C Add the contributions coming from er
2898           fac3=-3.0d0*fac
2899           do k=1,3
2900             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2901             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2902             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2903             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2904           enddo
2905           do k=1,3
2906 C Derivatives in DC(i)
2907 cgrad            ghalf1=0.5d0*agg(k,1)
2908 cgrad            ghalf2=0.5d0*agg(k,2)
2909 cgrad            ghalf3=0.5d0*agg(k,3)
2910 cgrad            ghalf4=0.5d0*agg(k,4)
2911             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2912      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2913             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2914      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2915             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2916      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2917             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2918      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2919 C Derivatives in DC(i+1)
2920             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2921      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2922             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2923      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2924             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2925      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2926             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2927      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2928 C Derivatives in DC(j)
2929             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2930      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2931             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2932      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2933             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2934      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2935             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2936      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2937 C Derivatives in DC(j+1) or DC(nres-1)
2938             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2939      &      -3.0d0*vryg(k,3)*ury)
2940             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2941      &      -3.0d0*vrzg(k,3)*ury)
2942             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2943      &      -3.0d0*vryg(k,3)*urz)
2944             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2945      &      -3.0d0*vrzg(k,3)*urz)
2946 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2947 cgrad              do l=1,4
2948 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2949 cgrad              enddo
2950 cgrad            endif
2951           enddo
2952           endif ! calc_grad
2953           acipa(1,1)=a22
2954           acipa(1,2)=a23
2955           acipa(2,1)=a32
2956           acipa(2,2)=a33
2957           a22=-a22
2958           a23=-a23
2959           if (calc_grad) then
2960           do l=1,2
2961             do k=1,3
2962               agg(k,l)=-agg(k,l)
2963               aggi(k,l)=-aggi(k,l)
2964               aggi1(k,l)=-aggi1(k,l)
2965               aggj(k,l)=-aggj(k,l)
2966               aggj1(k,l)=-aggj1(k,l)
2967             enddo
2968           enddo
2969           endif ! calc_grad
2970           if (j.lt.nres-1) then
2971             a22=-a22
2972             a32=-a32
2973             do l=1,3,2
2974               do k=1,3
2975                 agg(k,l)=-agg(k,l)
2976                 aggi(k,l)=-aggi(k,l)
2977                 aggi1(k,l)=-aggi1(k,l)
2978                 aggj(k,l)=-aggj(k,l)
2979                 aggj1(k,l)=-aggj1(k,l)
2980               enddo
2981             enddo
2982           else
2983             a22=-a22
2984             a23=-a23
2985             a32=-a32
2986             a33=-a33
2987             do l=1,4
2988               do k=1,3
2989                 agg(k,l)=-agg(k,l)
2990                 aggi(k,l)=-aggi(k,l)
2991                 aggi1(k,l)=-aggi1(k,l)
2992                 aggj(k,l)=-aggj(k,l)
2993                 aggj1(k,l)=-aggj1(k,l)
2994               enddo
2995             enddo
2996           endif
2997           ENDIF ! WCORR
2998           IF (wel_loc.gt.0.0d0) THEN
2999 C Contribution to the local-electrostatic energy coming from the i-j pair
3000           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3001      &     +a33*muij(4)
3002 #ifdef DEBUG
3003           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3004      &     " a33",a33
3005           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3006      &     " wel_loc",wel_loc
3007 #endif
3008           if (shield_mode.eq.0) then
3009            fac_shield(i)=1.0
3010            fac_shield(j)=1.0
3011 C          else
3012 C           fac_shield(i)=0.4
3013 C           fac_shield(j)=0.6
3014           endif
3015           eel_loc_ij=eel_loc_ij
3016      &    *fac_shield(i)*fac_shield(j)
3017           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3018      &            'eelloc',i,j,eel_loc_ij
3019 c           if (eel_loc_ij.ne.0)
3020 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3021 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3022
3023           eel_loc=eel_loc+eel_loc_ij
3024 C Now derivative over eel_loc
3025           if (calc_grad) then
3026           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3027      &  (shield_mode.gt.0)) then
3028 C          print *,i,j
3029
3030           do ilist=1,ishield_list(i)
3031            iresshield=shield_list(ilist,i)
3032            do k=1,3
3033            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3034      &                                          /fac_shield(i)
3035 C     &      *2.0
3036            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3037      &              rlocshield
3038      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3039             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3040      &      +rlocshield
3041            enddo
3042           enddo
3043           do ilist=1,ishield_list(j)
3044            iresshield=shield_list(ilist,j)
3045            do k=1,3
3046            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3047      &                                       /fac_shield(j)
3048 C     &     *2.0
3049            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3050      &              rlocshield
3051      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3052            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3053      &             +rlocshield
3054
3055            enddo
3056           enddo
3057
3058           do k=1,3
3059             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3060      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3061             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3062      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3063             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3064      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3065             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3066      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3067            enddo
3068            endif
3069
3070
3071 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3072 c     &                     ' eel_loc_ij',eel_loc_ij
3073 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3074 C Calculate patrial derivative for theta angle
3075 #ifdef NEWCORR
3076          geel_loc_ij=(a22*gmuij1(1)
3077      &     +a23*gmuij1(2)
3078      &     +a32*gmuij1(3)
3079      &     +a33*gmuij1(4))
3080      &    *fac_shield(i)*fac_shield(j)
3081 c         write(iout,*) "derivative over thatai"
3082 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3083 c     &   a33*gmuij1(4)
3084          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3085      &      geel_loc_ij*wel_loc
3086 c         write(iout,*) "derivative over thatai-1"
3087 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3088 c     &   a33*gmuij2(4)
3089          geel_loc_ij=
3090      &     a22*gmuij2(1)
3091      &     +a23*gmuij2(2)
3092      &     +a32*gmuij2(3)
3093      &     +a33*gmuij2(4)
3094          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3095      &      geel_loc_ij*wel_loc
3096      &    *fac_shield(i)*fac_shield(j)
3097
3098 c  Derivative over j residue
3099          geel_loc_ji=a22*gmuji1(1)
3100      &     +a23*gmuji1(2)
3101      &     +a32*gmuji1(3)
3102      &     +a33*gmuji1(4)
3103 c         write(iout,*) "derivative over thataj"
3104 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3105 c     &   a33*gmuji1(4)
3106
3107         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3108      &      geel_loc_ji*wel_loc
3109      &    *fac_shield(i)*fac_shield(j)
3110
3111          geel_loc_ji=
3112      &     +a22*gmuji2(1)
3113      &     +a23*gmuji2(2)
3114      &     +a32*gmuji2(3)
3115      &     +a33*gmuji2(4)
3116 c         write(iout,*) "derivative over thataj-1"
3117 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3118 c     &   a33*gmuji2(4)
3119          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3120      &      geel_loc_ji*wel_loc
3121      &    *fac_shield(i)*fac_shield(j)
3122 #endif
3123 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3124
3125 C Partial derivatives in virtual-bond dihedral angles gamma
3126           if (i.gt.1)
3127      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3128      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3129      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3130      &    *fac_shield(i)*fac_shield(j)
3131
3132           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3133      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3134      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3135      &    *fac_shield(i)*fac_shield(j)
3136 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3137           do l=1,3
3138             ggg(l)=(agg(l,1)*muij(1)+
3139      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3140      &    *fac_shield(i)*fac_shield(j)
3141             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3142             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3143 cgrad            ghalf=0.5d0*ggg(l)
3144 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3145 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3146           enddo
3147 cgrad          do k=i+1,j2
3148 cgrad            do l=1,3
3149 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3150 cgrad            enddo
3151 cgrad          enddo
3152 C Remaining derivatives of eello
3153           do l=1,3
3154             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3155      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3156      &    *fac_shield(i)*fac_shield(j)
3157
3158             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3159      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3160      &    *fac_shield(i)*fac_shield(j)
3161
3162             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3163      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3164      &    *fac_shield(i)*fac_shield(j)
3165
3166             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3167      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3168      &    *fac_shield(i)*fac_shield(j)
3169
3170           enddo
3171           endif ! calc_grad
3172           ENDIF
3173
3174
3175 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3176 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3177           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3178      &       .and. num_conti.le.maxconts) then
3179 c            write (iout,*) i,j," entered corr"
3180 C
3181 C Calculate the contact function. The ith column of the array JCONT will
3182 C contain the numbers of atoms that make contacts with the atom I (of numbers
3183 C greater than I). The arrays FACONT and GACONT will contain the values of
3184 C the contact function and its derivative.
3185 c           r0ij=1.02D0*rpp(iteli,itelj)
3186 c           r0ij=1.11D0*rpp(iteli,itelj)
3187             r0ij=2.20D0*rpp(iteli,itelj)
3188 c           r0ij=1.55D0*rpp(iteli,itelj)
3189             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3190             if (fcont.gt.0.0D0) then
3191               num_conti=num_conti+1
3192               if (num_conti.gt.maxconts) then
3193                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3194      &                         ' will skip next contacts for this conf.'
3195               else
3196                 jcont_hb(num_conti,i)=j
3197 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3198 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3199                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3200      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3201 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3202 C  terms.
3203                 d_cont(num_conti,i)=rij
3204 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3205 C     --- Electrostatic-interaction matrix ---
3206                 a_chuj(1,1,num_conti,i)=a22
3207                 a_chuj(1,2,num_conti,i)=a23
3208                 a_chuj(2,1,num_conti,i)=a32
3209                 a_chuj(2,2,num_conti,i)=a33
3210 C     --- Gradient of rij
3211                 if (calc_grad) then
3212                 do kkk=1,3
3213                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3214                 enddo
3215                 kkll=0
3216                 do k=1,2
3217                   do l=1,2
3218                     kkll=kkll+1
3219                     do m=1,3
3220                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3221                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3222                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3223                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3224                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3225                     enddo
3226                   enddo
3227                 enddo
3228                 endif ! calc_grad
3229                 ENDIF
3230                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3231 C Calculate contact energies
3232                 cosa4=4.0D0*cosa
3233                 wij=cosa-3.0D0*cosb*cosg
3234                 cosbg1=cosb+cosg
3235                 cosbg2=cosb-cosg
3236 c               fac3=dsqrt(-ael6i)/r0ij**3
3237                 fac3=dsqrt(-ael6i)*r3ij
3238 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3239                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3240                 if (ees0tmp.gt.0) then
3241                   ees0pij=dsqrt(ees0tmp)
3242                 else
3243                   ees0pij=0
3244                 endif
3245 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3246                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3247                 if (ees0tmp.gt.0) then
3248                   ees0mij=dsqrt(ees0tmp)
3249                 else
3250                   ees0mij=0
3251                 endif
3252 c               ees0mij=0.0D0
3253                 if (shield_mode.eq.0) then
3254                 fac_shield(i)=1.0d0
3255                 fac_shield(j)=1.0d0
3256                 else
3257                 ees0plist(num_conti,i)=j
3258 C                fac_shield(i)=0.4d0
3259 C                fac_shield(j)=0.6d0
3260                 endif
3261                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3262      &          *fac_shield(i)*fac_shield(j)
3263                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3264      &          *fac_shield(i)*fac_shield(j)
3265 C Diagnostics. Comment out or remove after debugging!
3266 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3267 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3268 c               ees0m(num_conti,i)=0.0D0
3269 C End diagnostics.
3270 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3271 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3272 C Angular derivatives of the contact function
3273
3274                 ees0pij1=fac3/ees0pij
3275                 ees0mij1=fac3/ees0mij
3276                 fac3p=-3.0D0*fac3*rrmij
3277                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3278                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3279 c               ees0mij1=0.0D0
3280                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3281                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3282                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3283                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3284                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3285                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3286                 ecosap=ecosa1+ecosa2
3287                 ecosbp=ecosb1+ecosb2
3288                 ecosgp=ecosg1+ecosg2
3289                 ecosam=ecosa1-ecosa2
3290                 ecosbm=ecosb1-ecosb2
3291                 ecosgm=ecosg1-ecosg2
3292 C Diagnostics
3293 c               ecosap=ecosa1
3294 c               ecosbp=ecosb1
3295 c               ecosgp=ecosg1
3296 c               ecosam=0.0D0
3297 c               ecosbm=0.0D0
3298 c               ecosgm=0.0D0
3299 C End diagnostics
3300                 facont_hb(num_conti,i)=fcont
3301
3302                 if (calc_grad) then
3303                 fprimcont=fprimcont/rij
3304 cd              facont_hb(num_conti,i)=1.0D0
3305 C Following line is for diagnostics.
3306 cd              fprimcont=0.0D0
3307                 do k=1,3
3308                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3309                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3310                 enddo
3311                 do k=1,3
3312                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3313                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3314                 enddo
3315                 gggp(1)=gggp(1)+ees0pijp*xj
3316                 gggp(2)=gggp(2)+ees0pijp*yj
3317                 gggp(3)=gggp(3)+ees0pijp*zj
3318                 gggm(1)=gggm(1)+ees0mijp*xj
3319                 gggm(2)=gggm(2)+ees0mijp*yj
3320                 gggm(3)=gggm(3)+ees0mijp*zj
3321 C Derivatives due to the contact function
3322                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3323                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3324                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3325                 do k=1,3
3326 c
3327 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3328 c          following the change of gradient-summation algorithm.
3329 c
3330 cgrad                  ghalfp=0.5D0*gggp(k)
3331 cgrad                  ghalfm=0.5D0*gggm(k)
3332                   gacontp_hb1(k,num_conti,i)=!ghalfp
3333      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3334      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3335      &          *fac_shield(i)*fac_shield(j)
3336
3337                   gacontp_hb2(k,num_conti,i)=!ghalfp
3338      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3339      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3340      &          *fac_shield(i)*fac_shield(j)
3341
3342                   gacontp_hb3(k,num_conti,i)=gggp(k)
3343      &          *fac_shield(i)*fac_shield(j)
3344
3345                   gacontm_hb1(k,num_conti,i)=!ghalfm
3346      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3347      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3348      &          *fac_shield(i)*fac_shield(j)
3349
3350                   gacontm_hb2(k,num_conti,i)=!ghalfm
3351      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3352      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3353      &          *fac_shield(i)*fac_shield(j)
3354
3355                   gacontm_hb3(k,num_conti,i)=gggm(k)
3356      &          *fac_shield(i)*fac_shield(j)
3357
3358                 enddo
3359 C Diagnostics. Comment out or remove after debugging!
3360 cdiag           do k=1,3
3361 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3362 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3363 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3364 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3365 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3366 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3367 cdiag           enddo
3368
3369                  endif ! calc_grad
3370
3371               ENDIF ! wcorr
3372               endif  ! num_conti.le.maxconts
3373             endif  ! fcont.gt.0
3374           endif    ! j.gt.i+1
3375           if (calc_grad) then
3376           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3377             do k=1,4
3378               do l=1,3
3379                 ghalf=0.5d0*agg(l,k)
3380                 aggi(l,k)=aggi(l,k)+ghalf
3381                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3382                 aggj(l,k)=aggj(l,k)+ghalf
3383               enddo
3384             enddo
3385             if (j.eq.nres-1 .and. i.lt.j-2) then
3386               do k=1,4
3387                 do l=1,3
3388                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3389                 enddo
3390               enddo
3391             endif
3392           endif
3393           endif ! calc_grad
3394 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3395       return
3396       end
3397 C-----------------------------------------------------------------------------
3398       subroutine eturn3(i,eello_turn3)
3399 C Third- and fourth-order contributions from turns
3400       implicit real*8 (a-h,o-z)
3401       include 'DIMENSIONS'
3402       include 'DIMENSIONS.ZSCOPT'
3403       include 'COMMON.IOUNITS'
3404       include 'COMMON.GEO'
3405       include 'COMMON.VAR'
3406       include 'COMMON.LOCAL'
3407       include 'COMMON.CHAIN'
3408       include 'COMMON.DERIV'
3409       include 'COMMON.INTERACT'
3410       include 'COMMON.CONTACTS'
3411       include 'COMMON.TORSION'
3412       include 'COMMON.VECTORS'
3413       include 'COMMON.FFIELD'
3414       include 'COMMON.CONTROL'
3415       include 'COMMON.SHIELD'
3416       dimension ggg(3)
3417       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3418      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3419      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3420      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3421      &  auxgmat2(2,2),auxgmatt2(2,2)
3422       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3423      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3424       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3425      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3426      &    num_conti,j1,j2
3427       j=i+2
3428 c      write (iout,*) "eturn3",i,j,j1,j2
3429       a_temp(1,1)=a22
3430       a_temp(1,2)=a23
3431       a_temp(2,1)=a32
3432       a_temp(2,2)=a33
3433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3434 C
3435 C               Third-order contributions
3436 C
3437 C                 (i+2)o----(i+3)
3438 C                      | |
3439 C                      | |
3440 C                 (i+1)o----i
3441 C
3442 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3443 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3444         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3445 c auxalary matices for theta gradient
3446 c auxalary matrix for i+1 and constant i+2
3447         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3448 c auxalary matrix for i+2 and constant i+1
3449         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3450         call transpose2(auxmat(1,1),auxmat1(1,1))
3451         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3452         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3453         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3454         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3455         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3456         if (shield_mode.eq.0) then
3457         fac_shield(i)=1.0
3458         fac_shield(j)=1.0
3459 C        else
3460 C        fac_shield(i)=0.4
3461 C        fac_shield(j)=0.6
3462         endif
3463         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3464      &  *fac_shield(i)*fac_shield(j)
3465         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3466      &  *fac_shield(i)*fac_shield(j)
3467         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3468      &    eello_t3
3469         if (calc_grad) then
3470 C#ifdef NEWCORR
3471 C Derivatives in theta
3472         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3473      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3474      &   *fac_shield(i)*fac_shield(j)
3475         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3476      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3477      &   *fac_shield(i)*fac_shield(j)
3478 C#endif
3479
3480 C Derivatives in shield mode
3481           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3482      &  (shield_mode.gt.0)) then
3483 C          print *,i,j
3484
3485           do ilist=1,ishield_list(i)
3486            iresshield=shield_list(ilist,i)
3487            do k=1,3
3488            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3489 C     &      *2.0
3490            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3491      &              rlocshield
3492      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3493             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3494      &      +rlocshield
3495            enddo
3496           enddo
3497           do ilist=1,ishield_list(j)
3498            iresshield=shield_list(ilist,j)
3499            do k=1,3
3500            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3501 C     &     *2.0
3502            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3503      &              rlocshield
3504      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3505            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3506      &             +rlocshield
3507
3508            enddo
3509           enddo
3510
3511           do k=1,3
3512             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3513      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3514             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3515      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3516             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3517      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3518             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3519      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3520            enddo
3521            endif
3522
3523 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3524 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3525 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3526 cd     &    ' eello_turn3_num',4*eello_turn3_num
3527 C Derivatives in gamma(i)
3528         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3529         call transpose2(auxmat2(1,1),auxmat3(1,1))
3530         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3531         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3532      &   *fac_shield(i)*fac_shield(j)
3533 C Derivatives in gamma(i+1)
3534         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3535         call transpose2(auxmat2(1,1),auxmat3(1,1))
3536         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3537         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3538      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3539      &   *fac_shield(i)*fac_shield(j)
3540 C Cartesian derivatives
3541         do l=1,3
3542 c            ghalf1=0.5d0*agg(l,1)
3543 c            ghalf2=0.5d0*agg(l,2)
3544 c            ghalf3=0.5d0*agg(l,3)
3545 c            ghalf4=0.5d0*agg(l,4)
3546           a_temp(1,1)=aggi(l,1)!+ghalf1
3547           a_temp(1,2)=aggi(l,2)!+ghalf2
3548           a_temp(2,1)=aggi(l,3)!+ghalf3
3549           a_temp(2,2)=aggi(l,4)!+ghalf4
3550           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3551           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3552      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3553      &   *fac_shield(i)*fac_shield(j)
3554
3555           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3556           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3557           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3558           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3559           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3560           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3561      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3562      &   *fac_shield(i)*fac_shield(j)
3563           a_temp(1,1)=aggj(l,1)!+ghalf1
3564           a_temp(1,2)=aggj(l,2)!+ghalf2
3565           a_temp(2,1)=aggj(l,3)!+ghalf3
3566           a_temp(2,2)=aggj(l,4)!+ghalf4
3567           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3568           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3569      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3570      &   *fac_shield(i)*fac_shield(j)
3571           a_temp(1,1)=aggj1(l,1)
3572           a_temp(1,2)=aggj1(l,2)
3573           a_temp(2,1)=aggj1(l,3)
3574           a_temp(2,2)=aggj1(l,4)
3575           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3576           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3577      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3578      &   *fac_shield(i)*fac_shield(j)
3579         enddo
3580
3581         endif ! calc_grad
3582
3583       return
3584       end
3585 C-------------------------------------------------------------------------------
3586       subroutine eturn4(i,eello_turn4)
3587 C Third- and fourth-order contributions from turns
3588       implicit real*8 (a-h,o-z)
3589       include 'DIMENSIONS'
3590       include 'DIMENSIONS.ZSCOPT'
3591       include 'COMMON.IOUNITS'
3592       include 'COMMON.GEO'
3593       include 'COMMON.VAR'
3594       include 'COMMON.LOCAL'
3595       include 'COMMON.CHAIN'
3596       include 'COMMON.DERIV'
3597       include 'COMMON.INTERACT'
3598       include 'COMMON.CONTACTS'
3599       include 'COMMON.TORSION'
3600       include 'COMMON.VECTORS'
3601       include 'COMMON.FFIELD'
3602       include 'COMMON.CONTROL'
3603       include 'COMMON.SHIELD'
3604       dimension ggg(3)
3605       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3606      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3607      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3608      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3609      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3610      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3611      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3612       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3613      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3614       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3615      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3616      &    num_conti,j1,j2
3617       j=i+3
3618 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3619 C
3620 C               Fourth-order contributions
3621 C
3622 C                 (i+3)o----(i+4)
3623 C                     /  |
3624 C               (i+2)o   |
3625 C                     \  |
3626 C                 (i+1)o----i
3627 C
3628 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3629 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3630 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3631 c        write(iout,*)"WCHODZE W PROGRAM"
3632         a_temp(1,1)=a22
3633         a_temp(1,2)=a23
3634         a_temp(2,1)=a32
3635         a_temp(2,2)=a33
3636         iti1=itype2loc(itype(i+1))
3637         iti2=itype2loc(itype(i+2))
3638         iti3=itype2loc(itype(i+3))
3639 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3640         call transpose2(EUg(1,1,i+1),e1t(1,1))
3641         call transpose2(Eug(1,1,i+2),e2t(1,1))
3642         call transpose2(Eug(1,1,i+3),e3t(1,1))
3643 C Ematrix derivative in theta
3644         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3645         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3646         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3647         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3648 c       eta1 in derivative theta
3649         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3650         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3651 c       auxgvec is derivative of Ub2 so i+3 theta
3652         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3653 c       auxalary matrix of E i+1
3654         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3655 c        s1=0.0
3656 c        gs1=0.0
3657         s1=scalar2(b1(1,i+2),auxvec(1))
3658 c derivative of theta i+2 with constant i+3
3659         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3660 c derivative of theta i+2 with constant i+2
3661         gs32=scalar2(b1(1,i+2),auxgvec(1))
3662 c derivative of E matix in theta of i+1
3663         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3664
3665         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3666 c       ea31 in derivative theta
3667         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3668         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3669 c auxilary matrix auxgvec of Ub2 with constant E matirx
3670         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3671 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3672         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3673
3674 c        s2=0.0
3675 c        gs2=0.0
3676         s2=scalar2(b1(1,i+1),auxvec(1))
3677 c derivative of theta i+1 with constant i+3
3678         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3679 c derivative of theta i+2 with constant i+1
3680         gs21=scalar2(b1(1,i+1),auxgvec(1))
3681 c derivative of theta i+3 with constant i+1
3682         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3683 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3684 c     &  gtb1(1,i+1)
3685         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3686 c two derivatives over diffetent matrices
3687 c gtae3e2 is derivative over i+3
3688         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3689 c ae3gte2 is derivative over i+2
3690         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3691         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3692 c three possible derivative over theta E matices
3693 c i+1
3694         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3695 c i+2
3696         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3697 c i+3
3698         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3699         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3700
3701         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3702         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3703         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3704         if (shield_mode.eq.0) then
3705         fac_shield(i)=1.0
3706         fac_shield(j)=1.0
3707 C        else
3708 C        fac_shield(i)=0.6
3709 C        fac_shield(j)=0.4
3710         endif
3711         eello_turn4=eello_turn4-(s1+s2+s3)
3712      &  *fac_shield(i)*fac_shield(j)
3713         eello_t4=-(s1+s2+s3)
3714      &  *fac_shield(i)*fac_shield(j)
3715 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3716         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3717      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3718 C Now derivative over shield:
3719           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3720      &  (shield_mode.gt.0)) then
3721 C          print *,i,j
3722
3723           do ilist=1,ishield_list(i)
3724            iresshield=shield_list(ilist,i)
3725            do k=1,3
3726            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3727 C     &      *2.0
3728            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3729      &              rlocshield
3730      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3731             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3732      &      +rlocshield
3733            enddo
3734           enddo
3735           do ilist=1,ishield_list(j)
3736            iresshield=shield_list(ilist,j)
3737            do k=1,3
3738            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3739 C     &     *2.0
3740            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3741      &              rlocshield
3742      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3743            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3744      &             +rlocshield
3745
3746            enddo
3747           enddo
3748
3749           do k=1,3
3750             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3751      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3752             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3753      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3754             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3755      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3756             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3757      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3758            enddo
3759            endif
3760 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3761 cd     &    ' eello_turn4_num',8*eello_turn4_num
3762 #ifdef NEWCORR
3763         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3764      &                  -(gs13+gsE13+gsEE1)*wturn4
3765      &  *fac_shield(i)*fac_shield(j)
3766         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3767      &                    -(gs23+gs21+gsEE2)*wturn4
3768      &  *fac_shield(i)*fac_shield(j)
3769
3770         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3771      &                    -(gs32+gsE31+gsEE3)*wturn4
3772      &  *fac_shield(i)*fac_shield(j)
3773
3774 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3775 c     &   gs2
3776 #endif
3777         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3778      &      'eturn4',i,j,-(s1+s2+s3)
3779 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3780 c     &    ' eello_turn4_num',8*eello_turn4_num
3781 C Derivatives in gamma(i)
3782         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3783         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3784         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3785         s1=scalar2(b1(1,i+2),auxvec(1))
3786         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3787         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3788         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3789      &  *fac_shield(i)*fac_shield(j)
3790 C Derivatives in gamma(i+1)
3791         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3792         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3793         s2=scalar2(b1(1,i+1),auxvec(1))
3794         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3795         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3796         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3797         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3798      &  *fac_shield(i)*fac_shield(j)
3799 C Derivatives in gamma(i+2)
3800         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3801         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3802         s1=scalar2(b1(1,i+2),auxvec(1))
3803         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3804         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3805         s2=scalar2(b1(1,i+1),auxvec(1))
3806         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3807         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3808         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3809         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3810      &  *fac_shield(i)*fac_shield(j)
3811         if (calc_grad) then
3812 C Cartesian derivatives
3813 C Derivatives of this turn contributions in DC(i+2)
3814         if (j.lt.nres-1) then
3815           do l=1,3
3816             a_temp(1,1)=agg(l,1)
3817             a_temp(1,2)=agg(l,2)
3818             a_temp(2,1)=agg(l,3)
3819             a_temp(2,2)=agg(l,4)
3820             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3821             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3822             s1=scalar2(b1(1,i+2),auxvec(1))
3823             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3824             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3825             s2=scalar2(b1(1,i+1),auxvec(1))
3826             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3827             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3828             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3829             ggg(l)=-(s1+s2+s3)
3830             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3831      &  *fac_shield(i)*fac_shield(j)
3832           enddo
3833         endif
3834 C Remaining derivatives of this turn contribution
3835         do l=1,3
3836           a_temp(1,1)=aggi(l,1)
3837           a_temp(1,2)=aggi(l,2)
3838           a_temp(2,1)=aggi(l,3)
3839           a_temp(2,2)=aggi(l,4)
3840           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3841           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3842           s1=scalar2(b1(1,i+2),auxvec(1))
3843           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3844           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3845           s2=scalar2(b1(1,i+1),auxvec(1))
3846           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3847           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3848           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3849           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3850      &  *fac_shield(i)*fac_shield(j)
3851           a_temp(1,1)=aggi1(l,1)
3852           a_temp(1,2)=aggi1(l,2)
3853           a_temp(2,1)=aggi1(l,3)
3854           a_temp(2,2)=aggi1(l,4)
3855           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3856           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3857           s1=scalar2(b1(1,i+2),auxvec(1))
3858           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3859           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3860           s2=scalar2(b1(1,i+1),auxvec(1))
3861           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3862           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3863           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3864           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3865      &  *fac_shield(i)*fac_shield(j)
3866           a_temp(1,1)=aggj(l,1)
3867           a_temp(1,2)=aggj(l,2)
3868           a_temp(2,1)=aggj(l,3)
3869           a_temp(2,2)=aggj(l,4)
3870           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3871           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3872           s1=scalar2(b1(1,i+2),auxvec(1))
3873           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3874           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3875           s2=scalar2(b1(1,i+1),auxvec(1))
3876           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3877           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3878           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3879           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3880      &  *fac_shield(i)*fac_shield(j)
3881           a_temp(1,1)=aggj1(l,1)
3882           a_temp(1,2)=aggj1(l,2)
3883           a_temp(2,1)=aggj1(l,3)
3884           a_temp(2,2)=aggj1(l,4)
3885           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3886           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3887           s1=scalar2(b1(1,i+2),auxvec(1))
3888           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3889           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3890           s2=scalar2(b1(1,i+1),auxvec(1))
3891           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3892           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3893           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3894 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3895           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3896      &  *fac_shield(i)*fac_shield(j)
3897         enddo
3898
3899         endif ! calc_grad
3900
3901       return
3902       end
3903 C-----------------------------------------------------------------------------
3904       subroutine vecpr(u,v,w)
3905       implicit real*8(a-h,o-z)
3906       dimension u(3),v(3),w(3)
3907       w(1)=u(2)*v(3)-u(3)*v(2)
3908       w(2)=-u(1)*v(3)+u(3)*v(1)
3909       w(3)=u(1)*v(2)-u(2)*v(1)
3910       return
3911       end
3912 C-----------------------------------------------------------------------------
3913       subroutine unormderiv(u,ugrad,unorm,ungrad)
3914 C This subroutine computes the derivatives of a normalized vector u, given
3915 C the derivatives computed without normalization conditions, ugrad. Returns
3916 C ungrad.
3917       implicit none
3918       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3919       double precision vec(3)
3920       double precision scalar
3921       integer i,j
3922 c      write (2,*) 'ugrad',ugrad
3923 c      write (2,*) 'u',u
3924       do i=1,3
3925         vec(i)=scalar(ugrad(1,i),u(1))
3926       enddo
3927 c      write (2,*) 'vec',vec
3928       do i=1,3
3929         do j=1,3
3930           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3931         enddo
3932       enddo
3933 c      write (2,*) 'ungrad',ungrad
3934       return
3935       end
3936 C-----------------------------------------------------------------------------
3937       subroutine escp(evdw2,evdw2_14)
3938 C
3939 C This subroutine calculates the excluded-volume interaction energy between
3940 C peptide-group centers and side chains and its gradient in virtual-bond and
3941 C side-chain vectors.
3942 C
3943       implicit real*8 (a-h,o-z)
3944       include 'DIMENSIONS'
3945       include 'DIMENSIONS.ZSCOPT'
3946       include 'COMMON.CONTROL'
3947       include 'COMMON.GEO'
3948       include 'COMMON.VAR'
3949       include 'COMMON.LOCAL'
3950       include 'COMMON.CHAIN'
3951       include 'COMMON.DERIV'
3952       include 'COMMON.INTERACT'
3953       include 'COMMON.FFIELD'
3954       include 'COMMON.IOUNITS'
3955       dimension ggg(3)
3956       evdw2=0.0D0
3957       evdw2_14=0.0d0
3958 cd    print '(a)','Enter ESCP'
3959 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3960 c     &  ' scal14',scal14
3961       do i=iatscp_s,iatscp_e
3962         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3963         iteli=itel(i)
3964 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3965 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3966         if (iteli.eq.0) goto 1225
3967         xi=0.5D0*(c(1,i)+c(1,i+1))
3968         yi=0.5D0*(c(2,i)+c(2,i+1))
3969         zi=0.5D0*(c(3,i)+c(3,i+1))
3970 C Returning the ith atom to box
3971           xi=mod(xi,boxxsize)
3972           if (xi.lt.0) xi=xi+boxxsize
3973           yi=mod(yi,boxysize)
3974           if (yi.lt.0) yi=yi+boxysize
3975           zi=mod(zi,boxzsize)
3976           if (zi.lt.0) zi=zi+boxzsize
3977         do iint=1,nscp_gr(i)
3978
3979         do j=iscpstart(i,iint),iscpend(i,iint)
3980           itypj=iabs(itype(j))
3981           if (itypj.eq.ntyp1) cycle
3982 C Uncomment following three lines for SC-p interactions
3983 c         xj=c(1,nres+j)-xi
3984 c         yj=c(2,nres+j)-yi
3985 c         zj=c(3,nres+j)-zi
3986 C Uncomment following three lines for Ca-p interactions
3987           xj=c(1,j)
3988           yj=c(2,j)
3989           zj=c(3,j)
3990 C returning the jth atom to box
3991           xj=mod(xj,boxxsize)
3992           if (xj.lt.0) xj=xj+boxxsize
3993           yj=mod(yj,boxysize)
3994           if (yj.lt.0) yj=yj+boxysize
3995           zj=mod(zj,boxzsize)
3996           if (zj.lt.0) zj=zj+boxzsize
3997       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3998       xj_safe=xj
3999       yj_safe=yj
4000       zj_safe=zj
4001       subchap=0
4002 C Finding the closest jth atom
4003       do xshift=-1,1
4004       do yshift=-1,1
4005       do zshift=-1,1
4006           xj=xj_safe+xshift*boxxsize
4007           yj=yj_safe+yshift*boxysize
4008           zj=zj_safe+zshift*boxzsize
4009           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4010           if(dist_temp.lt.dist_init) then
4011             dist_init=dist_temp
4012             xj_temp=xj
4013             yj_temp=yj
4014             zj_temp=zj
4015             subchap=1
4016           endif
4017        enddo
4018        enddo
4019        enddo
4020        if (subchap.eq.1) then
4021           xj=xj_temp-xi
4022           yj=yj_temp-yi
4023           zj=zj_temp-zi
4024        else
4025           xj=xj_safe-xi
4026           yj=yj_safe-yi
4027           zj=zj_safe-zi
4028        endif
4029           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4030 C sss is scaling function for smoothing the cutoff gradient otherwise
4031 C the gradient would not be continuouse
4032           sss=sscale(1.0d0/(dsqrt(rrij)))
4033           if (sss.le.0.0d0) cycle
4034           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4035           fac=rrij**expon2
4036           e1=fac*fac*aad(itypj,iteli)
4037           e2=fac*bad(itypj,iteli)
4038           if (iabs(j-i) .le. 2) then
4039             e1=scal14*e1
4040             e2=scal14*e2
4041             evdw2_14=evdw2_14+(e1+e2)*sss
4042           endif
4043           evdwij=e1+e2
4044 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4045 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4046 c     &       bad(itypj,iteli)
4047           evdw2=evdw2+evdwij*sss
4048           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4049      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4050      &       bad(itypj,iteli)
4051
4052           if (calc_grad) then
4053 C
4054 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4055 C
4056           fac=-(evdwij+e1)*rrij*sss
4057           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4058           ggg(1)=xj*fac
4059           ggg(2)=yj*fac
4060           ggg(3)=zj*fac
4061           if (j.lt.i) then
4062 cd          write (iout,*) 'j<i'
4063 C Uncomment following three lines for SC-p interactions
4064 c           do k=1,3
4065 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4066 c           enddo
4067           else
4068 cd          write (iout,*) 'j>i'
4069             do k=1,3
4070               ggg(k)=-ggg(k)
4071 C Uncomment following line for SC-p interactions
4072 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4073             enddo
4074           endif
4075           do k=1,3
4076             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4077           enddo
4078           kstart=min0(i+1,j)
4079           kend=max0(i-1,j-1)
4080 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4081 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4082           do k=kstart,kend
4083             do l=1,3
4084               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4085             enddo
4086           enddo
4087           endif ! calc_grad
4088         enddo
4089         enddo ! iint
4090  1225   continue
4091       enddo ! i
4092       do i=1,nct
4093         do j=1,3
4094           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4095           gradx_scp(j,i)=expon*gradx_scp(j,i)
4096         enddo
4097       enddo
4098 C******************************************************************************
4099 C
4100 C                              N O T E !!!
4101 C
4102 C To save time the factor EXPON has been extracted from ALL components
4103 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4104 C use!
4105 C
4106 C******************************************************************************
4107       return
4108       end
4109 C--------------------------------------------------------------------------
4110       subroutine edis(ehpb)
4111 C
4112 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4113 C
4114       implicit real*8 (a-h,o-z)
4115       include 'DIMENSIONS'
4116       include 'DIMENSIONS.ZSCOPT'
4117       include 'COMMON.SBRIDGE'
4118       include 'COMMON.CHAIN'
4119       include 'COMMON.DERIV'
4120       include 'COMMON.VAR'
4121       include 'COMMON.INTERACT'
4122       include 'COMMON.CONTROL'
4123       include 'COMMON.IOUNITS'
4124       dimension ggg(3),ggg_peak(3,1000)
4125       ehpb=0.0D0
4126       do i=1,3
4127        ggg(i)=0.0d0
4128       enddo
4129 c 8/21/18 AL: added explicit restraints on reference coords
4130 c      write (iout,*) "restr_on_coord",restr_on_coord
4131       if (restr_on_coord) then
4132
4133       do i=nnt,nct
4134         ecoor=0.0d0
4135         if (itype(i).eq.ntyp1) cycle
4136         do j=1,3
4137           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4138           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4139         enddo
4140         if (itype(i).ne.10) then
4141           do j=1,3
4142             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4143             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4144           enddo
4145         endif
4146         if (energy_dec) write (iout,*)
4147      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4148         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4149       enddo
4150
4151       endif
4152
4153 C      write (iout,*) ,"link_end",link_end,constr_dist
4154 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4155 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4156 c     &  " constr_dist",constr_dist
4157       if (link_end.eq.0.and.link_end_peak.eq.0) return
4158       do i=link_start_peak,link_end_peak
4159         ehpb_peak=0.0d0
4160 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4161 c     &   ipeak(1,i),ipeak(2,i)
4162         do ip=ipeak(1,i),ipeak(2,i)
4163           ii=ihpb_peak(ip)
4164           jj=jhpb_peak(ip)
4165           dd=dist(ii,jj)
4166           iip=ip-ipeak(1,i)+1
4167 C iii and jjj point to the residues for which the distance is assigned.
4168 c          if (ii.gt.nres) then
4169 c            iii=ii-nres
4170 c            jjj=jj-nres
4171 c          else
4172 c            iii=ii
4173 c            jjj=jj
4174 c          endif
4175           if (ii.gt.nres) then
4176             iii=ii-nres
4177           else
4178             iii=ii
4179           endif
4180           if (jj.gt.nres) then
4181             jjj=jj-nres
4182           else
4183             jjj=jj
4184           endif
4185           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4186           aux=dexp(-scal_peak*aux)
4187           ehpb_peak=ehpb_peak+aux
4188           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4189      &      forcon_peak(ip))*aux/dd
4190           do j=1,3
4191             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4192           enddo
4193           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4194      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4195      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4196         enddo
4197 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4198         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4199         do ip=ipeak(1,i),ipeak(2,i)
4200           iip=ip-ipeak(1,i)+1
4201           do j=1,3
4202             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4203           enddo
4204           ii=ihpb_peak(ip)
4205           jj=jhpb_peak(ip)
4206 C iii and jjj point to the residues for which the distance is assigned.
4207           if (ii.gt.nres) then
4208             iii=ii-nres
4209             jjj=jj-nres
4210           else
4211             iii=ii
4212             jjj=jj
4213           endif
4214           if (iii.lt.ii) then
4215             do j=1,3
4216               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4217             enddo
4218           endif
4219           if (jjj.lt.jj) then
4220             do j=1,3
4221               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4222             enddo
4223           endif
4224           do k=1,3
4225             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4226             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4227           enddo
4228         enddo
4229       enddo
4230       do i=link_start,link_end
4231 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4232 C CA-CA distance used in regularization of structure.
4233         ii=ihpb(i)
4234         jj=jhpb(i)
4235 C iii and jjj point to the residues for which the distance is assigned.
4236         if (ii.gt.nres) then
4237           iii=ii-nres
4238         else
4239           iii=ii
4240         endif
4241         if (jj.gt.nres) then
4242           jjj=jj-nres
4243         else
4244           jjj=jj
4245         endif
4246 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4247 c     &    dhpb(i),dhpb1(i),forcon(i)
4248 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4249 C    distance and angle dependent SS bond potential.
4250 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4251 C     & iabs(itype(jjj)).eq.1) then
4252 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4253 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4254         if (.not.dyn_ss .and. i.le.nss) then
4255 C 15/02/13 CC dynamic SSbond - additional check
4256           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4257      &        iabs(itype(jjj)).eq.1) then
4258            call ssbond_ene(iii,jjj,eij)
4259            ehpb=ehpb+2*eij
4260          endif
4261 cd          write (iout,*) "eij",eij
4262 cd   &   ' waga=',waga,' fac=',fac
4263 !        else if (ii.gt.nres .and. jj.gt.nres) then
4264         else
4265 C Calculate the distance between the two points and its difference from the
4266 C target distance.
4267           dd=dist(ii,jj)
4268           if (irestr_type(i).eq.11) then
4269             ehpb=ehpb+fordepth(i)!**4.0d0
4270      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4271             fac=fordepth(i)!**4.0d0
4272      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4273             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4274      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4275      &        ehpb,irestr_type(i)
4276           else if (irestr_type(i).eq.10) then
4277 c AL 6//19/2018 cross-link restraints
4278             xdis = 0.5d0*(dd/forcon(i))**2
4279             expdis = dexp(-xdis)
4280 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4281             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4282 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4283 c     &          " wboltzd",wboltzd
4284             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4285 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4286             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4287      &           *expdis/(aux*forcon(i)**2)
4288             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4289      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4290      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4291           else if (irestr_type(i).eq.2) then
4292 c Quartic restraints
4293             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4294             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4295      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4296      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4297             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4298           else
4299 c Quadratic restraints
4300             rdis=dd-dhpb(i)
4301 C Get the force constant corresponding to this distance.
4302             waga=forcon(i)
4303 C Calculate the contribution to energy.
4304             ehpb=ehpb+0.5d0*waga*rdis*rdis
4305             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4306      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4307      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4308 C
4309 C Evaluate gradient.
4310 C
4311             fac=waga*rdis/dd
4312           endif
4313 c Calculate Cartesian gradient
4314           do j=1,3
4315             ggg(j)=fac*(c(j,jj)-c(j,ii))
4316           enddo
4317 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4318 C If this is a SC-SC distance, we need to calculate the contributions to the
4319 C Cartesian gradient in the SC vectors (ghpbx).
4320           if (iii.lt.ii) then
4321             do j=1,3
4322               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4323             enddo
4324           endif
4325           if (jjj.lt.jj) then
4326             do j=1,3
4327               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4328             enddo
4329           endif
4330           do k=1,3
4331             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4332             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4333           enddo
4334         endif
4335       enddo
4336       return
4337       end
4338 C--------------------------------------------------------------------------
4339       subroutine ssbond_ene(i,j,eij)
4340 C
4341 C Calculate the distance and angle dependent SS-bond potential energy
4342 C using a free-energy function derived based on RHF/6-31G** ab initio
4343 C calculations of diethyl disulfide.
4344 C
4345 C A. Liwo and U. Kozlowska, 11/24/03
4346 C
4347       implicit real*8 (a-h,o-z)
4348       include 'DIMENSIONS'
4349       include 'DIMENSIONS.ZSCOPT'
4350       include 'COMMON.SBRIDGE'
4351       include 'COMMON.CHAIN'
4352       include 'COMMON.DERIV'
4353       include 'COMMON.LOCAL'
4354       include 'COMMON.INTERACT'
4355       include 'COMMON.VAR'
4356       include 'COMMON.IOUNITS'
4357       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4358       itypi=iabs(itype(i))
4359       xi=c(1,nres+i)
4360       yi=c(2,nres+i)
4361       zi=c(3,nres+i)
4362       dxi=dc_norm(1,nres+i)
4363       dyi=dc_norm(2,nres+i)
4364       dzi=dc_norm(3,nres+i)
4365       dsci_inv=dsc_inv(itypi)
4366       itypj=iabs(itype(j))
4367       dscj_inv=dsc_inv(itypj)
4368       xj=c(1,nres+j)-xi
4369       yj=c(2,nres+j)-yi
4370       zj=c(3,nres+j)-zi
4371       dxj=dc_norm(1,nres+j)
4372       dyj=dc_norm(2,nres+j)
4373       dzj=dc_norm(3,nres+j)
4374       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4375       rij=dsqrt(rrij)
4376       erij(1)=xj*rij
4377       erij(2)=yj*rij
4378       erij(3)=zj*rij
4379       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4380       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4381       om12=dxi*dxj+dyi*dyj+dzi*dzj
4382       do k=1,3
4383         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4384         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4385       enddo
4386       rij=1.0d0/rij
4387       deltad=rij-d0cm
4388       deltat1=1.0d0-om1
4389       deltat2=1.0d0+om2
4390       deltat12=om2-om1+2.0d0
4391       cosphi=om12-om1*om2
4392       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4393      &  +akct*deltad*deltat12
4394      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4395 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4396 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4397 c     &  " deltat12",deltat12," eij",eij
4398       ed=2*akcm*deltad+akct*deltat12
4399       pom1=akct*deltad
4400       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4401       eom1=-2*akth*deltat1-pom1-om2*pom2
4402       eom2= 2*akth*deltat2+pom1-om1*pom2
4403       eom12=pom2
4404       do k=1,3
4405         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4406       enddo
4407       do k=1,3
4408         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4409      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4410         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4411      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4412       enddo
4413 C
4414 C Calculate the components of the gradient in DC and X
4415 C
4416       do k=i,j-1
4417         do l=1,3
4418           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4419         enddo
4420       enddo
4421       return
4422       end
4423 C--------------------------------------------------------------------------
4424 c MODELLER restraint function
4425       subroutine e_modeller(ehomology_constr)
4426       implicit real*8 (a-h,o-z)
4427       include 'DIMENSIONS'
4428       include 'DIMENSIONS.ZSCOPT'
4429       include 'DIMENSIONS.FREE'
4430       integer nnn, i, j, k, ki, irec, l
4431       integer katy, odleglosci, test7
4432       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4433       real*8 distance(max_template),distancek(max_template),
4434      &    min_odl,godl(max_template),dih_diff(max_template)
4435
4436 c
4437 c     FP - 30/10/2014 Temporary specifications for homology restraints
4438 c
4439       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4440      &                 sgtheta
4441       double precision, dimension (maxres) :: guscdiff,usc_diff
4442       double precision, dimension (max_template) ::
4443      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4444      &           theta_diff
4445
4446       include 'COMMON.SBRIDGE'
4447       include 'COMMON.CHAIN'
4448       include 'COMMON.GEO'
4449       include 'COMMON.DERIV'
4450       include 'COMMON.LOCAL'
4451       include 'COMMON.INTERACT'
4452       include 'COMMON.VAR'
4453       include 'COMMON.IOUNITS'
4454       include 'COMMON.CONTROL'
4455       include 'COMMON.HOMRESTR'
4456       include 'COMMON.HOMOLOGY'
4457       include 'COMMON.SETUP'
4458       include 'COMMON.NAMES'
4459
4460       do i=1,max_template
4461         distancek(i)=9999999.9
4462       enddo
4463
4464       odleg=0.0d0
4465
4466 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4467 c function)
4468 C AL 5/2/14 - Introduce list of restraints
4469 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4470 #ifdef DEBUG
4471       write(iout,*) "------- dist restrs start -------"
4472 #endif
4473       do ii = link_start_homo,link_end_homo
4474          i = ires_homo(ii)
4475          j = jres_homo(ii)
4476          dij=dist(i,j)
4477 c        write (iout,*) "dij(",i,j,") =",dij
4478          nexl=0
4479          do k=1,constr_homology
4480            if(.not.l_homo(k,ii)) then
4481               nexl=nexl+1
4482               cycle
4483            endif
4484            distance(k)=odl(k,ii)-dij
4485 c          write (iout,*) "distance(",k,") =",distance(k)
4486 c
4487 c          For Gaussian-type Urestr
4488 c
4489            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4490 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4491 c          write (iout,*) "distancek(",k,") =",distancek(k)
4492 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4493 c
4494 c          For Lorentzian-type Urestr
4495 c
4496            if (waga_dist.lt.0.0d0) then
4497               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4498               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4499      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4500            endif
4501          enddo
4502
4503 c         min_odl=minval(distancek)
4504          do kk=1,constr_homology
4505           if(l_homo(kk,ii)) then
4506             min_odl=distancek(kk)
4507             exit
4508           endif
4509          enddo
4510          do kk=1,constr_homology
4511           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4512      &              min_odl=distancek(kk)
4513          enddo
4514 c        write (iout,* )"min_odl",min_odl
4515 #ifdef DEBUG
4516          write (iout,*) "ij dij",i,j,dij
4517          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4518          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4519          write (iout,* )"min_odl",min_odl
4520 #endif
4521 #ifdef OLDRESTR
4522          odleg2=0.0d0
4523 #else
4524          if (waga_dist.ge.0.0d0) then
4525            odleg2=nexl
4526          else
4527            odleg2=0.0d0
4528          endif
4529 #endif
4530          do k=1,constr_homology
4531 c Nie wiem po co to liczycie jeszcze raz!
4532 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4533 c     &              (2*(sigma_odl(i,j,k))**2))
4534            if(.not.l_homo(k,ii)) cycle
4535            if (waga_dist.ge.0.0d0) then
4536 c
4537 c          For Gaussian-type Urestr
4538 c
4539             godl(k)=dexp(-distancek(k)+min_odl)
4540             odleg2=odleg2+godl(k)
4541 c
4542 c          For Lorentzian-type Urestr
4543 c
4544            else
4545             odleg2=odleg2+distancek(k)
4546            endif
4547
4548 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4549 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4550 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4551 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4552
4553          enddo
4554 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4555 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4556 #ifdef DEBUG
4557          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4558          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4559 #endif
4560            if (waga_dist.ge.0.0d0) then
4561 c
4562 c          For Gaussian-type Urestr
4563 c
4564               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4565 c
4566 c          For Lorentzian-type Urestr
4567 c
4568            else
4569               odleg=odleg+odleg2/constr_homology
4570            endif
4571 c
4572 #ifdef GRAD
4573 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4574 c Gradient
4575 c
4576 c          For Gaussian-type Urestr
4577 c
4578          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4579          sum_sgodl=0.0d0
4580          do k=1,constr_homology
4581 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4582 c     &           *waga_dist)+min_odl
4583 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4584 c
4585          if(.not.l_homo(k,ii)) cycle
4586          if (waga_dist.ge.0.0d0) then
4587 c          For Gaussian-type Urestr
4588 c
4589            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4590 c
4591 c          For Lorentzian-type Urestr
4592 c
4593          else
4594            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4595      &           sigma_odlir(k,ii)**2)**2)
4596          endif
4597            sum_sgodl=sum_sgodl+sgodl
4598
4599 c            sgodl2=sgodl2+sgodl
4600 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4601 c      write(iout,*) "constr_homology=",constr_homology
4602 c      write(iout,*) i, j, k, "TEST K"
4603          enddo
4604          if (waga_dist.ge.0.0d0) then
4605 c
4606 c          For Gaussian-type Urestr
4607 c
4608             grad_odl3=waga_homology(iset)*waga_dist
4609      &                *sum_sgodl/(sum_godl*dij)
4610 c
4611 c          For Lorentzian-type Urestr
4612 c
4613          else
4614 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4615 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4616             grad_odl3=-waga_homology(iset)*waga_dist*
4617      &                sum_sgodl/(constr_homology*dij)
4618          endif
4619 c
4620 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4621
4622
4623 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4624 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4625 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4626
4627 ccc      write(iout,*) godl, sgodl, grad_odl3
4628
4629 c          grad_odl=grad_odl+grad_odl3
4630
4631          do jik=1,3
4632             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4633 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4634 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4635 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4636             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4637             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4638 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4639 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4640 c         if (i.eq.25.and.j.eq.27) then
4641 c         write(iout,*) "jik",jik,"i",i,"j",j
4642 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4643 c         write(iout,*) "grad_odl3",grad_odl3
4644 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4645 c         write(iout,*) "ggodl",ggodl
4646 c         write(iout,*) "ghpbc(",jik,i,")",
4647 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4648 c     &                 ghpbc(jik,j)
4649 c         endif
4650          enddo
4651 #endif
4652 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4653 ccc     & dLOG(odleg2),"-odleg=", -odleg
4654
4655       enddo ! ii-loop for dist
4656 #ifdef DEBUG
4657       write(iout,*) "------- dist restrs end -------"
4658 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4659 c    &     waga_d.eq.1.0d0) call sum_gradient
4660 #endif
4661 c Pseudo-energy and gradient from dihedral-angle restraints from
4662 c homology templates
4663 c      write (iout,*) "End of distance loop"
4664 c      call flush(iout)
4665       kat=0.0d0
4666 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4667 #ifdef DEBUG
4668       write(iout,*) "------- dih restrs start -------"
4669       do i=idihconstr_start_homo,idihconstr_end_homo
4670         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4671       enddo
4672 #endif
4673       do i=idihconstr_start_homo,idihconstr_end_homo
4674         kat2=0.0d0
4675 c        betai=beta(i,i+1,i+2,i+3)
4676         betai = phi(i)
4677 c       write (iout,*) "betai =",betai
4678         do k=1,constr_homology
4679           dih_diff(k)=pinorm(dih(k,i)-betai)
4680 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4681 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4682 c     &                                   -(6.28318-dih_diff(i,k))
4683 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4684 c     &                                   6.28318+dih_diff(i,k)
4685 #ifdef OLD_DIHED
4686           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4687 #else
4688           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4689 #endif
4690 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4691           gdih(k)=dexp(kat3)
4692           kat2=kat2+gdih(k)
4693 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4694 c          write(*,*)""
4695         enddo
4696 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4697 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4698 #ifdef DEBUG
4699         write (iout,*) "i",i," betai",betai," kat2",kat2
4700         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4701 #endif
4702         if (kat2.le.1.0d-14) cycle
4703         kat=kat-dLOG(kat2/constr_homology)
4704 c       write (iout,*) "kat",kat ! sum of -ln-s
4705
4706 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4707 ccc     & dLOG(kat2), "-kat=", -kat
4708
4709 #ifdef GRAD
4710 c ----------------------------------------------------------------------
4711 c Gradient
4712 c ----------------------------------------------------------------------
4713
4714         sum_gdih=kat2
4715         sum_sgdih=0.0d0
4716         do k=1,constr_homology
4717 #ifdef OLD_DIHED
4718           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4719 #else
4720           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4721 #endif
4722 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4723           sum_sgdih=sum_sgdih+sgdih
4724         enddo
4725 c       grad_dih3=sum_sgdih/sum_gdih
4726         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4727
4728 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4729 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4730 ccc     & gloc(nphi+i-3,icg)
4731         gloc(i,icg)=gloc(i,icg)+grad_dih3
4732 c        if (i.eq.25) then
4733 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4734 c        endif
4735 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4736 ccc     & gloc(nphi+i-3,icg)
4737 #endif
4738       enddo ! i-loop for dih
4739 #ifdef DEBUG
4740       write(iout,*) "------- dih restrs end -------"
4741 #endif
4742
4743 c Pseudo-energy and gradient for theta angle restraints from
4744 c homology templates
4745 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4746 c adapted
4747
4748 c
4749 c     For constr_homology reference structures (FP)
4750 c
4751 c     Uconst_back_tot=0.0d0
4752       Eval=0.0d0
4753       Erot=0.0d0
4754 c     Econstr_back legacy
4755 #ifdef GRAD
4756       do i=1,nres
4757 c     do i=ithet_start,ithet_end
4758        dutheta(i)=0.0d0
4759 c     enddo
4760 c     do i=loc_start,loc_end
4761         do j=1,3
4762           duscdiff(j,i)=0.0d0
4763           duscdiffx(j,i)=0.0d0
4764         enddo
4765       enddo
4766 #endif
4767 c
4768 c     do iref=1,nref
4769 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4770 c     write (iout,*) "waga_theta",waga_theta
4771       if (waga_theta.gt.0.0d0) then
4772 #ifdef DEBUG
4773       write (iout,*) "usampl",usampl
4774       write(iout,*) "------- theta restrs start -------"
4775 c     do i=ithet_start,ithet_end
4776 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4777 c     enddo
4778 #endif
4779 c     write (iout,*) "maxres",maxres,"nres",nres
4780
4781       do i=ithet_start,ithet_end
4782 c
4783 c     do i=1,nfrag_back
4784 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4785 c
4786 c Deviation of theta angles wrt constr_homology ref structures
4787 c
4788         utheta_i=0.0d0 ! argument of Gaussian for single k
4789         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4790 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4791 c       over residues in a fragment
4792 c       write (iout,*) "theta(",i,")=",theta(i)
4793         do k=1,constr_homology
4794 c
4795 c         dtheta_i=theta(j)-thetaref(j,iref)
4796 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4797           theta_diff(k)=thetatpl(k,i)-theta(i)
4798 c
4799           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4800 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4801           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4802           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4803 c         Gradient for single Gaussian restraint in subr Econstr_back
4804 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4805 c
4806         enddo
4807 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4808 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4809
4810 c
4811 #ifdef GRAD
4812 c         Gradient for multiple Gaussian restraint
4813         sum_gtheta=gutheta_i
4814         sum_sgtheta=0.0d0
4815         do k=1,constr_homology
4816 c        New generalized expr for multiple Gaussian from Econstr_back
4817          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4818 c
4819 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4820           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4821         enddo
4822 c
4823 c       Final value of gradient using same var as in Econstr_back
4824         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4825      &               *waga_homology(iset)
4826 c       dutheta(i)=sum_sgtheta/sum_gtheta
4827 c
4828 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4829 #endif
4830         Eval=Eval-dLOG(gutheta_i/constr_homology)
4831 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4832 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4833 c       Uconst_back=Uconst_back+utheta(i)
4834       enddo ! (i-loop for theta)
4835 #ifdef DEBUG
4836       write(iout,*) "------- theta restrs end -------"
4837 #endif
4838       endif
4839 c
4840 c Deviation of local SC geometry
4841 c
4842 c Separation of two i-loops (instructed by AL - 11/3/2014)
4843 c
4844 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4845 c     write (iout,*) "waga_d",waga_d
4846
4847 #ifdef DEBUG
4848       write(iout,*) "------- SC restrs start -------"
4849       write (iout,*) "Initial duscdiff,duscdiffx"
4850       do i=loc_start,loc_end
4851         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4852      &                 (duscdiffx(jik,i),jik=1,3)
4853       enddo
4854 #endif
4855       do i=loc_start,loc_end
4856         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4857         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4858 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4859 c       write(iout,*) "xxtab, yytab, zztab"
4860 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4861         do k=1,constr_homology
4862 c
4863           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4864 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4865           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4866           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4867 c         write(iout,*) "dxx, dyy, dzz"
4868 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4869 c
4870           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4871 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4872 c         uscdiffk(k)=usc_diff(i)
4873           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4874           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4875 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4876 c     &      xxref(j),yyref(j),zzref(j)
4877         enddo
4878 c
4879 c       Gradient
4880 c
4881 c       Generalized expression for multiple Gaussian acc to that for a single
4882 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4883 c
4884 c       Original implementation
4885 c       sum_guscdiff=guscdiff(i)
4886 c
4887 c       sum_sguscdiff=0.0d0
4888 c       do k=1,constr_homology
4889 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4890 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4891 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4892 c       enddo
4893 c
4894 c       Implementation of new expressions for gradient (Jan. 2015)
4895 c
4896 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4897 #ifdef GRAD
4898         do k=1,constr_homology
4899 c
4900 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4901 c       before. Now the drivatives should be correct
4902 c
4903           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4904 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4905           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4906           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4907 c
4908 c         New implementation
4909 c
4910           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4911      &                 sigma_d(k,i) ! for the grad wrt r'
4912 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4913 c
4914 c
4915 c        New implementation
4916          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4917          do jik=1,3
4918             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4919      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4920      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4921             duscdiff(jik,i)=duscdiff(jik,i)+
4922      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4923      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4924             duscdiffx(jik,i)=duscdiffx(jik,i)+
4925      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4926      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4927 c
4928 #ifdef DEBUG
4929              write(iout,*) "jik",jik,"i",i
4930              write(iout,*) "dxx, dyy, dzz"
4931              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4932              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4933 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4934 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4935 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4936 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4937 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4938 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4939 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4940 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4941 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4942 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4943 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4944 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4945 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4946 c            endif
4947 #endif
4948          enddo
4949         enddo
4950 #endif
4951 c
4952 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4953 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4954 c
4955 c        write (iout,*) i," uscdiff",uscdiff(i)
4956 c
4957 c Put together deviations from local geometry
4958
4959 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4960 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4961         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4962 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4963 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4964 c       Uconst_back=Uconst_back+usc_diff(i)
4965 c
4966 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4967 c
4968 c     New implment: multiplied by sum_sguscdiff
4969 c
4970
4971       enddo ! (i-loop for dscdiff)
4972
4973 c      endif
4974
4975 #ifdef DEBUG
4976       write(iout,*) "------- SC restrs end -------"
4977         write (iout,*) "------ After SC loop in e_modeller ------"
4978         do i=loc_start,loc_end
4979          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4980          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4981         enddo
4982       if (waga_theta.eq.1.0d0) then
4983       write (iout,*) "in e_modeller after SC restr end: dutheta"
4984       do i=ithet_start,ithet_end
4985         write (iout,*) i,dutheta(i)
4986       enddo
4987       endif
4988       if (waga_d.eq.1.0d0) then
4989       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4990       do i=1,nres
4991         write (iout,*) i,(duscdiff(j,i),j=1,3)
4992         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4993       enddo
4994       endif
4995 #endif
4996
4997 c Total energy from homology restraints
4998 #ifdef DEBUG
4999       write (iout,*) "odleg",odleg," kat",kat
5000       write (iout,*) "odleg",odleg," kat",kat
5001       write (iout,*) "Eval",Eval," Erot",Erot
5002       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5003       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5004       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5005 #endif
5006 c
5007 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5008 c
5009 c     ehomology_constr=odleg+kat
5010 c
5011 c     For Lorentzian-type Urestr
5012 c
5013
5014       if (waga_dist.ge.0.0d0) then
5015 c
5016 c          For Gaussian-type Urestr
5017 c
5018 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5019 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5020         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5021      &              waga_theta*Eval+waga_d*Erot
5022 c     write (iout,*) "ehomology_constr=",ehomology_constr
5023       else
5024 c
5025 c          For Lorentzian-type Urestr
5026 c
5027 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5028 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5029         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5030      &              waga_theta*Eval+waga_d*Erot
5031 c     write (iout,*) "ehomology_constr=",ehomology_constr
5032       endif
5033 #ifdef DEBUG
5034       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5035      & "Eval",waga_theta,eval,
5036      &   "Erot",waga_d,Erot
5037       write (iout,*) "ehomology_constr",ehomology_constr
5038 #endif
5039       return
5040
5041   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5042   747 format(a12,i4,i4,i4,f8.3,f8.3)
5043   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5044   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5045   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5046      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5047       end
5048 c-----------------------------------------------------------------------
5049       subroutine ebond(estr)
5050 c
5051 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5052 c
5053       implicit real*8 (a-h,o-z)
5054       include 'DIMENSIONS'
5055       include 'DIMENSIONS.ZSCOPT'
5056       include 'COMMON.LOCAL'
5057       include 'COMMON.GEO'
5058       include 'COMMON.INTERACT'
5059       include 'COMMON.DERIV'
5060       include 'COMMON.VAR'
5061       include 'COMMON.CHAIN'
5062       include 'COMMON.IOUNITS'
5063       include 'COMMON.NAMES'
5064       include 'COMMON.FFIELD'
5065       include 'COMMON.CONTROL'
5066       double precision u(3),ud(3)
5067       estr=0.0d0
5068       estr1=0.0d0
5069 c      write (iout,*) "distchainmax",distchainmax
5070       do i=nnt+1,nct
5071         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5072 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5073 C          do j=1,3
5074 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5075 C     &      *dc(j,i-1)/vbld(i)
5076 C          enddo
5077 C          if (energy_dec) write(iout,*)
5078 C     &       "estr1",i,vbld(i),distchainmax,
5079 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5080 C        else
5081          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5082         diff = vbld(i)-vbldpDUM
5083 C         write(iout,*) i,diff
5084          else
5085           diff = vbld(i)-vbldp0
5086 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5087          endif
5088           estr=estr+diff*diff
5089           do j=1,3
5090             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5091           enddo
5092 C        endif
5093 C        write (iout,'(a7,i5,4f7.3)')
5094 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5095       enddo
5096       estr=0.5d0*AKP*estr+estr1
5097 c
5098 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5099 c
5100       do i=nnt,nct
5101         iti=iabs(itype(i))
5102         if (iti.ne.10 .and. iti.ne.ntyp1) then
5103           nbi=nbondterm(iti)
5104           if (nbi.eq.1) then
5105             diff=vbld(i+nres)-vbldsc0(1,iti)
5106 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5107 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5108             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5109             do j=1,3
5110               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5111             enddo
5112           else
5113             do j=1,nbi
5114               diff=vbld(i+nres)-vbldsc0(j,iti)
5115               ud(j)=aksc(j,iti)*diff
5116               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5117             enddo
5118             uprod=u(1)
5119             do j=2,nbi
5120               uprod=uprod*u(j)
5121             enddo
5122             usum=0.0d0
5123             usumsqder=0.0d0
5124             do j=1,nbi
5125               uprod1=1.0d0
5126               uprod2=1.0d0
5127               do k=1,nbi
5128                 if (k.ne.j) then
5129                   uprod1=uprod1*u(k)
5130                   uprod2=uprod2*u(k)*u(k)
5131                 endif
5132               enddo
5133               usum=usum+uprod1
5134               usumsqder=usumsqder+ud(j)*uprod2
5135             enddo
5136 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5137 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5138             estr=estr+uprod/usum
5139             do j=1,3
5140              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5141             enddo
5142           endif
5143         endif
5144       enddo
5145       return
5146       end
5147 #ifdef CRYST_THETA
5148 C--------------------------------------------------------------------------
5149       subroutine ebend(etheta,ethetacnstr)
5150 C
5151 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5152 C angles gamma and its derivatives in consecutive thetas and gammas.
5153 C
5154       implicit real*8 (a-h,o-z)
5155       include 'DIMENSIONS'
5156       include 'DIMENSIONS.ZSCOPT'
5157       include 'COMMON.LOCAL'
5158       include 'COMMON.GEO'
5159       include 'COMMON.INTERACT'
5160       include 'COMMON.DERIV'
5161       include 'COMMON.VAR'
5162       include 'COMMON.CHAIN'
5163       include 'COMMON.IOUNITS'
5164       include 'COMMON.NAMES'
5165       include 'COMMON.FFIELD'
5166       include 'COMMON.TORCNSTR'
5167       common /calcthet/ term1,term2,termm,diffak,ratak,
5168      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5169      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5170       double precision y(2),z(2)
5171       delta=0.02d0*pi
5172 c      time11=dexp(-2*time)
5173 c      time12=1.0d0
5174       etheta=0.0D0
5175 c      write (iout,*) "nres",nres
5176 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5177 c      write (iout,*) ithet_start,ithet_end
5178       do i=ithet_start,ithet_end
5179 C        if (itype(i-1).eq.ntyp1) cycle
5180         if (i.le.2) cycle
5181         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5182      &  .or.itype(i).eq.ntyp1) cycle
5183 C Zero the energy function and its derivative at 0 or pi.
5184         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5185         it=itype(i-1)
5186         ichir1=isign(1,itype(i-2))
5187         ichir2=isign(1,itype(i))
5188          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5189          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5190          if (itype(i-1).eq.10) then
5191           itype1=isign(10,itype(i-2))
5192           ichir11=isign(1,itype(i-2))
5193           ichir12=isign(1,itype(i-2))
5194           itype2=isign(10,itype(i))
5195           ichir21=isign(1,itype(i))
5196           ichir22=isign(1,itype(i))
5197          endif
5198          if (i.eq.3) then
5199           y(1)=0.0D0
5200           y(2)=0.0D0
5201           else
5202
5203         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5204 #ifdef OSF
5205           phii=phi(i)
5206 c          icrc=0
5207 c          call proc_proc(phii,icrc)
5208           if (icrc.eq.1) phii=150.0
5209 #else
5210           phii=phi(i)
5211 #endif
5212           y(1)=dcos(phii)
5213           y(2)=dsin(phii)
5214         else
5215           y(1)=0.0D0
5216           y(2)=0.0D0
5217         endif
5218         endif
5219         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5220 #ifdef OSF
5221           phii1=phi(i+1)
5222 c          icrc=0
5223 c          call proc_proc(phii1,icrc)
5224           if (icrc.eq.1) phii1=150.0
5225           phii1=pinorm(phii1)
5226           z(1)=cos(phii1)
5227 #else
5228           phii1=phi(i+1)
5229           z(1)=dcos(phii1)
5230 #endif
5231           z(2)=dsin(phii1)
5232         else
5233           z(1)=0.0D0
5234           z(2)=0.0D0
5235         endif
5236 C Calculate the "mean" value of theta from the part of the distribution
5237 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5238 C In following comments this theta will be referred to as t_c.
5239         thet_pred_mean=0.0d0
5240         do k=1,2
5241             athetk=athet(k,it,ichir1,ichir2)
5242             bthetk=bthet(k,it,ichir1,ichir2)
5243           if (it.eq.10) then
5244              athetk=athet(k,itype1,ichir11,ichir12)
5245              bthetk=bthet(k,itype2,ichir21,ichir22)
5246           endif
5247           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5248         enddo
5249 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5250         dthett=thet_pred_mean*ssd
5251         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5252 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5253 C Derivatives of the "mean" values in gamma1 and gamma2.
5254         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5255      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5256          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5257      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5258          if (it.eq.10) then
5259       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5260      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5261         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5262      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5263          endif
5264         if (theta(i).gt.pi-delta) then
5265           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5266      &         E_tc0)
5267           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5268           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5269           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5270      &        E_theta)
5271           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5272      &        E_tc)
5273         else if (theta(i).lt.delta) then
5274           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5275           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5276           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5277      &        E_theta)
5278           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5279           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5280      &        E_tc)
5281         else
5282           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5283      &        E_theta,E_tc)
5284         endif
5285         etheta=etheta+ethetai
5286 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5287 c     &      'ebend',i,ethetai,theta(i),itype(i)
5288 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5289 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5290         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5291         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5292         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5293 c 1215   continue
5294       enddo
5295       ethetacnstr=0.0d0
5296 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5297       do i=1,ntheta_constr
5298         itheta=itheta_constr(i)
5299         thetiii=theta(itheta)
5300         difi=pinorm(thetiii-theta_constr0(i))
5301         if (difi.gt.theta_drange(i)) then
5302           difi=difi-theta_drange(i)
5303           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5304           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5305      &    +for_thet_constr(i)*difi**3
5306         else if (difi.lt.-drange(i)) then
5307           difi=difi+drange(i)
5308           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5309           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5310      &    +for_thet_constr(i)*difi**3
5311         else
5312           difi=0.0
5313         endif
5314 C       if (energy_dec) then
5315 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5316 C     &    i,itheta,rad2deg*thetiii,
5317 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5318 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5319 C     &    gloc(itheta+nphi-2,icg)
5320 C        endif
5321       enddo
5322 C Ufff.... We've done all this!!!
5323       return
5324       end
5325 C---------------------------------------------------------------------------
5326       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5327      &     E_tc)
5328       implicit real*8 (a-h,o-z)
5329       include 'DIMENSIONS'
5330       include 'COMMON.LOCAL'
5331       include 'COMMON.IOUNITS'
5332       common /calcthet/ term1,term2,termm,diffak,ratak,
5333      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5334      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5335 C Calculate the contributions to both Gaussian lobes.
5336 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5337 C The "polynomial part" of the "standard deviation" of this part of
5338 C the distribution.
5339         sig=polthet(3,it)
5340         do j=2,0,-1
5341           sig=sig*thet_pred_mean+polthet(j,it)
5342         enddo
5343 C Derivative of the "interior part" of the "standard deviation of the"
5344 C gamma-dependent Gaussian lobe in t_c.
5345         sigtc=3*polthet(3,it)
5346         do j=2,1,-1
5347           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5348         enddo
5349         sigtc=sig*sigtc
5350 C Set the parameters of both Gaussian lobes of the distribution.
5351 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5352         fac=sig*sig+sigc0(it)
5353         sigcsq=fac+fac
5354         sigc=1.0D0/sigcsq
5355 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5356         sigsqtc=-4.0D0*sigcsq*sigtc
5357 c       print *,i,sig,sigtc,sigsqtc
5358 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5359         sigtc=-sigtc/(fac*fac)
5360 C Following variable is sigma(t_c)**(-2)
5361         sigcsq=sigcsq*sigcsq
5362         sig0i=sig0(it)
5363         sig0inv=1.0D0/sig0i**2
5364         delthec=thetai-thet_pred_mean
5365         delthe0=thetai-theta0i
5366         term1=-0.5D0*sigcsq*delthec*delthec
5367         term2=-0.5D0*sig0inv*delthe0*delthe0
5368 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5369 C NaNs in taking the logarithm. We extract the largest exponent which is added
5370 C to the energy (this being the log of the distribution) at the end of energy
5371 C term evaluation for this virtual-bond angle.
5372         if (term1.gt.term2) then
5373           termm=term1
5374           term2=dexp(term2-termm)
5375           term1=1.0d0
5376         else
5377           termm=term2
5378           term1=dexp(term1-termm)
5379           term2=1.0d0
5380         endif
5381 C The ratio between the gamma-independent and gamma-dependent lobes of
5382 C the distribution is a Gaussian function of thet_pred_mean too.
5383         diffak=gthet(2,it)-thet_pred_mean
5384         ratak=diffak/gthet(3,it)**2
5385         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5386 C Let's differentiate it in thet_pred_mean NOW.
5387         aktc=ak*ratak
5388 C Now put together the distribution terms to make complete distribution.
5389         termexp=term1+ak*term2
5390         termpre=sigc+ak*sig0i
5391 C Contribution of the bending energy from this theta is just the -log of
5392 C the sum of the contributions from the two lobes and the pre-exponential
5393 C factor. Simple enough, isn't it?
5394         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5395 C NOW the derivatives!!!
5396 C 6/6/97 Take into account the deformation.
5397         E_theta=(delthec*sigcsq*term1
5398      &       +ak*delthe0*sig0inv*term2)/termexp
5399         E_tc=((sigtc+aktc*sig0i)/termpre
5400      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5401      &       aktc*term2)/termexp)
5402       return
5403       end
5404 c-----------------------------------------------------------------------------
5405       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5406       implicit real*8 (a-h,o-z)
5407       include 'DIMENSIONS'
5408       include 'COMMON.LOCAL'
5409       include 'COMMON.IOUNITS'
5410       common /calcthet/ term1,term2,termm,diffak,ratak,
5411      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5412      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5413       delthec=thetai-thet_pred_mean
5414       delthe0=thetai-theta0i
5415 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5416       t3 = thetai-thet_pred_mean
5417       t6 = t3**2
5418       t9 = term1
5419       t12 = t3*sigcsq
5420       t14 = t12+t6*sigsqtc
5421       t16 = 1.0d0
5422       t21 = thetai-theta0i
5423       t23 = t21**2
5424       t26 = term2
5425       t27 = t21*t26
5426       t32 = termexp
5427       t40 = t32**2
5428       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5429      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5430      & *(-t12*t9-ak*sig0inv*t27)
5431       return
5432       end
5433 #else
5434 C--------------------------------------------------------------------------
5435       subroutine ebend(etheta)
5436 C
5437 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5438 C angles gamma and its derivatives in consecutive thetas and gammas.
5439 C ab initio-derived potentials from
5440 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5441 C
5442       implicit real*8 (a-h,o-z)
5443       include 'DIMENSIONS'
5444       include 'DIMENSIONS.ZSCOPT'
5445       include 'COMMON.LOCAL'
5446       include 'COMMON.GEO'
5447       include 'COMMON.INTERACT'
5448       include 'COMMON.DERIV'
5449       include 'COMMON.VAR'
5450       include 'COMMON.CHAIN'
5451       include 'COMMON.IOUNITS'
5452       include 'COMMON.NAMES'
5453       include 'COMMON.FFIELD'
5454       include 'COMMON.CONTROL'
5455       include 'COMMON.TORCNSTR'
5456       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5457      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5458      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5459      & sinph1ph2(maxdouble,maxdouble)
5460       logical lprn /.false./, lprn1 /.false./
5461       etheta=0.0D0
5462 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5463       do i=ithet_start,ithet_end
5464 C         if (i.eq.2) cycle
5465 C        if (itype(i-1).eq.ntyp1) cycle
5466         if (i.le.2) cycle
5467         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5468      &  .or.itype(i).eq.ntyp1) cycle
5469         if (iabs(itype(i+1)).eq.20) iblock=2
5470         if (iabs(itype(i+1)).ne.20) iblock=1
5471         dethetai=0.0d0
5472         dephii=0.0d0
5473         dephii1=0.0d0
5474         theti2=0.5d0*theta(i)
5475         ityp2=ithetyp((itype(i-1)))
5476         do k=1,nntheterm
5477           coskt(k)=dcos(k*theti2)
5478           sinkt(k)=dsin(k*theti2)
5479         enddo
5480         if (i.eq.3) then
5481           phii=0.0d0
5482           ityp1=nthetyp+1
5483           do k=1,nsingle
5484             cosph1(k)=0.0d0
5485             sinph1(k)=0.0d0
5486           enddo
5487         else
5488         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5489 #ifdef OSF
5490           phii=phi(i)
5491           if (phii.ne.phii) phii=150.0
5492 #else
5493           phii=phi(i)
5494 #endif
5495           ityp1=ithetyp((itype(i-2)))
5496           do k=1,nsingle
5497             cosph1(k)=dcos(k*phii)
5498             sinph1(k)=dsin(k*phii)
5499           enddo
5500         else
5501           phii=0.0d0
5502 c          ityp1=nthetyp+1
5503           do k=1,nsingle
5504             ityp1=ithetyp((itype(i-2)))
5505             cosph1(k)=0.0d0
5506             sinph1(k)=0.0d0
5507           enddo
5508         endif
5509         endif
5510         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5511 #ifdef OSF
5512           phii1=phi(i+1)
5513           if (phii1.ne.phii1) phii1=150.0
5514           phii1=pinorm(phii1)
5515 #else
5516           phii1=phi(i+1)
5517 #endif
5518           ityp3=ithetyp((itype(i)))
5519           do k=1,nsingle
5520             cosph2(k)=dcos(k*phii1)
5521             sinph2(k)=dsin(k*phii1)
5522           enddo
5523         else
5524           phii1=0.0d0
5525 c          ityp3=nthetyp+1
5526           ityp3=ithetyp((itype(i)))
5527           do k=1,nsingle
5528             cosph2(k)=0.0d0
5529             sinph2(k)=0.0d0
5530           enddo
5531         endif
5532 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5533 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5534 c        call flush(iout)
5535         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5536         do k=1,ndouble
5537           do l=1,k-1
5538             ccl=cosph1(l)*cosph2(k-l)
5539             ssl=sinph1(l)*sinph2(k-l)
5540             scl=sinph1(l)*cosph2(k-l)
5541             csl=cosph1(l)*sinph2(k-l)
5542             cosph1ph2(l,k)=ccl-ssl
5543             cosph1ph2(k,l)=ccl+ssl
5544             sinph1ph2(l,k)=scl+csl
5545             sinph1ph2(k,l)=scl-csl
5546           enddo
5547         enddo
5548         if (lprn) then
5549         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5550      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5551         write (iout,*) "coskt and sinkt"
5552         do k=1,nntheterm
5553           write (iout,*) k,coskt(k),sinkt(k)
5554         enddo
5555         endif
5556         do k=1,ntheterm
5557           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5558           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5559      &      *coskt(k)
5560           if (lprn)
5561      &    write (iout,*) "k",k,"
5562      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5563      &     " ethetai",ethetai
5564         enddo
5565         if (lprn) then
5566         write (iout,*) "cosph and sinph"
5567         do k=1,nsingle
5568           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5569         enddo
5570         write (iout,*) "cosph1ph2 and sinph2ph2"
5571         do k=2,ndouble
5572           do l=1,k-1
5573             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5574      &         sinph1ph2(l,k),sinph1ph2(k,l)
5575           enddo
5576         enddo
5577         write(iout,*) "ethetai",ethetai
5578         endif
5579         do m=1,ntheterm2
5580           do k=1,nsingle
5581             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5582      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5583      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5584      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5585             ethetai=ethetai+sinkt(m)*aux
5586             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5587             dephii=dephii+k*sinkt(m)*(
5588      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5589      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5590             dephii1=dephii1+k*sinkt(m)*(
5591      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5592      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5593             if (lprn)
5594      &      write (iout,*) "m",m," k",k," bbthet",
5595      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5596      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5597      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5598      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5599           enddo
5600         enddo
5601         if (lprn)
5602      &  write(iout,*) "ethetai",ethetai
5603         do m=1,ntheterm3
5604           do k=2,ndouble
5605             do l=1,k-1
5606               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5607      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5608      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5609      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5610               ethetai=ethetai+sinkt(m)*aux
5611               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5612               dephii=dephii+l*sinkt(m)*(
5613      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5614      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5615      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5616      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5617               dephii1=dephii1+(k-l)*sinkt(m)*(
5618      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5619      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5620      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5621      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5622               if (lprn) then
5623               write (iout,*) "m",m," k",k," l",l," ffthet",
5624      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5625      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5626      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5627      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5628      &            " ethetai",ethetai
5629               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5630      &            cosph1ph2(k,l)*sinkt(m),
5631      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5632               endif
5633             enddo
5634           enddo
5635         enddo
5636 10      continue
5637         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5638      &   i,theta(i)*rad2deg,phii*rad2deg,
5639      &   phii1*rad2deg,ethetai
5640         etheta=etheta+ethetai
5641         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5642         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5643 c        gloc(nphi+i-2,icg)=wang*dethetai
5644         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5645       enddo
5646       return
5647       end
5648 #endif
5649 #ifdef CRYST_SC
5650 c-----------------------------------------------------------------------------
5651       subroutine esc(escloc)
5652 C Calculate the local energy of a side chain and its derivatives in the
5653 C corresponding virtual-bond valence angles THETA and the spherical angles
5654 C ALPHA and OMEGA.
5655       implicit real*8 (a-h,o-z)
5656       include 'DIMENSIONS'
5657       include 'DIMENSIONS.ZSCOPT'
5658       include 'COMMON.GEO'
5659       include 'COMMON.LOCAL'
5660       include 'COMMON.VAR'
5661       include 'COMMON.INTERACT'
5662       include 'COMMON.DERIV'
5663       include 'COMMON.CHAIN'
5664       include 'COMMON.IOUNITS'
5665       include 'COMMON.NAMES'
5666       include 'COMMON.FFIELD'
5667       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5668      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5669       common /sccalc/ time11,time12,time112,theti,it,nlobit
5670       delta=0.02d0*pi
5671       escloc=0.0D0
5672 C      write (iout,*) 'ESC'
5673       do i=loc_start,loc_end
5674         it=itype(i)
5675         if (it.eq.ntyp1) cycle
5676         if (it.eq.10) goto 1
5677         nlobit=nlob(iabs(it))
5678 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5679 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5680         theti=theta(i+1)-pipol
5681         x(1)=dtan(theti)
5682         x(2)=alph(i)
5683         x(3)=omeg(i)
5684 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5685
5686         if (x(2).gt.pi-delta) then
5687           xtemp(1)=x(1)
5688           xtemp(2)=pi-delta
5689           xtemp(3)=x(3)
5690           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5691           xtemp(2)=pi
5692           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5693           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5694      &        escloci,dersc(2))
5695           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5696      &        ddersc0(1),dersc(1))
5697           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5698      &        ddersc0(3),dersc(3))
5699           xtemp(2)=pi-delta
5700           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5701           xtemp(2)=pi
5702           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5703           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5704      &            dersc0(2),esclocbi,dersc02)
5705           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5706      &            dersc12,dersc01)
5707           call splinthet(x(2),0.5d0*delta,ss,ssd)
5708           dersc0(1)=dersc01
5709           dersc0(2)=dersc02
5710           dersc0(3)=0.0d0
5711           do k=1,3
5712             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5713           enddo
5714           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5715           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5716      &             esclocbi,ss,ssd
5717           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5718 c         escloci=esclocbi
5719 c         write (iout,*) escloci
5720         else if (x(2).lt.delta) then
5721           xtemp(1)=x(1)
5722           xtemp(2)=delta
5723           xtemp(3)=x(3)
5724           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5725           xtemp(2)=0.0d0
5726           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5727           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5728      &        escloci,dersc(2))
5729           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5730      &        ddersc0(1),dersc(1))
5731           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5732      &        ddersc0(3),dersc(3))
5733           xtemp(2)=delta
5734           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5735           xtemp(2)=0.0d0
5736           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5737           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5738      &            dersc0(2),esclocbi,dersc02)
5739           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5740      &            dersc12,dersc01)
5741           dersc0(1)=dersc01
5742           dersc0(2)=dersc02
5743           dersc0(3)=0.0d0
5744           call splinthet(x(2),0.5d0*delta,ss,ssd)
5745           do k=1,3
5746             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5747           enddo
5748           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5749 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5750 c     &             esclocbi,ss,ssd
5751           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5752 C         write (iout,*) 'i=',i, escloci
5753         else
5754           call enesc(x,escloci,dersc,ddummy,.false.)
5755         endif
5756
5757         escloc=escloc+escloci
5758 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5759             write (iout,'(a6,i5,0pf7.3)')
5760      &     'escloc',i,escloci
5761
5762         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5763      &   wscloc*dersc(1)
5764         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5765         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5766     1   continue
5767       enddo
5768       return
5769       end
5770 C---------------------------------------------------------------------------
5771       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5772       implicit real*8 (a-h,o-z)
5773       include 'DIMENSIONS'
5774       include 'COMMON.GEO'
5775       include 'COMMON.LOCAL'
5776       include 'COMMON.IOUNITS'
5777       common /sccalc/ time11,time12,time112,theti,it,nlobit
5778       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5779       double precision contr(maxlob,-1:1)
5780       logical mixed
5781 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5782         escloc_i=0.0D0
5783         do j=1,3
5784           dersc(j)=0.0D0
5785           if (mixed) ddersc(j)=0.0d0
5786         enddo
5787         x3=x(3)
5788
5789 C Because of periodicity of the dependence of the SC energy in omega we have
5790 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5791 C To avoid underflows, first compute & store the exponents.
5792
5793         do iii=-1,1
5794
5795           x(3)=x3+iii*dwapi
5796
5797           do j=1,nlobit
5798             do k=1,3
5799               z(k)=x(k)-censc(k,j,it)
5800             enddo
5801             do k=1,3
5802               Axk=0.0D0
5803               do l=1,3
5804                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5805               enddo
5806               Ax(k,j,iii)=Axk
5807             enddo
5808             expfac=0.0D0
5809             do k=1,3
5810               expfac=expfac+Ax(k,j,iii)*z(k)
5811             enddo
5812             contr(j,iii)=expfac
5813           enddo ! j
5814
5815         enddo ! iii
5816
5817         x(3)=x3
5818 C As in the case of ebend, we want to avoid underflows in exponentiation and
5819 C subsequent NaNs and INFs in energy calculation.
5820 C Find the largest exponent
5821         emin=contr(1,-1)
5822         do iii=-1,1
5823           do j=1,nlobit
5824             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5825           enddo
5826         enddo
5827         emin=0.5D0*emin
5828 cd      print *,'it=',it,' emin=',emin
5829
5830 C Compute the contribution to SC energy and derivatives
5831         do iii=-1,1
5832
5833           do j=1,nlobit
5834             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5835 cd          print *,'j=',j,' expfac=',expfac
5836             escloc_i=escloc_i+expfac
5837             do k=1,3
5838               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5839             enddo
5840             if (mixed) then
5841               do k=1,3,2
5842                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5843      &            +gaussc(k,2,j,it))*expfac
5844               enddo
5845             endif
5846           enddo
5847
5848         enddo ! iii
5849
5850         dersc(1)=dersc(1)/cos(theti)**2
5851         ddersc(1)=ddersc(1)/cos(theti)**2
5852         ddersc(3)=ddersc(3)
5853
5854         escloci=-(dlog(escloc_i)-emin)
5855         do j=1,3
5856           dersc(j)=dersc(j)/escloc_i
5857         enddo
5858         if (mixed) then
5859           do j=1,3,2
5860             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5861           enddo
5862         endif
5863       return
5864       end
5865 C------------------------------------------------------------------------------
5866       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5867       implicit real*8 (a-h,o-z)
5868       include 'DIMENSIONS'
5869       include 'COMMON.GEO'
5870       include 'COMMON.LOCAL'
5871       include 'COMMON.IOUNITS'
5872       common /sccalc/ time11,time12,time112,theti,it,nlobit
5873       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5874       double precision contr(maxlob)
5875       logical mixed
5876
5877       escloc_i=0.0D0
5878
5879       do j=1,3
5880         dersc(j)=0.0D0
5881       enddo
5882
5883       do j=1,nlobit
5884         do k=1,2
5885           z(k)=x(k)-censc(k,j,it)
5886         enddo
5887         z(3)=dwapi
5888         do k=1,3
5889           Axk=0.0D0
5890           do l=1,3
5891             Axk=Axk+gaussc(l,k,j,it)*z(l)
5892           enddo
5893           Ax(k,j)=Axk
5894         enddo
5895         expfac=0.0D0
5896         do k=1,3
5897           expfac=expfac+Ax(k,j)*z(k)
5898         enddo
5899         contr(j)=expfac
5900       enddo ! j
5901
5902 C As in the case of ebend, we want to avoid underflows in exponentiation and
5903 C subsequent NaNs and INFs in energy calculation.
5904 C Find the largest exponent
5905       emin=contr(1)
5906       do j=1,nlobit
5907         if (emin.gt.contr(j)) emin=contr(j)
5908       enddo
5909       emin=0.5D0*emin
5910
5911 C Compute the contribution to SC energy and derivatives
5912
5913       dersc12=0.0d0
5914       do j=1,nlobit
5915         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5916         escloc_i=escloc_i+expfac
5917         do k=1,2
5918           dersc(k)=dersc(k)+Ax(k,j)*expfac
5919         enddo
5920         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5921      &            +gaussc(1,2,j,it))*expfac
5922         dersc(3)=0.0d0
5923       enddo
5924
5925       dersc(1)=dersc(1)/cos(theti)**2
5926       dersc12=dersc12/cos(theti)**2
5927       escloci=-(dlog(escloc_i)-emin)
5928       do j=1,2
5929         dersc(j)=dersc(j)/escloc_i
5930       enddo
5931       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5932       return
5933       end
5934 #else
5935 c----------------------------------------------------------------------------------
5936       subroutine esc(escloc)
5937 C Calculate the local energy of a side chain and its derivatives in the
5938 C corresponding virtual-bond valence angles THETA and the spherical angles
5939 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5940 C added by Urszula Kozlowska. 07/11/2007
5941 C
5942       implicit real*8 (a-h,o-z)
5943       include 'DIMENSIONS'
5944       include 'DIMENSIONS.ZSCOPT'
5945       include 'COMMON.GEO'
5946       include 'COMMON.LOCAL'
5947       include 'COMMON.VAR'
5948       include 'COMMON.SCROT'
5949       include 'COMMON.INTERACT'
5950       include 'COMMON.DERIV'
5951       include 'COMMON.CHAIN'
5952       include 'COMMON.IOUNITS'
5953       include 'COMMON.NAMES'
5954       include 'COMMON.FFIELD'
5955       include 'COMMON.CONTROL'
5956       include 'COMMON.VECTORS'
5957       double precision x_prime(3),y_prime(3),z_prime(3)
5958      &    , sumene,dsc_i,dp2_i,x(65),
5959      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5960      &    de_dxx,de_dyy,de_dzz,de_dt
5961       double precision s1_t,s1_6_t,s2_t,s2_6_t
5962       double precision
5963      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5964      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5965      & dt_dCi(3),dt_dCi1(3)
5966       common /sccalc/ time11,time12,time112,theti,it,nlobit
5967       delta=0.02d0*pi
5968       escloc=0.0D0
5969       do i=loc_start,loc_end
5970         if (itype(i).eq.ntyp1) cycle
5971         costtab(i+1) =dcos(theta(i+1))
5972         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5973         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5974         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5975         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5976         cosfac=dsqrt(cosfac2)
5977         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5978         sinfac=dsqrt(sinfac2)
5979         it=iabs(itype(i))
5980         if (it.eq.10) goto 1
5981 c
5982 C  Compute the axes of tghe local cartesian coordinates system; store in
5983 c   x_prime, y_prime and z_prime
5984 c
5985         do j=1,3
5986           x_prime(j) = 0.00
5987           y_prime(j) = 0.00
5988           z_prime(j) = 0.00
5989         enddo
5990 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5991 C     &   dc_norm(3,i+nres)
5992         do j = 1,3
5993           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5994           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5995         enddo
5996         do j = 1,3
5997           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5998         enddo
5999 c       write (2,*) "i",i
6000 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6001 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6002 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6003 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6004 c      & " xy",scalar(x_prime(1),y_prime(1)),
6005 c      & " xz",scalar(x_prime(1),z_prime(1)),
6006 c      & " yy",scalar(y_prime(1),y_prime(1)),
6007 c      & " yz",scalar(y_prime(1),z_prime(1)),
6008 c      & " zz",scalar(z_prime(1),z_prime(1))
6009 c
6010 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6011 C to local coordinate system. Store in xx, yy, zz.
6012 c
6013         xx=0.0d0
6014         yy=0.0d0
6015         zz=0.0d0
6016         do j = 1,3
6017           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6018           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6019           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6020         enddo
6021
6022         xxtab(i)=xx
6023         yytab(i)=yy
6024         zztab(i)=zz
6025 C
6026 C Compute the energy of the ith side cbain
6027 C
6028 c        write (2,*) "xx",xx," yy",yy," zz",zz
6029         it=iabs(itype(i))
6030         do j = 1,65
6031           x(j) = sc_parmin(j,it)
6032         enddo
6033 #ifdef CHECK_COORD
6034 Cc diagnostics - remove later
6035         xx1 = dcos(alph(2))
6036         yy1 = dsin(alph(2))*dcos(omeg(2))
6037         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6038         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6039      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6040      &    xx1,yy1,zz1
6041 C,"  --- ", xx_w,yy_w,zz_w
6042 c end diagnostics
6043 #endif
6044         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6045      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6046      &   + x(10)*yy*zz
6047         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6048      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6049      & + x(20)*yy*zz
6050         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6051      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6052      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6053      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6054      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6055      &  +x(40)*xx*yy*zz
6056         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6057      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6058      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6059      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6060      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6061      &  +x(60)*xx*yy*zz
6062         dsc_i   = 0.743d0+x(61)
6063         dp2_i   = 1.9d0+x(62)
6064         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6065      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6066         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6067      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6068         s1=(1+x(63))/(0.1d0 + dscp1)
6069         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6070         s2=(1+x(65))/(0.1d0 + dscp2)
6071         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6072         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6073      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6074 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6075 c     &   sumene4,
6076 c     &   dscp1,dscp2,sumene
6077 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6078         escloc = escloc + sumene
6079 c        write (2,*) "escloc",escloc
6080 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6081 c     &  zz,xx,yy
6082         if (.not. calc_grad) goto 1
6083 #ifdef DEBUG
6084 C
6085 C This section to check the numerical derivatives of the energy of ith side
6086 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6087 C #define DEBUG in the code to turn it on.
6088 C
6089         write (2,*) "sumene               =",sumene
6090         aincr=1.0d-7
6091         xxsave=xx
6092         xx=xx+aincr
6093         write (2,*) xx,yy,zz
6094         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6095         de_dxx_num=(sumenep-sumene)/aincr
6096         xx=xxsave
6097         write (2,*) "xx+ sumene from enesc=",sumenep
6098         yysave=yy
6099         yy=yy+aincr
6100         write (2,*) xx,yy,zz
6101         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6102         de_dyy_num=(sumenep-sumene)/aincr
6103         yy=yysave
6104         write (2,*) "yy+ sumene from enesc=",sumenep
6105         zzsave=zz
6106         zz=zz+aincr
6107         write (2,*) xx,yy,zz
6108         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6109         de_dzz_num=(sumenep-sumene)/aincr
6110         zz=zzsave
6111         write (2,*) "zz+ sumene from enesc=",sumenep
6112         costsave=cost2tab(i+1)
6113         sintsave=sint2tab(i+1)
6114         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6115         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6116         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6117         de_dt_num=(sumenep-sumene)/aincr
6118         write (2,*) " t+ sumene from enesc=",sumenep
6119         cost2tab(i+1)=costsave
6120         sint2tab(i+1)=sintsave
6121 C End of diagnostics section.
6122 #endif
6123 C
6124 C Compute the gradient of esc
6125 C
6126         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6127         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6128         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6129         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6130         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6131         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6132         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6133         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6134         pom1=(sumene3*sint2tab(i+1)+sumene1)
6135      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6136         pom2=(sumene4*cost2tab(i+1)+sumene2)
6137      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6138         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6139         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6140      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6141      &  +x(40)*yy*zz
6142         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6143         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6144      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6145      &  +x(60)*yy*zz
6146         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6147      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6148      &        +(pom1+pom2)*pom_dx
6149 #ifdef DEBUG
6150         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6151 #endif
6152 C
6153         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6154         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6155      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6156      &  +x(40)*xx*zz
6157         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6158         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6159      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6160      &  +x(59)*zz**2 +x(60)*xx*zz
6161         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6162      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6163      &        +(pom1-pom2)*pom_dy
6164 #ifdef DEBUG
6165         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6166 #endif
6167 C
6168         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6169      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6170      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6171      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6172      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6173      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6174      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6175      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6176 #ifdef DEBUG
6177         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6178 #endif
6179 C
6180         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6181      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6182      &  +pom1*pom_dt1+pom2*pom_dt2
6183 #ifdef DEBUG
6184         write(2,*), "de_dt = ", de_dt,de_dt_num
6185 #endif
6186 c
6187 C
6188        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6189        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6190        cosfac2xx=cosfac2*xx
6191        sinfac2yy=sinfac2*yy
6192        do k = 1,3
6193          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6194      &      vbld_inv(i+1)
6195          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6196      &      vbld_inv(i)
6197          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6198          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6199 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6200 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6201 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6202 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6203          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6204          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6205          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6206          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6207          dZZ_Ci1(k)=0.0d0
6208          dZZ_Ci(k)=0.0d0
6209          do j=1,3
6210            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6211      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6212            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6213      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6214          enddo
6215
6216          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6217          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6218          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6219 c
6220          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6221          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6222        enddo
6223
6224        do k=1,3
6225          dXX_Ctab(k,i)=dXX_Ci(k)
6226          dXX_C1tab(k,i)=dXX_Ci1(k)
6227          dYY_Ctab(k,i)=dYY_Ci(k)
6228          dYY_C1tab(k,i)=dYY_Ci1(k)
6229          dZZ_Ctab(k,i)=dZZ_Ci(k)
6230          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6231          dXX_XYZtab(k,i)=dXX_XYZ(k)
6232          dYY_XYZtab(k,i)=dYY_XYZ(k)
6233          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6234        enddo
6235
6236        do k = 1,3
6237 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6238 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6239 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6240 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6241 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6242 c     &    dt_dci(k)
6243 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6244 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6245          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6246      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6247          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6248      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6249          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6250      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6251        enddo
6252 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6253 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6254
6255 C to check gradient call subroutine check_grad
6256
6257     1 continue
6258       enddo
6259       return
6260       end
6261 #endif
6262 c------------------------------------------------------------------------------
6263       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6264 C
6265 C This procedure calculates two-body contact function g(rij) and its derivative:
6266 C
6267 C           eps0ij                                     !       x < -1
6268 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6269 C            0                                         !       x > 1
6270 C
6271 C where x=(rij-r0ij)/delta
6272 C
6273 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6274 C
6275       implicit none
6276       double precision rij,r0ij,eps0ij,fcont,fprimcont
6277       double precision x,x2,x4,delta
6278 c     delta=0.02D0*r0ij
6279 c      delta=0.2D0*r0ij
6280       x=(rij-r0ij)/delta
6281       if (x.lt.-1.0D0) then
6282         fcont=eps0ij
6283         fprimcont=0.0D0
6284       else if (x.le.1.0D0) then
6285         x2=x*x
6286         x4=x2*x2
6287         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6288         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6289       else
6290         fcont=0.0D0
6291         fprimcont=0.0D0
6292       endif
6293       return
6294       end
6295 c------------------------------------------------------------------------------
6296       subroutine splinthet(theti,delta,ss,ssder)
6297       implicit real*8 (a-h,o-z)
6298       include 'DIMENSIONS'
6299       include 'DIMENSIONS.ZSCOPT'
6300       include 'COMMON.VAR'
6301       include 'COMMON.GEO'
6302       thetup=pi-delta
6303       thetlow=delta
6304       if (theti.gt.pipol) then
6305         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6306       else
6307         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6308         ssder=-ssder
6309       endif
6310       return
6311       end
6312 c------------------------------------------------------------------------------
6313       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6314       implicit none
6315       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6316       double precision ksi,ksi2,ksi3,a1,a2,a3
6317       a1=fprim0*delta/(f1-f0)
6318       a2=3.0d0-2.0d0*a1
6319       a3=a1-2.0d0
6320       ksi=(x-x0)/delta
6321       ksi2=ksi*ksi
6322       ksi3=ksi2*ksi
6323       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6324       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6325       return
6326       end
6327 c------------------------------------------------------------------------------
6328       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6329       implicit none
6330       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6331       double precision ksi,ksi2,ksi3,a1,a2,a3
6332       ksi=(x-x0)/delta
6333       ksi2=ksi*ksi
6334       ksi3=ksi2*ksi
6335       a1=fprim0x*delta
6336       a2=3*(f1x-f0x)-2*fprim0x*delta
6337       a3=fprim0x*delta-2*(f1x-f0x)
6338       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6339       return
6340       end
6341 C-----------------------------------------------------------------------------
6342 #ifdef CRYST_TOR
6343 C-----------------------------------------------------------------------------
6344       subroutine etor(etors,fact)
6345       implicit real*8 (a-h,o-z)
6346       include 'DIMENSIONS'
6347       include 'DIMENSIONS.ZSCOPT'
6348       include 'COMMON.VAR'
6349       include 'COMMON.GEO'
6350       include 'COMMON.LOCAL'
6351       include 'COMMON.TORSION'
6352       include 'COMMON.INTERACT'
6353       include 'COMMON.DERIV'
6354       include 'COMMON.CHAIN'
6355       include 'COMMON.NAMES'
6356       include 'COMMON.IOUNITS'
6357       include 'COMMON.FFIELD'
6358       include 'COMMON.TORCNSTR'
6359       logical lprn
6360 C Set lprn=.true. for debugging
6361       lprn=.false.
6362 c      lprn=.true.
6363       etors=0.0D0
6364       do i=iphi_start,iphi_end
6365         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6366      &      .or. itype(i).eq.ntyp1) cycle
6367         itori=itortyp(itype(i-2))
6368         itori1=itortyp(itype(i-1))
6369         phii=phi(i)
6370         gloci=0.0D0
6371 C Proline-Proline pair is a special case...
6372         if (itori.eq.3 .and. itori1.eq.3) then
6373           if (phii.gt.-dwapi3) then
6374             cosphi=dcos(3*phii)
6375             fac=1.0D0/(1.0D0-cosphi)
6376             etorsi=v1(1,3,3)*fac
6377             etorsi=etorsi+etorsi
6378             etors=etors+etorsi-v1(1,3,3)
6379             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6380           endif
6381           do j=1,3
6382             v1ij=v1(j+1,itori,itori1)
6383             v2ij=v2(j+1,itori,itori1)
6384             cosphi=dcos(j*phii)
6385             sinphi=dsin(j*phii)
6386             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6387             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6388           enddo
6389         else
6390           do j=1,nterm_old
6391             v1ij=v1(j,itori,itori1)
6392             v2ij=v2(j,itori,itori1)
6393             cosphi=dcos(j*phii)
6394             sinphi=dsin(j*phii)
6395             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6396             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6397           enddo
6398         endif
6399         if (lprn)
6400      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6401      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6402      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6403         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6404 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6405       enddo
6406       return
6407       end
6408 c------------------------------------------------------------------------------
6409 #else
6410       subroutine etor(etors,fact)
6411       implicit real*8 (a-h,o-z)
6412       include 'DIMENSIONS'
6413       include 'DIMENSIONS.ZSCOPT'
6414       include 'COMMON.VAR'
6415       include 'COMMON.GEO'
6416       include 'COMMON.LOCAL'
6417       include 'COMMON.TORSION'
6418       include 'COMMON.INTERACT'
6419       include 'COMMON.DERIV'
6420       include 'COMMON.CHAIN'
6421       include 'COMMON.NAMES'
6422       include 'COMMON.IOUNITS'
6423       include 'COMMON.FFIELD'
6424       include 'COMMON.TORCNSTR'
6425       logical lprn
6426 C Set lprn=.true. for debugging
6427       lprn=.false.
6428 c      lprn=.true.
6429       etors=0.0D0
6430       do i=iphi_start,iphi_end
6431         if (i.le.2) cycle
6432         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6433      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6434 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6435 C     &       .or. itype(i).eq.ntyp1) cycle
6436         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6437          if (iabs(itype(i)).eq.20) then
6438          iblock=2
6439          else
6440          iblock=1
6441          endif
6442         itori=itortyp(itype(i-2))
6443         itori1=itortyp(itype(i-1))
6444         phii=phi(i)
6445         gloci=0.0D0
6446 C Regular cosine and sine terms
6447         do j=1,nterm(itori,itori1,iblock)
6448           v1ij=v1(j,itori,itori1,iblock)
6449           v2ij=v2(j,itori,itori1,iblock)
6450           cosphi=dcos(j*phii)
6451           sinphi=dsin(j*phii)
6452           etors=etors+v1ij*cosphi+v2ij*sinphi
6453           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6454         enddo
6455 C Lorentz terms
6456 C                         v1
6457 C  E = SUM ----------------------------------- - v1
6458 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6459 C
6460         cosphi=dcos(0.5d0*phii)
6461         sinphi=dsin(0.5d0*phii)
6462         do j=1,nlor(itori,itori1,iblock)
6463           vl1ij=vlor1(j,itori,itori1)
6464           vl2ij=vlor2(j,itori,itori1)
6465           vl3ij=vlor3(j,itori,itori1)
6466           pom=vl2ij*cosphi+vl3ij*sinphi
6467           pom1=1.0d0/(pom*pom+1.0d0)
6468           etors=etors+vl1ij*pom1
6469 c          if (energy_dec) etors_ii=etors_ii+
6470 c     &                vl1ij*pom1
6471           pom=-pom*pom1*pom1
6472           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6473         enddo
6474 C Subtract the constant term
6475         etors=etors-v0(itori,itori1,iblock)
6476         if (lprn)
6477      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6478      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6479      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6480         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6481 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6482  1215   continue
6483       enddo
6484       return
6485       end
6486 c----------------------------------------------------------------------------
6487       subroutine etor_d(etors_d,fact2)
6488 C 6/23/01 Compute double torsional energy
6489       implicit real*8 (a-h,o-z)
6490       include 'DIMENSIONS'
6491       include 'DIMENSIONS.ZSCOPT'
6492       include 'COMMON.VAR'
6493       include 'COMMON.GEO'
6494       include 'COMMON.LOCAL'
6495       include 'COMMON.TORSION'
6496       include 'COMMON.INTERACT'
6497       include 'COMMON.DERIV'
6498       include 'COMMON.CHAIN'
6499       include 'COMMON.NAMES'
6500       include 'COMMON.IOUNITS'
6501       include 'COMMON.FFIELD'
6502       include 'COMMON.TORCNSTR'
6503       logical lprn
6504 C Set lprn=.true. for debugging
6505       lprn=.false.
6506 c     lprn=.true.
6507       etors_d=0.0D0
6508       do i=iphi_start,iphi_end-1
6509         if (i.le.3) cycle
6510 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6511 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6512          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6513      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6514      &  (itype(i+1).eq.ntyp1)) cycle
6515         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6516      &     goto 1215
6517         itori=itortyp(itype(i-2))
6518         itori1=itortyp(itype(i-1))
6519         itori2=itortyp(itype(i))
6520         phii=phi(i)
6521         phii1=phi(i+1)
6522         gloci1=0.0D0
6523         gloci2=0.0D0
6524         iblock=1
6525         if (iabs(itype(i+1)).eq.20) iblock=2
6526 C Regular cosine and sine terms
6527         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6528           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6529           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6530           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6531           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6532           cosphi1=dcos(j*phii)
6533           sinphi1=dsin(j*phii)
6534           cosphi2=dcos(j*phii1)
6535           sinphi2=dsin(j*phii1)
6536           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6537      &     v2cij*cosphi2+v2sij*sinphi2
6538           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6539           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6540         enddo
6541         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6542           do l=1,k-1
6543             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6544             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6545             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6546             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6547             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6548             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6549             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6550             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6551             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6552      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6553             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6554      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6555             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6556      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6557           enddo
6558         enddo
6559         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6560         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6561  1215   continue
6562       enddo
6563       return
6564       end
6565 #endif
6566 c---------------------------------------------------------------------------
6567 C The rigorous attempt to derive energy function
6568       subroutine etor_kcc(etors,fact)
6569       implicit real*8 (a-h,o-z)
6570       include 'DIMENSIONS'
6571       include 'DIMENSIONS.ZSCOPT'
6572       include 'COMMON.VAR'
6573       include 'COMMON.GEO'
6574       include 'COMMON.LOCAL'
6575       include 'COMMON.TORSION'
6576       include 'COMMON.INTERACT'
6577       include 'COMMON.DERIV'
6578       include 'COMMON.CHAIN'
6579       include 'COMMON.NAMES'
6580       include 'COMMON.IOUNITS'
6581       include 'COMMON.FFIELD'
6582       include 'COMMON.TORCNSTR'
6583       include 'COMMON.CONTROL'
6584       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6585       logical lprn
6586 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6587 C Set lprn=.true. for debugging
6588       lprn=energy_dec
6589 c     lprn=.true.
6590 C      print *,"wchodze kcc"
6591       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6592       etors=0.0D0
6593       do i=iphi_start,iphi_end
6594 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6595 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6596 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6597 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6598         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6599      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6600         itori=itortyp(itype(i-2))
6601         itori1=itortyp(itype(i-1))
6602         phii=phi(i)
6603         glocig=0.0D0
6604         glocit1=0.0d0
6605         glocit2=0.0d0
6606 C to avoid multiple devision by 2
6607 c        theti22=0.5d0*theta(i)
6608 C theta 12 is the theta_1 /2
6609 C theta 22 is theta_2 /2
6610 c        theti12=0.5d0*theta(i-1)
6611 C and appropriate sinus function
6612         sinthet1=dsin(theta(i-1))
6613         sinthet2=dsin(theta(i))
6614         costhet1=dcos(theta(i-1))
6615         costhet2=dcos(theta(i))
6616 C to speed up lets store its mutliplication
6617         sint1t2=sinthet2*sinthet1
6618         sint1t2n=1.0d0
6619 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6620 C +d_n*sin(n*gamma)) *
6621 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6622 C we have two sum 1) Non-Chebyshev which is with n and gamma
6623         nval=nterm_kcc_Tb(itori,itori1)
6624         c1(0)=0.0d0
6625         c2(0)=0.0d0
6626         c1(1)=1.0d0
6627         c2(1)=1.0d0
6628         do j=2,nval
6629           c1(j)=c1(j-1)*costhet1
6630           c2(j)=c2(j-1)*costhet2
6631         enddo
6632         etori=0.0d0
6633         do j=1,nterm_kcc(itori,itori1)
6634           cosphi=dcos(j*phii)
6635           sinphi=dsin(j*phii)
6636           sint1t2n1=sint1t2n
6637           sint1t2n=sint1t2n*sint1t2
6638           sumvalc=0.0d0
6639           gradvalct1=0.0d0
6640           gradvalct2=0.0d0
6641           do k=1,nval
6642             do l=1,nval
6643               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6644               gradvalct1=gradvalct1+
6645      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6646               gradvalct2=gradvalct2+
6647      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6648             enddo
6649           enddo
6650           gradvalct1=-gradvalct1*sinthet1
6651           gradvalct2=-gradvalct2*sinthet2
6652           sumvals=0.0d0
6653           gradvalst1=0.0d0
6654           gradvalst2=0.0d0
6655           do k=1,nval
6656             do l=1,nval
6657               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6658               gradvalst1=gradvalst1+
6659      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6660               gradvalst2=gradvalst2+
6661      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6662             enddo
6663           enddo
6664           gradvalst1=-gradvalst1*sinthet1
6665           gradvalst2=-gradvalst2*sinthet2
6666           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6667 C glocig is the gradient local i site in gamma
6668           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6669 C now gradient over theta_1
6670           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6671      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6672           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6673      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6674         enddo ! j
6675         etors=etors+etori
6676 C derivative over gamma
6677         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6678 C derivative over theta1
6679         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6680 C now derivative over theta2
6681         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6682         if (lprn) then
6683           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6684      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6685           write (iout,*) "c1",(c1(k),k=0,nval),
6686      &    " c2",(c2(k),k=0,nval)
6687           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6688         endif
6689       enddo
6690       return
6691       end
6692 c---------------------------------------------------------------------------------------------
6693       subroutine etor_constr(edihcnstr)
6694       implicit real*8 (a-h,o-z)
6695       include 'DIMENSIONS'
6696       include 'DIMENSIONS.ZSCOPT'
6697       include 'COMMON.VAR'
6698       include 'COMMON.GEO'
6699       include 'COMMON.LOCAL'
6700       include 'COMMON.TORSION'
6701       include 'COMMON.INTERACT'
6702       include 'COMMON.DERIV'
6703       include 'COMMON.CHAIN'
6704       include 'COMMON.NAMES'
6705       include 'COMMON.IOUNITS'
6706       include 'COMMON.FFIELD'
6707       include 'COMMON.TORCNSTR'
6708       include 'COMMON.CONTROL'
6709 ! 6/20/98 - dihedral angle constraints
6710       edihcnstr=0.0d0
6711 c      do i=1,ndih_constr
6712 c      write (iout,*) "idihconstr_start",idihconstr_start,
6713 c     &  " idihconstr_end",idihconstr_end
6714
6715       if (raw_psipred) then
6716         do i=idihconstr_start,idihconstr_end
6717           itori=idih_constr(i)
6718           phii=phi(itori)
6719           gaudih_i=vpsipred(1,i)
6720           gauder_i=0.0d0
6721           do j=1,2
6722             s = sdihed(j,i)
6723             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6724             dexpcos_i=dexp(-cos_i*cos_i)
6725             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6726             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6727      &            *cos_i*dexpcos_i/s**2
6728           enddo
6729           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6730           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6731           if (energy_dec)
6732      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6733      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6734      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6735      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6736      &     -wdihc*dlog(gaudih_i)
6737         enddo
6738       else
6739
6740       do i=idihconstr_start,idihconstr_end
6741         itori=idih_constr(i)
6742         phii=phi(itori)
6743         difi=pinorm(phii-phi0(i))
6744         if (difi.gt.drange(i)) then
6745           difi=difi-drange(i)
6746           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6748         else if (difi.lt.-drange(i)) then
6749           difi=difi+drange(i)
6750           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6751           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6752         else
6753           difi=0.0
6754         endif
6755       enddo
6756
6757       endif
6758
6759 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6760       return
6761       end
6762 c----------------------------------------------------------------------------
6763 C The rigorous attempt to derive energy function
6764       subroutine ebend_kcc(etheta)
6765
6766       implicit real*8 (a-h,o-z)
6767       include 'DIMENSIONS'
6768       include 'DIMENSIONS.ZSCOPT'
6769       include 'COMMON.VAR'
6770       include 'COMMON.GEO'
6771       include 'COMMON.LOCAL'
6772       include 'COMMON.TORSION'
6773       include 'COMMON.INTERACT'
6774       include 'COMMON.DERIV'
6775       include 'COMMON.CHAIN'
6776       include 'COMMON.NAMES'
6777       include 'COMMON.IOUNITS'
6778       include 'COMMON.FFIELD'
6779       include 'COMMON.TORCNSTR'
6780       include 'COMMON.CONTROL'
6781       logical lprn
6782       double precision thybt1(maxang_kcc)
6783 C Set lprn=.true. for debugging
6784       lprn=energy_dec
6785 c     lprn=.true.
6786 C      print *,"wchodze kcc"
6787       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6788       etheta=0.0D0
6789       do i=ithet_start,ithet_end
6790 c        print *,i,itype(i-1),itype(i),itype(i-2)
6791         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6792      &  .or.itype(i).eq.ntyp1) cycle
6793         iti=iabs(itortyp(itype(i-1)))
6794         sinthet=dsin(theta(i))
6795         costhet=dcos(theta(i))
6796         do j=1,nbend_kcc_Tb(iti)
6797           thybt1(j)=v1bend_chyb(j,iti)
6798         enddo
6799         sumth1thyb=v1bend_chyb(0,iti)+
6800      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6801         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6802      &    sumth1thyb
6803         ihelp=nbend_kcc_Tb(iti)-1
6804         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6805         etheta=etheta+sumth1thyb
6806 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6807         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6808       enddo
6809       return
6810       end
6811 c-------------------------------------------------------------------------------------
6812       subroutine etheta_constr(ethetacnstr)
6813
6814       implicit real*8 (a-h,o-z)
6815       include 'DIMENSIONS'
6816       include 'DIMENSIONS.ZSCOPT'
6817       include 'COMMON.VAR'
6818       include 'COMMON.GEO'
6819       include 'COMMON.LOCAL'
6820       include 'COMMON.TORSION'
6821       include 'COMMON.INTERACT'
6822       include 'COMMON.DERIV'
6823       include 'COMMON.CHAIN'
6824       include 'COMMON.NAMES'
6825       include 'COMMON.IOUNITS'
6826       include 'COMMON.FFIELD'
6827       include 'COMMON.TORCNSTR'
6828       include 'COMMON.CONTROL'
6829       ethetacnstr=0.0d0
6830 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6831       do i=ithetaconstr_start,ithetaconstr_end
6832         itheta=itheta_constr(i)
6833         thetiii=theta(itheta)
6834         difi=pinorm(thetiii-theta_constr0(i))
6835         if (difi.gt.theta_drange(i)) then
6836           difi=difi-theta_drange(i)
6837           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6838           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6839      &    +for_thet_constr(i)*difi**3
6840         else if (difi.lt.-drange(i)) then
6841           difi=difi+drange(i)
6842           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6843           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6844      &    +for_thet_constr(i)*difi**3
6845         else
6846           difi=0.0
6847         endif
6848        if (energy_dec) then
6849         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6850      &    i,itheta,rad2deg*thetiii,
6851      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6852      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6853      &    gloc(itheta+nphi-2,icg)
6854         endif
6855       enddo
6856       return
6857       end
6858 c------------------------------------------------------------------------------
6859 c------------------------------------------------------------------------------
6860       subroutine eback_sc_corr(esccor)
6861 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6862 c        conformational states; temporarily implemented as differences
6863 c        between UNRES torsional potentials (dependent on three types of
6864 c        residues) and the torsional potentials dependent on all 20 types
6865 c        of residues computed from AM1 energy surfaces of terminally-blocked
6866 c        amino-acid residues.
6867       implicit real*8 (a-h,o-z)
6868       include 'DIMENSIONS'
6869       include 'DIMENSIONS.ZSCOPT'
6870       include 'COMMON.VAR'
6871       include 'COMMON.GEO'
6872       include 'COMMON.LOCAL'
6873       include 'COMMON.TORSION'
6874       include 'COMMON.SCCOR'
6875       include 'COMMON.INTERACT'
6876       include 'COMMON.DERIV'
6877       include 'COMMON.CHAIN'
6878       include 'COMMON.NAMES'
6879       include 'COMMON.IOUNITS'
6880       include 'COMMON.FFIELD'
6881       include 'COMMON.CONTROL'
6882       logical lprn
6883 C Set lprn=.true. for debugging
6884       lprn=.false.
6885 c      lprn=.true.
6886 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6887       esccor=0.0D0
6888       do i=itau_start,itau_end
6889         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6890         esccor_ii=0.0D0
6891         isccori=isccortyp(itype(i-2))
6892         isccori1=isccortyp(itype(i-1))
6893         phii=phi(i)
6894         do intertyp=1,3 !intertyp
6895 cc Added 09 May 2012 (Adasko)
6896 cc  Intertyp means interaction type of backbone mainchain correlation:
6897 c   1 = SC...Ca...Ca...Ca
6898 c   2 = Ca...Ca...Ca...SC
6899 c   3 = SC...Ca...Ca...SCi
6900         gloci=0.0D0
6901         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6902      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6903      &      (itype(i-1).eq.ntyp1)))
6904      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6905      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6906      &     .or.(itype(i).eq.ntyp1)))
6907      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6908      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6909      &      (itype(i-3).eq.ntyp1)))) cycle
6910         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6911         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6912      & cycle
6913        do j=1,nterm_sccor(isccori,isccori1)
6914           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6915           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6916           cosphi=dcos(j*tauangle(intertyp,i))
6917           sinphi=dsin(j*tauangle(intertyp,i))
6918            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6919            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6920          enddo
6921 C      write (iout,*)"EBACK_SC_COR",esccor,i
6922 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6923 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6924 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6925         if (lprn)
6926      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6927      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6928      &  (v1sccor(j,1,itori,itori1),j=1,6)
6929      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6930 c        gsccor_loc(i-3)=gloci
6931        enddo !intertyp
6932       enddo
6933       return
6934       end
6935 c------------------------------------------------------------------------------
6936       subroutine multibody(ecorr)
6937 C This subroutine calculates multi-body contributions to energy following
6938 C the idea of Skolnick et al. If side chains I and J make a contact and
6939 C at the same time side chains I+1 and J+1 make a contact, an extra
6940 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6941       implicit real*8 (a-h,o-z)
6942       include 'DIMENSIONS'
6943       include 'COMMON.IOUNITS'
6944       include 'COMMON.DERIV'
6945       include 'COMMON.INTERACT'
6946       include 'COMMON.CONTACTS'
6947       double precision gx(3),gx1(3)
6948       logical lprn
6949
6950 C Set lprn=.true. for debugging
6951       lprn=.false.
6952
6953       if (lprn) then
6954         write (iout,'(a)') 'Contact function values:'
6955         do i=nnt,nct-2
6956           write (iout,'(i2,20(1x,i2,f10.5))')
6957      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6958         enddo
6959       endif
6960       ecorr=0.0D0
6961       do i=nnt,nct
6962         do j=1,3
6963           gradcorr(j,i)=0.0D0
6964           gradxorr(j,i)=0.0D0
6965         enddo
6966       enddo
6967       do i=nnt,nct-2
6968
6969         DO ISHIFT = 3,4
6970
6971         i1=i+ishift
6972         num_conti=num_cont(i)
6973         num_conti1=num_cont(i1)
6974         do jj=1,num_conti
6975           j=jcont(jj,i)
6976           do kk=1,num_conti1
6977             j1=jcont(kk,i1)
6978             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6979 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6980 cd   &                   ' ishift=',ishift
6981 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6982 C The system gains extra energy.
6983               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6984             endif   ! j1==j+-ishift
6985           enddo     ! kk
6986         enddo       ! jj
6987
6988         ENDDO ! ISHIFT
6989
6990       enddo         ! i
6991       return
6992       end
6993 c------------------------------------------------------------------------------
6994       double precision function esccorr(i,j,k,l,jj,kk)
6995       implicit real*8 (a-h,o-z)
6996       include 'DIMENSIONS'
6997       include 'COMMON.IOUNITS'
6998       include 'COMMON.DERIV'
6999       include 'COMMON.INTERACT'
7000       include 'COMMON.CONTACTS'
7001       double precision gx(3),gx1(3)
7002       logical lprn
7003       lprn=.false.
7004       eij=facont(jj,i)
7005       ekl=facont(kk,k)
7006 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7007 C Calculate the multi-body contribution to energy.
7008 C Calculate multi-body contributions to the gradient.
7009 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7010 cd   & k,l,(gacont(m,kk,k),m=1,3)
7011       do m=1,3
7012         gx(m) =ekl*gacont(m,jj,i)
7013         gx1(m)=eij*gacont(m,kk,k)
7014         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7015         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7016         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7017         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7018       enddo
7019       do m=i,j-1
7020         do ll=1,3
7021           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7022         enddo
7023       enddo
7024       do m=k,l-1
7025         do ll=1,3
7026           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7027         enddo
7028       enddo
7029       esccorr=-eij*ekl
7030       return
7031       end
7032 c------------------------------------------------------------------------------
7033       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7034 C This subroutine calculates multi-body contributions to hydrogen-bonding
7035       implicit real*8 (a-h,o-z)
7036       include 'DIMENSIONS'
7037       include 'DIMENSIONS.ZSCOPT'
7038       include 'COMMON.IOUNITS'
7039       include 'COMMON.FFIELD'
7040       include 'COMMON.DERIV'
7041       include 'COMMON.INTERACT'
7042       include 'COMMON.CONTACTS'
7043       double precision gx(3),gx1(3)
7044       logical lprn,ldone
7045
7046 C Set lprn=.true. for debugging
7047       lprn=.false.
7048       if (lprn) then
7049         write (iout,'(a)') 'Contact function values:'
7050         do i=nnt,nct-2
7051           write (iout,'(2i3,50(1x,i2,f5.2))')
7052      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7053      &    j=1,num_cont_hb(i))
7054         enddo
7055       endif
7056       ecorr=0.0D0
7057 C Remove the loop below after debugging !!!
7058       do i=nnt,nct
7059         do j=1,3
7060           gradcorr(j,i)=0.0D0
7061           gradxorr(j,i)=0.0D0
7062         enddo
7063       enddo
7064 C Calculate the local-electrostatic correlation terms
7065       do i=iatel_s,iatel_e+1
7066         i1=i+1
7067         num_conti=num_cont_hb(i)
7068         num_conti1=num_cont_hb(i+1)
7069         do jj=1,num_conti
7070           j=jcont_hb(jj,i)
7071           do kk=1,num_conti1
7072             j1=jcont_hb(kk,i1)
7073 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7074 c     &         ' jj=',jj,' kk=',kk
7075             if (j1.eq.j+1 .or. j1.eq.j-1) then
7076 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7077 C The system gains extra energy.
7078               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7079               n_corr=n_corr+1
7080             else if (j1.eq.j) then
7081 C Contacts I-J and I-(J+1) occur simultaneously.
7082 C The system loses extra energy.
7083 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7084             endif
7085           enddo ! kk
7086           do kk=1,num_conti
7087             j1=jcont_hb(kk,i)
7088 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7089 c    &         ' jj=',jj,' kk=',kk
7090             if (j1.eq.j+1) then
7091 C Contacts I-J and (I+1)-J occur simultaneously.
7092 C The system loses extra energy.
7093 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7094             endif ! j1==j+1
7095           enddo ! kk
7096         enddo ! jj
7097       enddo ! i
7098       return
7099       end
7100 c------------------------------------------------------------------------------
7101       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7102      &  n_corr1)
7103 C This subroutine calculates multi-body contributions to hydrogen-bonding
7104       implicit real*8 (a-h,o-z)
7105       include 'DIMENSIONS'
7106       include 'DIMENSIONS.ZSCOPT'
7107       include 'COMMON.IOUNITS'
7108 #ifdef MPI
7109       include "mpif.h"
7110 #endif
7111       include 'COMMON.FFIELD'
7112       include 'COMMON.DERIV'
7113       include 'COMMON.LOCAL'
7114       include 'COMMON.INTERACT'
7115       include 'COMMON.CONTACTS'
7116       include 'COMMON.CHAIN'
7117       include 'COMMON.CONTROL'
7118       include 'COMMON.SHIELD'
7119       double precision gx(3),gx1(3)
7120       integer num_cont_hb_old(maxres)
7121       logical lprn,ldone
7122       double precision eello4,eello5,eelo6,eello_turn6
7123       external eello4,eello5,eello6,eello_turn6
7124 C Set lprn=.true. for debugging
7125       lprn=.false.
7126       eturn6=0.0d0
7127       if (lprn) then
7128         write (iout,'(a)') 'Contact function values:'
7129         do i=nnt,nct-2
7130           write (iout,'(2i3,50(1x,i2,5f6.3))')
7131      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7132      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7133         enddo
7134       endif
7135       ecorr=0.0D0
7136       ecorr5=0.0d0
7137       ecorr6=0.0d0
7138 C Remove the loop below after debugging !!!
7139       do i=nnt,nct
7140         do j=1,3
7141           gradcorr(j,i)=0.0D0
7142           gradxorr(j,i)=0.0D0
7143         enddo
7144       enddo
7145 C Calculate the dipole-dipole interaction energies
7146       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7147       do i=iatel_s,iatel_e+1
7148         num_conti=num_cont_hb(i)
7149         do jj=1,num_conti
7150           j=jcont_hb(jj,i)
7151 #ifdef MOMENT
7152           call dipole(i,j,jj)
7153 #endif
7154         enddo
7155       enddo
7156       endif
7157 C Calculate the local-electrostatic correlation terms
7158 c                write (iout,*) "gradcorr5 in eello5 before loop"
7159 c                do iii=1,nres
7160 c                  write (iout,'(i5,3f10.5)')
7161 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7162 c                enddo
7163       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7164 c        write (iout,*) "corr loop i",i
7165         i1=i+1
7166         num_conti=num_cont_hb(i)
7167         num_conti1=num_cont_hb(i+1)
7168         do jj=1,num_conti
7169           j=jcont_hb(jj,i)
7170           jp=iabs(j)
7171           do kk=1,num_conti1
7172             j1=jcont_hb(kk,i1)
7173             jp1=iabs(j1)
7174 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7175 c     &         ' jj=',jj,' kk=',kk
7176 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7177             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7178      &          .or. j.lt.0 .and. j1.gt.0) .and.
7179      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7180 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7181 C The system gains extra energy.
7182               n_corr=n_corr+1
7183               sqd1=dsqrt(d_cont(jj,i))
7184               sqd2=dsqrt(d_cont(kk,i1))
7185               sred_geom = sqd1*sqd2
7186               IF (sred_geom.lt.cutoff_corr) THEN
7187                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7188      &            ekont,fprimcont)
7189 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7190 cd     &         ' jj=',jj,' kk=',kk
7191                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7192                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7193                 do l=1,3
7194                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7195                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7196                 enddo
7197                 n_corr1=n_corr1+1
7198 cd               write (iout,*) 'sred_geom=',sred_geom,
7199 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7200 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7201 cd               write (iout,*) "g_contij",g_contij
7202 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7203 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7204                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7205                 if (wcorr4.gt.0.0d0)
7206      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7207 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7208                   if (energy_dec.and.wcorr4.gt.0.0d0)
7209      1                 write (iout,'(a6,4i5,0pf7.3)')
7210      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7211 c                write (iout,*) "gradcorr5 before eello5"
7212 c                do iii=1,nres
7213 c                  write (iout,'(i5,3f10.5)')
7214 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7215 c                enddo
7216                 if (wcorr5.gt.0.0d0)
7217      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7218 c                write (iout,*) "gradcorr5 after eello5"
7219 c                do iii=1,nres
7220 c                  write (iout,'(i5,3f10.5)')
7221 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7222 c                enddo
7223                   if (energy_dec.and.wcorr5.gt.0.0d0)
7224      1                 write (iout,'(a6,4i5,0pf7.3)')
7225      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7226 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7227 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7228                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7229      &               .or. wturn6.eq.0.0d0))then
7230 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7231                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7232                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7233      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7234 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7235 cd     &            'ecorr6=',ecorr6
7236 cd                write (iout,'(4e15.5)') sred_geom,
7237 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7238 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7239 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7240                 else if (wturn6.gt.0.0d0
7241      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7242 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7243                   eturn6=eturn6+eello_turn6(i,jj,kk)
7244                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7245      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7246 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7247                 endif
7248               ENDIF
7249 1111          continue
7250             endif
7251           enddo ! kk
7252         enddo ! jj
7253       enddo ! i
7254       do i=1,nres
7255         num_cont_hb(i)=num_cont_hb_old(i)
7256       enddo
7257 c                write (iout,*) "gradcorr5 in eello5"
7258 c                do iii=1,nres
7259 c                  write (iout,'(i5,3f10.5)')
7260 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7261 c                enddo
7262       return
7263       end
7264 c------------------------------------------------------------------------------
7265       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7266       implicit real*8 (a-h,o-z)
7267       include 'DIMENSIONS'
7268       include 'DIMENSIONS.ZSCOPT'
7269       include 'COMMON.IOUNITS'
7270       include 'COMMON.DERIV'
7271       include 'COMMON.INTERACT'
7272       include 'COMMON.CONTACTS'
7273       include 'COMMON.SHIELD'
7274       include 'COMMON.CONTROL'
7275       double precision gx(3),gx1(3)
7276       logical lprn
7277       lprn=.false.
7278 C      print *,"wchodze",fac_shield(i),shield_mode
7279       eij=facont_hb(jj,i)
7280       ekl=facont_hb(kk,k)
7281       ees0pij=ees0p(jj,i)
7282       ees0pkl=ees0p(kk,k)
7283       ees0mij=ees0m(jj,i)
7284       ees0mkl=ees0m(kk,k)
7285       ekont=eij*ekl
7286       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7287 C*
7288 C     & fac_shield(i)**2*fac_shield(j)**2
7289 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7290 C Following 4 lines for diagnostics.
7291 cd    ees0pkl=0.0D0
7292 cd    ees0pij=1.0D0
7293 cd    ees0mkl=0.0D0
7294 cd    ees0mij=1.0D0
7295 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7296 c     & 'Contacts ',i,j,
7297 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7298 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7299 c     & 'gradcorr_long'
7300 C Calculate the multi-body contribution to energy.
7301 C      ecorr=ecorr+ekont*ees
7302 C Calculate multi-body contributions to the gradient.
7303       coeffpees0pij=coeffp*ees0pij
7304       coeffmees0mij=coeffm*ees0mij
7305       coeffpees0pkl=coeffp*ees0pkl
7306       coeffmees0mkl=coeffm*ees0mkl
7307       do ll=1,3
7308 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7309         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7310      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7311      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7312         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7313      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7314      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7315 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7316         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7317      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7318      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7319         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7320      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7321      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7322         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7323      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7324      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7325         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7326         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7327         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7328      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7329      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7330         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7331         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7332 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7333       enddo
7334 c      write (iout,*)
7335 cgrad      do m=i+1,j-1
7336 cgrad        do ll=1,3
7337 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7338 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7339 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7340 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7341 cgrad        enddo
7342 cgrad      enddo
7343 cgrad      do m=k+1,l-1
7344 cgrad        do ll=1,3
7345 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7346 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7347 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7348 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7349 cgrad        enddo
7350 cgrad      enddo
7351 c      write (iout,*) "ehbcorr",ekont*ees
7352 C      print *,ekont,ees,i,k
7353       ehbcorr=ekont*ees
7354 C now gradient over shielding
7355 C      return
7356       if (shield_mode.gt.0) then
7357        j=ees0plist(jj,i)
7358        l=ees0plist(kk,k)
7359 C        print *,i,j,fac_shield(i),fac_shield(j),
7360 C     &fac_shield(k),fac_shield(l)
7361         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7362      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7363           do ilist=1,ishield_list(i)
7364            iresshield=shield_list(ilist,i)
7365            do m=1,3
7366            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7367 C     &      *2.0
7368            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7369      &              rlocshield
7370      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7371             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7372      &+rlocshield
7373            enddo
7374           enddo
7375           do ilist=1,ishield_list(j)
7376            iresshield=shield_list(ilist,j)
7377            do m=1,3
7378            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7379 C     &     *2.0
7380            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7381      &              rlocshield
7382      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7383            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7384      &     +rlocshield
7385            enddo
7386           enddo
7387
7388           do ilist=1,ishield_list(k)
7389            iresshield=shield_list(ilist,k)
7390            do m=1,3
7391            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7392 C     &     *2.0
7393            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7394      &              rlocshield
7395      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7396            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7397      &     +rlocshield
7398            enddo
7399           enddo
7400           do ilist=1,ishield_list(l)
7401            iresshield=shield_list(ilist,l)
7402            do m=1,3
7403            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7404 C     &     *2.0
7405            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7406      &              rlocshield
7407      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7408            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7409      &     +rlocshield
7410            enddo
7411           enddo
7412 C          print *,gshieldx(m,iresshield)
7413           do m=1,3
7414             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7415      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7416             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7417      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7418             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7419      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7420             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7421      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7422
7423             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7424      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7425             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7426      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7427             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7428      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7429             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7430      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7431
7432            enddo
7433       endif
7434       endif
7435       return
7436       end
7437 #ifdef MOMENT
7438 C---------------------------------------------------------------------------
7439       subroutine dipole(i,j,jj)
7440       implicit real*8 (a-h,o-z)
7441       include 'DIMENSIONS'
7442       include 'DIMENSIONS.ZSCOPT'
7443       include 'COMMON.IOUNITS'
7444       include 'COMMON.CHAIN'
7445       include 'COMMON.FFIELD'
7446       include 'COMMON.DERIV'
7447       include 'COMMON.INTERACT'
7448       include 'COMMON.CONTACTS'
7449       include 'COMMON.TORSION'
7450       include 'COMMON.VAR'
7451       include 'COMMON.GEO'
7452       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7453      &  auxmat(2,2)
7454       iti1 = itortyp(itype(i+1))
7455       if (j.lt.nres-1) then
7456         itj1 = itype2loc(itype(j+1))
7457       else
7458         itj1=nloctyp
7459       endif
7460       do iii=1,2
7461         dipi(iii,1)=Ub2(iii,i)
7462         dipderi(iii)=Ub2der(iii,i)
7463         dipi(iii,2)=b1(iii,i+1)
7464         dipj(iii,1)=Ub2(iii,j)
7465         dipderj(iii)=Ub2der(iii,j)
7466         dipj(iii,2)=b1(iii,j+1)
7467       enddo
7468       kkk=0
7469       do iii=1,2
7470         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7471         do jjj=1,2
7472           kkk=kkk+1
7473           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7474         enddo
7475       enddo
7476       do kkk=1,5
7477         do lll=1,3
7478           mmm=0
7479           do iii=1,2
7480             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7481      &        auxvec(1))
7482             do jjj=1,2
7483               mmm=mmm+1
7484               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7485             enddo
7486           enddo
7487         enddo
7488       enddo
7489       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7490       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7491       do iii=1,2
7492         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7493       enddo
7494       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7495       do iii=1,2
7496         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7497       enddo
7498       return
7499       end
7500 #endif
7501 C---------------------------------------------------------------------------
7502       subroutine calc_eello(i,j,k,l,jj,kk)
7503 C
7504 C This subroutine computes matrices and vectors needed to calculate
7505 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7506 C
7507       implicit real*8 (a-h,o-z)
7508       include 'DIMENSIONS'
7509       include 'DIMENSIONS.ZSCOPT'
7510       include 'COMMON.IOUNITS'
7511       include 'COMMON.CHAIN'
7512       include 'COMMON.DERIV'
7513       include 'COMMON.INTERACT'
7514       include 'COMMON.CONTACTS'
7515       include 'COMMON.TORSION'
7516       include 'COMMON.VAR'
7517       include 'COMMON.GEO'
7518       include 'COMMON.FFIELD'
7519       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7520      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7521       logical lprn
7522       common /kutas/ lprn
7523 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7524 cd     & ' jj=',jj,' kk=',kk
7525 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7526 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7527 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7528       do iii=1,2
7529         do jjj=1,2
7530           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7531           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7532         enddo
7533       enddo
7534       call transpose2(aa1(1,1),aa1t(1,1))
7535       call transpose2(aa2(1,1),aa2t(1,1))
7536       do kkk=1,5
7537         do lll=1,3
7538           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7539      &      aa1tder(1,1,lll,kkk))
7540           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7541      &      aa2tder(1,1,lll,kkk))
7542         enddo
7543       enddo
7544       if (l.eq.j+1) then
7545 C parallel orientation of the two CA-CA-CA frames.
7546         if (i.gt.1) then
7547           iti=itype2loc(itype(i))
7548         else
7549           iti=nloctyp
7550         endif
7551         itk1=itype2loc(itype(k+1))
7552         itj=itype2loc(itype(j))
7553         if (l.lt.nres-1) then
7554           itl1=itype2loc(itype(l+1))
7555         else
7556           itl1=nloctyp
7557         endif
7558 C A1 kernel(j+1) A2T
7559 cd        do iii=1,2
7560 cd          write (iout,'(3f10.5,5x,3f10.5)')
7561 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7562 cd        enddo
7563         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7564      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7565      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7566 C Following matrices are needed only for 6-th order cumulants
7567         IF (wcorr6.gt.0.0d0) THEN
7568         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7569      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7570      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7571         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7572      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7573      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7574      &   ADtEAderx(1,1,1,1,1,1))
7575         lprn=.false.
7576         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7577      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7578      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7579      &   ADtEA1derx(1,1,1,1,1,1))
7580         ENDIF
7581 C End 6-th order cumulants
7582 cd        lprn=.false.
7583 cd        if (lprn) then
7584 cd        write (2,*) 'In calc_eello6'
7585 cd        do iii=1,2
7586 cd          write (2,*) 'iii=',iii
7587 cd          do kkk=1,5
7588 cd            write (2,*) 'kkk=',kkk
7589 cd            do jjj=1,2
7590 cd              write (2,'(3(2f10.5),5x)')
7591 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7592 cd            enddo
7593 cd          enddo
7594 cd        enddo
7595 cd        endif
7596         call transpose2(EUgder(1,1,k),auxmat(1,1))
7597         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7598         call transpose2(EUg(1,1,k),auxmat(1,1))
7599         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7600         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7601         do iii=1,2
7602           do kkk=1,5
7603             do lll=1,3
7604               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7605      &          EAEAderx(1,1,lll,kkk,iii,1))
7606             enddo
7607           enddo
7608         enddo
7609 C A1T kernel(i+1) A2
7610         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7611      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7612      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7613 C Following matrices are needed only for 6-th order cumulants
7614         IF (wcorr6.gt.0.0d0) THEN
7615         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7616      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7617      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7618         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7619      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7620      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7621      &   ADtEAderx(1,1,1,1,1,2))
7622         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7623      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7624      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7625      &   ADtEA1derx(1,1,1,1,1,2))
7626         ENDIF
7627 C End 6-th order cumulants
7628         call transpose2(EUgder(1,1,l),auxmat(1,1))
7629         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7630         call transpose2(EUg(1,1,l),auxmat(1,1))
7631         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7632         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7633         do iii=1,2
7634           do kkk=1,5
7635             do lll=1,3
7636               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7637      &          EAEAderx(1,1,lll,kkk,iii,2))
7638             enddo
7639           enddo
7640         enddo
7641 C AEAb1 and AEAb2
7642 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7643 C They are needed only when the fifth- or the sixth-order cumulants are
7644 C indluded.
7645         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7646         call transpose2(AEA(1,1,1),auxmat(1,1))
7647         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7648         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7649         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7650         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7651         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7652         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7653         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7654         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7655         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7656         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7657         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7658         call transpose2(AEA(1,1,2),auxmat(1,1))
7659         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7660         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7661         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7662         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7663         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7664         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7665         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7666         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7667         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7668         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7669         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7670 C Calculate the Cartesian derivatives of the vectors.
7671         do iii=1,2
7672           do kkk=1,5
7673             do lll=1,3
7674               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7675               call matvec2(auxmat(1,1),b1(1,i),
7676      &          AEAb1derx(1,lll,kkk,iii,1,1))
7677               call matvec2(auxmat(1,1),Ub2(1,i),
7678      &          AEAb2derx(1,lll,kkk,iii,1,1))
7679               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7680      &          AEAb1derx(1,lll,kkk,iii,2,1))
7681               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7682      &          AEAb2derx(1,lll,kkk,iii,2,1))
7683               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7684               call matvec2(auxmat(1,1),b1(1,j),
7685      &          AEAb1derx(1,lll,kkk,iii,1,2))
7686               call matvec2(auxmat(1,1),Ub2(1,j),
7687      &          AEAb2derx(1,lll,kkk,iii,1,2))
7688               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7689      &          AEAb1derx(1,lll,kkk,iii,2,2))
7690               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7691      &          AEAb2derx(1,lll,kkk,iii,2,2))
7692             enddo
7693           enddo
7694         enddo
7695         ENDIF
7696 C End vectors
7697       else
7698 C Antiparallel orientation of the two CA-CA-CA frames.
7699         if (i.gt.1) then
7700           iti=itype2loc(itype(i))
7701         else
7702           iti=nloctyp
7703         endif
7704         itk1=itype2loc(itype(k+1))
7705         itl=itype2loc(itype(l))
7706         itj=itype2loc(itype(j))
7707         if (j.lt.nres-1) then
7708           itj1=itype2loc(itype(j+1))
7709         else
7710           itj1=nloctyp
7711         endif
7712 C A2 kernel(j-1)T A1T
7713         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7714      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7715      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7716 C Following matrices are needed only for 6-th order cumulants
7717         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7718      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7719         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7720      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7721      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7722         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7723      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7724      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7725      &   ADtEAderx(1,1,1,1,1,1))
7726         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7727      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7728      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7729      &   ADtEA1derx(1,1,1,1,1,1))
7730         ENDIF
7731 C End 6-th order cumulants
7732         call transpose2(EUgder(1,1,k),auxmat(1,1))
7733         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7734         call transpose2(EUg(1,1,k),auxmat(1,1))
7735         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7736         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7737         do iii=1,2
7738           do kkk=1,5
7739             do lll=1,3
7740               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7741      &          EAEAderx(1,1,lll,kkk,iii,1))
7742             enddo
7743           enddo
7744         enddo
7745 C A2T kernel(i+1)T A1
7746         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7747      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7748      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7749 C Following matrices are needed only for 6-th order cumulants
7750         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7751      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7752         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7753      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7754      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7755         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7756      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7757      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7758      &   ADtEAderx(1,1,1,1,1,2))
7759         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7760      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7761      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7762      &   ADtEA1derx(1,1,1,1,1,2))
7763         ENDIF
7764 C End 6-th order cumulants
7765         call transpose2(EUgder(1,1,j),auxmat(1,1))
7766         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7767         call transpose2(EUg(1,1,j),auxmat(1,1))
7768         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7769         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7770         do iii=1,2
7771           do kkk=1,5
7772             do lll=1,3
7773               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7774      &          EAEAderx(1,1,lll,kkk,iii,2))
7775             enddo
7776           enddo
7777         enddo
7778 C AEAb1 and AEAb2
7779 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7780 C They are needed only when the fifth- or the sixth-order cumulants are
7781 C indluded.
7782         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7783      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7784         call transpose2(AEA(1,1,1),auxmat(1,1))
7785         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7786         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7787         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7788         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7789         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7790         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7791         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7792         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7793         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7794         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7795         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7796         call transpose2(AEA(1,1,2),auxmat(1,1))
7797         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7798         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7799         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7800         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7801         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7802         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7803         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7804         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7805         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7806         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7807         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7808 C Calculate the Cartesian derivatives of the vectors.
7809         do iii=1,2
7810           do kkk=1,5
7811             do lll=1,3
7812               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7813               call matvec2(auxmat(1,1),b1(1,i),
7814      &          AEAb1derx(1,lll,kkk,iii,1,1))
7815               call matvec2(auxmat(1,1),Ub2(1,i),
7816      &          AEAb2derx(1,lll,kkk,iii,1,1))
7817               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7818      &          AEAb1derx(1,lll,kkk,iii,2,1))
7819               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7820      &          AEAb2derx(1,lll,kkk,iii,2,1))
7821               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7822               call matvec2(auxmat(1,1),b1(1,l),
7823      &          AEAb1derx(1,lll,kkk,iii,1,2))
7824               call matvec2(auxmat(1,1),Ub2(1,l),
7825      &          AEAb2derx(1,lll,kkk,iii,1,2))
7826               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7827      &          AEAb1derx(1,lll,kkk,iii,2,2))
7828               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7829      &          AEAb2derx(1,lll,kkk,iii,2,2))
7830             enddo
7831           enddo
7832         enddo
7833         ENDIF
7834 C End vectors
7835       endif
7836       return
7837       end
7838 C---------------------------------------------------------------------------
7839       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7840      &  KK,KKderg,AKA,AKAderg,AKAderx)
7841       implicit none
7842       integer nderg
7843       logical transp
7844       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7845      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7846      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7847       integer iii,kkk,lll
7848       integer jjj,mmm
7849       logical lprn
7850       common /kutas/ lprn
7851       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7852       do iii=1,nderg
7853         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7854      &    AKAderg(1,1,iii))
7855       enddo
7856 cd      if (lprn) write (2,*) 'In kernel'
7857       do kkk=1,5
7858 cd        if (lprn) write (2,*) 'kkk=',kkk
7859         do lll=1,3
7860           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7861      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7862 cd          if (lprn) then
7863 cd            write (2,*) 'lll=',lll
7864 cd            write (2,*) 'iii=1'
7865 cd            do jjj=1,2
7866 cd              write (2,'(3(2f10.5),5x)')
7867 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7868 cd            enddo
7869 cd          endif
7870           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7871      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7872 cd          if (lprn) then
7873 cd            write (2,*) 'lll=',lll
7874 cd            write (2,*) 'iii=2'
7875 cd            do jjj=1,2
7876 cd              write (2,'(3(2f10.5),5x)')
7877 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7878 cd            enddo
7879 cd          endif
7880         enddo
7881       enddo
7882       return
7883       end
7884 C---------------------------------------------------------------------------
7885       double precision function eello4(i,j,k,l,jj,kk)
7886       implicit real*8 (a-h,o-z)
7887       include 'DIMENSIONS'
7888       include 'DIMENSIONS.ZSCOPT'
7889       include 'COMMON.IOUNITS'
7890       include 'COMMON.CHAIN'
7891       include 'COMMON.DERIV'
7892       include 'COMMON.INTERACT'
7893       include 'COMMON.CONTACTS'
7894       include 'COMMON.TORSION'
7895       include 'COMMON.VAR'
7896       include 'COMMON.GEO'
7897       double precision pizda(2,2),ggg1(3),ggg2(3)
7898 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7899 cd        eello4=0.0d0
7900 cd        return
7901 cd      endif
7902 cd      print *,'eello4:',i,j,k,l,jj,kk
7903 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7904 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7905 cold      eij=facont_hb(jj,i)
7906 cold      ekl=facont_hb(kk,k)
7907 cold      ekont=eij*ekl
7908       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7909       if (calc_grad) then
7910 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7911       gcorr_loc(k-1)=gcorr_loc(k-1)
7912      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7913       if (l.eq.j+1) then
7914         gcorr_loc(l-1)=gcorr_loc(l-1)
7915      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7916       else
7917         gcorr_loc(j-1)=gcorr_loc(j-1)
7918      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7919       endif
7920       do iii=1,2
7921         do kkk=1,5
7922           do lll=1,3
7923             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7924      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7925 cd            derx(lll,kkk,iii)=0.0d0
7926           enddo
7927         enddo
7928       enddo
7929 cd      gcorr_loc(l-1)=0.0d0
7930 cd      gcorr_loc(j-1)=0.0d0
7931 cd      gcorr_loc(k-1)=0.0d0
7932 cd      eel4=1.0d0
7933 cd      write (iout,*)'Contacts have occurred for peptide groups',
7934 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7935 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7936       if (j.lt.nres-1) then
7937         j1=j+1
7938         j2=j-1
7939       else
7940         j1=j-1
7941         j2=j-2
7942       endif
7943       if (l.lt.nres-1) then
7944         l1=l+1
7945         l2=l-1
7946       else
7947         l1=l-1
7948         l2=l-2
7949       endif
7950       do ll=1,3
7951 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7952 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7953         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7954         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7955 cgrad        ghalf=0.5d0*ggg1(ll)
7956         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7957         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7958         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7959         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7960         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7961         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7962 cgrad        ghalf=0.5d0*ggg2(ll)
7963         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7964         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7965         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7966         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7967         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7968         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7969       enddo
7970 cgrad      do m=i+1,j-1
7971 cgrad        do ll=1,3
7972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7973 cgrad        enddo
7974 cgrad      enddo
7975 cgrad      do m=k+1,l-1
7976 cgrad        do ll=1,3
7977 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7978 cgrad        enddo
7979 cgrad      enddo
7980 cgrad      do m=i+2,j2
7981 cgrad        do ll=1,3
7982 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7983 cgrad        enddo
7984 cgrad      enddo
7985 cgrad      do m=k+2,l2
7986 cgrad        do ll=1,3
7987 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7988 cgrad        enddo
7989 cgrad      enddo
7990 cd      do iii=1,nres-3
7991 cd        write (2,*) iii,gcorr_loc(iii)
7992 cd      enddo
7993       endif ! calc_grad
7994       eello4=ekont*eel4
7995 cd      write (2,*) 'ekont',ekont
7996 cd      write (iout,*) 'eello4',ekont*eel4
7997       return
7998       end
7999 C---------------------------------------------------------------------------
8000       double precision function eello5(i,j,k,l,jj,kk)
8001       implicit real*8 (a-h,o-z)
8002       include 'DIMENSIONS'
8003       include 'DIMENSIONS.ZSCOPT'
8004       include 'COMMON.IOUNITS'
8005       include 'COMMON.CHAIN'
8006       include 'COMMON.DERIV'
8007       include 'COMMON.INTERACT'
8008       include 'COMMON.CONTACTS'
8009       include 'COMMON.TORSION'
8010       include 'COMMON.VAR'
8011       include 'COMMON.GEO'
8012       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8013       double precision ggg1(3),ggg2(3)
8014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8015 C                                                                              C
8016 C                            Parallel chains                                   C
8017 C                                                                              C
8018 C          o             o                   o             o                   C
8019 C         /l\           / \             \   / \           / \   /              C
8020 C        /   \         /   \             \ /   \         /   \ /               C
8021 C       j| o |l1       | o |              o| o |         | o |o                C
8022 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8023 C      \i/   \         /   \ /             /   \         /   \                 C
8024 C       o    k1             o                                                  C
8025 C         (I)          (II)                (III)          (IV)                 C
8026 C                                                                              C
8027 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8028 C                                                                              C
8029 C                            Antiparallel chains                               C
8030 C                                                                              C
8031 C          o             o                   o             o                   C
8032 C         /j\           / \             \   / \           / \   /              C
8033 C        /   \         /   \             \ /   \         /   \ /               C
8034 C      j1| o |l        | o |              o| o |         | o |o                C
8035 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8036 C      \i/   \         /   \ /             /   \         /   \                 C
8037 C       o     k1            o                                                  C
8038 C         (I)          (II)                (III)          (IV)                 C
8039 C                                                                              C
8040 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8041 C                                                                              C
8042 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8043 C                                                                              C
8044 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8045 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8046 cd        eello5=0.0d0
8047 cd        return
8048 cd      endif
8049 cd      write (iout,*)
8050 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8051 cd     &   ' and',k,l
8052       itk=itype2loc(itype(k))
8053       itl=itype2loc(itype(l))
8054       itj=itype2loc(itype(j))
8055       eello5_1=0.0d0
8056       eello5_2=0.0d0
8057       eello5_3=0.0d0
8058       eello5_4=0.0d0
8059 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8060 cd     &   eel5_3_num,eel5_4_num)
8061       do iii=1,2
8062         do kkk=1,5
8063           do lll=1,3
8064             derx(lll,kkk,iii)=0.0d0
8065           enddo
8066         enddo
8067       enddo
8068 cd      eij=facont_hb(jj,i)
8069 cd      ekl=facont_hb(kk,k)
8070 cd      ekont=eij*ekl
8071 cd      write (iout,*)'Contacts have occurred for peptide groups',
8072 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8073 cd      goto 1111
8074 C Contribution from the graph I.
8075 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8076 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8077       call transpose2(EUg(1,1,k),auxmat(1,1))
8078       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8079       vv(1)=pizda(1,1)-pizda(2,2)
8080       vv(2)=pizda(1,2)+pizda(2,1)
8081       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8082      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8083       if (calc_grad) then
8084 C Explicit gradient in virtual-dihedral angles.
8085       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8086      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8087      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8088       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8089       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8090       vv(1)=pizda(1,1)-pizda(2,2)
8091       vv(2)=pizda(1,2)+pizda(2,1)
8092       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8093      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8094      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8095       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8096       vv(1)=pizda(1,1)-pizda(2,2)
8097       vv(2)=pizda(1,2)+pizda(2,1)
8098       if (l.eq.j+1) then
8099         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8100      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8101      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8102       else
8103         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8104      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8105      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8106       endif
8107 C Cartesian gradient
8108       do iii=1,2
8109         do kkk=1,5
8110           do lll=1,3
8111             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8112      &        pizda(1,1))
8113             vv(1)=pizda(1,1)-pizda(2,2)
8114             vv(2)=pizda(1,2)+pizda(2,1)
8115             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8116      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8117      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8118           enddo
8119         enddo
8120       enddo
8121       endif ! calc_grad
8122 c      goto 1112
8123 c1111  continue
8124 C Contribution from graph II
8125       call transpose2(EE(1,1,k),auxmat(1,1))
8126       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8127       vv(1)=pizda(1,1)+pizda(2,2)
8128       vv(2)=pizda(2,1)-pizda(1,2)
8129       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8130      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8131       if (calc_grad) then
8132 C Explicit gradient in virtual-dihedral angles.
8133       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8134      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8135       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8136       vv(1)=pizda(1,1)+pizda(2,2)
8137       vv(2)=pizda(2,1)-pizda(1,2)
8138       if (l.eq.j+1) then
8139         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8140      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8141      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8142       else
8143         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8144      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8145      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8146       endif
8147 C Cartesian gradient
8148       do iii=1,2
8149         do kkk=1,5
8150           do lll=1,3
8151             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8152      &        pizda(1,1))
8153             vv(1)=pizda(1,1)+pizda(2,2)
8154             vv(2)=pizda(2,1)-pizda(1,2)
8155             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8156      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8157      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8158           enddo
8159         enddo
8160       enddo
8161       endif ! calc_grad
8162 cd      goto 1112
8163 cd1111  continue
8164       if (l.eq.j+1) then
8165 cd        goto 1110
8166 C Parallel orientation
8167 C Contribution from graph III
8168         call transpose2(EUg(1,1,l),auxmat(1,1))
8169         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8170         vv(1)=pizda(1,1)-pizda(2,2)
8171         vv(2)=pizda(1,2)+pizda(2,1)
8172         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8173      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8174         if (calc_grad) then
8175 C Explicit gradient in virtual-dihedral angles.
8176         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8177      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8178      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8179         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8180         vv(1)=pizda(1,1)-pizda(2,2)
8181         vv(2)=pizda(1,2)+pizda(2,1)
8182         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8183      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8184      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8185         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8186         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8187         vv(1)=pizda(1,1)-pizda(2,2)
8188         vv(2)=pizda(1,2)+pizda(2,1)
8189         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8190      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8191      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8192 C Cartesian gradient
8193         do iii=1,2
8194           do kkk=1,5
8195             do lll=1,3
8196               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8197      &          pizda(1,1))
8198               vv(1)=pizda(1,1)-pizda(2,2)
8199               vv(2)=pizda(1,2)+pizda(2,1)
8200               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8201      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8202      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8203             enddo
8204           enddo
8205         enddo
8206 cd        goto 1112
8207 C Contribution from graph IV
8208 cd1110    continue
8209         call transpose2(EE(1,1,l),auxmat(1,1))
8210         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8211         vv(1)=pizda(1,1)+pizda(2,2)
8212         vv(2)=pizda(2,1)-pizda(1,2)
8213         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8214      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8215 C Explicit gradient in virtual-dihedral angles.
8216         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8217      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8218         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8219         vv(1)=pizda(1,1)+pizda(2,2)
8220         vv(2)=pizda(2,1)-pizda(1,2)
8221         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8222      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8223      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8224 C Cartesian gradient
8225         do iii=1,2
8226           do kkk=1,5
8227             do lll=1,3
8228               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8229      &          pizda(1,1))
8230               vv(1)=pizda(1,1)+pizda(2,2)
8231               vv(2)=pizda(2,1)-pizda(1,2)
8232               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8233      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8234      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8235             enddo
8236           enddo
8237         enddo
8238         endif ! calc_grad
8239       else
8240 C Antiparallel orientation
8241 C Contribution from graph III
8242 c        goto 1110
8243         call transpose2(EUg(1,1,j),auxmat(1,1))
8244         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8245         vv(1)=pizda(1,1)-pizda(2,2)
8246         vv(2)=pizda(1,2)+pizda(2,1)
8247         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8248      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8249         if (calc_grad) then
8250 C Explicit gradient in virtual-dihedral angles.
8251         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8252      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8253      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8254         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8255         vv(1)=pizda(1,1)-pizda(2,2)
8256         vv(2)=pizda(1,2)+pizda(2,1)
8257         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8258      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8259      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8260         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8261         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8262         vv(1)=pizda(1,1)-pizda(2,2)
8263         vv(2)=pizda(1,2)+pizda(2,1)
8264         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8265      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8266      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8267 C Cartesian gradient
8268         do iii=1,2
8269           do kkk=1,5
8270             do lll=1,3
8271               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8272      &          pizda(1,1))
8273               vv(1)=pizda(1,1)-pizda(2,2)
8274               vv(2)=pizda(1,2)+pizda(2,1)
8275               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8276      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8277      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8278             enddo
8279           enddo
8280         enddo
8281         endif ! calc_grad
8282 cd        goto 1112
8283 C Contribution from graph IV
8284 1110    continue
8285         call transpose2(EE(1,1,j),auxmat(1,1))
8286         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8287         vv(1)=pizda(1,1)+pizda(2,2)
8288         vv(2)=pizda(2,1)-pizda(1,2)
8289         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8290      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8291         if (calc_grad) then
8292 C Explicit gradient in virtual-dihedral angles.
8293         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8294      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8295         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8296         vv(1)=pizda(1,1)+pizda(2,2)
8297         vv(2)=pizda(2,1)-pizda(1,2)
8298         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8299      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8300      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8301 C Cartesian gradient
8302         do iii=1,2
8303           do kkk=1,5
8304             do lll=1,3
8305               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8306      &          pizda(1,1))
8307               vv(1)=pizda(1,1)+pizda(2,2)
8308               vv(2)=pizda(2,1)-pizda(1,2)
8309               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8310      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8311      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8312             enddo
8313           enddo
8314         enddo
8315         endif ! calc_grad
8316       endif
8317 1112  continue
8318       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8319 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8320 cd        write (2,*) 'ijkl',i,j,k,l
8321 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8322 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8323 cd      endif
8324 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8325 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8326 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8327 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8328       if (calc_grad) then
8329       if (j.lt.nres-1) then
8330         j1=j+1
8331         j2=j-1
8332       else
8333         j1=j-1
8334         j2=j-2
8335       endif
8336       if (l.lt.nres-1) then
8337         l1=l+1
8338         l2=l-1
8339       else
8340         l1=l-1
8341         l2=l-2
8342       endif
8343 cd      eij=1.0d0
8344 cd      ekl=1.0d0
8345 cd      ekont=1.0d0
8346 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8347 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8348 C        summed up outside the subrouine as for the other subroutines
8349 C        handling long-range interactions. The old code is commented out
8350 C        with "cgrad" to keep track of changes.
8351       do ll=1,3
8352 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8353 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8354         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8355         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8356 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8357 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8358 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8359 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8360 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8361 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8362 c     &   gradcorr5ij,
8363 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8364 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8365 cgrad        ghalf=0.5d0*ggg1(ll)
8366 cd        ghalf=0.0d0
8367         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8368         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8369         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8370         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8371         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8372         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8373 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8374 cgrad        ghalf=0.5d0*ggg2(ll)
8375 cd        ghalf=0.0d0
8376         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8377         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8378         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8379         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8380         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8381         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8382       enddo
8383       endif ! calc_grad
8384 cd      goto 1112
8385 cgrad      do m=i+1,j-1
8386 cgrad        do ll=1,3
8387 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8388 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8389 cgrad        enddo
8390 cgrad      enddo
8391 cgrad      do m=k+1,l-1
8392 cgrad        do ll=1,3
8393 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8394 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8395 cgrad        enddo
8396 cgrad      enddo
8397 c1112  continue
8398 cgrad      do m=i+2,j2
8399 cgrad        do ll=1,3
8400 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8401 cgrad        enddo
8402 cgrad      enddo
8403 cgrad      do m=k+2,l2
8404 cgrad        do ll=1,3
8405 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8406 cgrad        enddo
8407 cgrad      enddo
8408 cd      do iii=1,nres-3
8409 cd        write (2,*) iii,g_corr5_loc(iii)
8410 cd      enddo
8411       eello5=ekont*eel5
8412 cd      write (2,*) 'ekont',ekont
8413 cd      write (iout,*) 'eello5',ekont*eel5
8414       return
8415       end
8416 c--------------------------------------------------------------------------
8417       double precision function eello6(i,j,k,l,jj,kk)
8418       implicit real*8 (a-h,o-z)
8419       include 'DIMENSIONS'
8420       include 'DIMENSIONS.ZSCOPT'
8421       include 'COMMON.IOUNITS'
8422       include 'COMMON.CHAIN'
8423       include 'COMMON.DERIV'
8424       include 'COMMON.INTERACT'
8425       include 'COMMON.CONTACTS'
8426       include 'COMMON.TORSION'
8427       include 'COMMON.VAR'
8428       include 'COMMON.GEO'
8429       include 'COMMON.FFIELD'
8430       double precision ggg1(3),ggg2(3)
8431 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8432 cd        eello6=0.0d0
8433 cd        return
8434 cd      endif
8435 cd      write (iout,*)
8436 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8437 cd     &   ' and',k,l
8438       eello6_1=0.0d0
8439       eello6_2=0.0d0
8440       eello6_3=0.0d0
8441       eello6_4=0.0d0
8442       eello6_5=0.0d0
8443       eello6_6=0.0d0
8444 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8445 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8446       do iii=1,2
8447         do kkk=1,5
8448           do lll=1,3
8449             derx(lll,kkk,iii)=0.0d0
8450           enddo
8451         enddo
8452       enddo
8453 cd      eij=facont_hb(jj,i)
8454 cd      ekl=facont_hb(kk,k)
8455 cd      ekont=eij*ekl
8456 cd      eij=1.0d0
8457 cd      ekl=1.0d0
8458 cd      ekont=1.0d0
8459       if (l.eq.j+1) then
8460         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8461         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8462         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8463         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8464         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8465         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8466       else
8467         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8468         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8469         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8470         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8471         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8472           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8473         else
8474           eello6_5=0.0d0
8475         endif
8476         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8477       endif
8478 C If turn contributions are considered, they will be handled separately.
8479       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8480 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8481 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8482 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8483 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8484 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8485 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8486 cd      goto 1112
8487       if (calc_grad) then
8488       if (j.lt.nres-1) then
8489         j1=j+1
8490         j2=j-1
8491       else
8492         j1=j-1
8493         j2=j-2
8494       endif
8495       if (l.lt.nres-1) then
8496         l1=l+1
8497         l2=l-1
8498       else
8499         l1=l-1
8500         l2=l-2
8501       endif
8502       do ll=1,3
8503 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8504 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8505 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8506 cgrad        ghalf=0.5d0*ggg1(ll)
8507 cd        ghalf=0.0d0
8508         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8509         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8510         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8511         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8512         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8513         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8514         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8515         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8516 cgrad        ghalf=0.5d0*ggg2(ll)
8517 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8518 cd        ghalf=0.0d0
8519         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8520         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8521         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8522         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8523         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8524         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8525       enddo
8526       endif ! calc_grad
8527 cd      goto 1112
8528 cgrad      do m=i+1,j-1
8529 cgrad        do ll=1,3
8530 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8531 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8532 cgrad        enddo
8533 cgrad      enddo
8534 cgrad      do m=k+1,l-1
8535 cgrad        do ll=1,3
8536 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8537 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8538 cgrad        enddo
8539 cgrad      enddo
8540 cgrad1112  continue
8541 cgrad      do m=i+2,j2
8542 cgrad        do ll=1,3
8543 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8544 cgrad        enddo
8545 cgrad      enddo
8546 cgrad      do m=k+2,l2
8547 cgrad        do ll=1,3
8548 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8549 cgrad        enddo
8550 cgrad      enddo
8551 cd      do iii=1,nres-3
8552 cd        write (2,*) iii,g_corr6_loc(iii)
8553 cd      enddo
8554       eello6=ekont*eel6
8555 cd      write (2,*) 'ekont',ekont
8556 cd      write (iout,*) 'eello6',ekont*eel6
8557       return
8558       end
8559 c--------------------------------------------------------------------------
8560       double precision function eello6_graph1(i,j,k,l,imat,swap)
8561       implicit real*8 (a-h,o-z)
8562       include 'DIMENSIONS'
8563       include 'DIMENSIONS.ZSCOPT'
8564       include 'COMMON.IOUNITS'
8565       include 'COMMON.CHAIN'
8566       include 'COMMON.DERIV'
8567       include 'COMMON.INTERACT'
8568       include 'COMMON.CONTACTS'
8569       include 'COMMON.TORSION'
8570       include 'COMMON.VAR'
8571       include 'COMMON.GEO'
8572       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8573       logical swap
8574       logical lprn
8575       common /kutas/ lprn
8576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8577 C                                                                              C
8578 C      Parallel       Antiparallel                                             C
8579 C                                                                              C
8580 C          o             o                                                     C
8581 C         /l\           /j\                                                    C
8582 C        /   \         /   \                                                   C
8583 C       /| o |         | o |\                                                  C
8584 C     \ j|/k\|  /   \  |/k\|l /                                                C
8585 C      \ /   \ /     \ /   \ /                                                 C
8586 C       o     o       o     o                                                  C
8587 C       i             i                                                        C
8588 C                                                                              C
8589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8590       itk=itype2loc(itype(k))
8591       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8592       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8593       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8594       call transpose2(EUgC(1,1,k),auxmat(1,1))
8595       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8596       vv1(1)=pizda1(1,1)-pizda1(2,2)
8597       vv1(2)=pizda1(1,2)+pizda1(2,1)
8598       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8599       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8600       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8601       s5=scalar2(vv(1),Dtobr2(1,i))
8602 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8603       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8604       if (calc_grad) then
8605       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8606      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8607      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8608      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8609      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8610      & +scalar2(vv(1),Dtobr2der(1,i)))
8611       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8612       vv1(1)=pizda1(1,1)-pizda1(2,2)
8613       vv1(2)=pizda1(1,2)+pizda1(2,1)
8614       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8615       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8616       if (l.eq.j+1) then
8617         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8618      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8619      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8620      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8621      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8622       else
8623         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8624      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8625      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8626      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8627      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8628       endif
8629       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8630       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8631       vv1(1)=pizda1(1,1)-pizda1(2,2)
8632       vv1(2)=pizda1(1,2)+pizda1(2,1)
8633       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8634      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8635      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8636      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8637       do iii=1,2
8638         if (swap) then
8639           ind=3-iii
8640         else
8641           ind=iii
8642         endif
8643         do kkk=1,5
8644           do lll=1,3
8645             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8646             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8647             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8648             call transpose2(EUgC(1,1,k),auxmat(1,1))
8649             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8650      &        pizda1(1,1))
8651             vv1(1)=pizda1(1,1)-pizda1(2,2)
8652             vv1(2)=pizda1(1,2)+pizda1(2,1)
8653             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8654             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8655      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8656             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8657      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8658             s5=scalar2(vv(1),Dtobr2(1,i))
8659             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8660           enddo
8661         enddo
8662       enddo
8663       endif ! calc_grad
8664       return
8665       end
8666 c----------------------------------------------------------------------------
8667       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8668       implicit real*8 (a-h,o-z)
8669       include 'DIMENSIONS'
8670       include 'DIMENSIONS.ZSCOPT'
8671       include 'COMMON.IOUNITS'
8672       include 'COMMON.CHAIN'
8673       include 'COMMON.DERIV'
8674       include 'COMMON.INTERACT'
8675       include 'COMMON.CONTACTS'
8676       include 'COMMON.TORSION'
8677       include 'COMMON.VAR'
8678       include 'COMMON.GEO'
8679       logical swap
8680       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8681      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8682       logical lprn
8683       common /kutas/ lprn
8684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8685 C                                                                              C
8686 C      Parallel       Antiparallel                                             C
8687 C                                                                              C
8688 C          o             o                                                     C
8689 C     \   /l\           /j\   /                                                C
8690 C      \ /   \         /   \ /                                                 C
8691 C       o| o |         | o |o                                                  C
8692 C     \ j|/k\|      \  |/k\|l                                                  C
8693 C      \ /   \       \ /   \                                                   C
8694 C       o             o                                                        C
8695 C       i             i                                                        C
8696 C                                                                              C
8697 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8698 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8699 C AL 7/4/01 s1 would occur in the sixth-order moment,
8700 C           but not in a cluster cumulant
8701 #ifdef MOMENT
8702       s1=dip(1,jj,i)*dip(1,kk,k)
8703 #endif
8704       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8705       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8706       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8707       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8708       call transpose2(EUg(1,1,k),auxmat(1,1))
8709       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8710       vv(1)=pizda(1,1)-pizda(2,2)
8711       vv(2)=pizda(1,2)+pizda(2,1)
8712       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8713 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8714 #ifdef MOMENT
8715       eello6_graph2=-(s1+s2+s3+s4)
8716 #else
8717       eello6_graph2=-(s2+s3+s4)
8718 #endif
8719 c      eello6_graph2=-s3
8720 C Derivatives in gamma(i-1)
8721       if (calc_grad) then
8722       if (i.gt.1) then
8723 #ifdef MOMENT
8724         s1=dipderg(1,jj,i)*dip(1,kk,k)
8725 #endif
8726         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8727         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8728         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8729         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8730 #ifdef MOMENT
8731         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8732 #else
8733         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8734 #endif
8735 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8736       endif
8737 C Derivatives in gamma(k-1)
8738 #ifdef MOMENT
8739       s1=dip(1,jj,i)*dipderg(1,kk,k)
8740 #endif
8741       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8742       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8743       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8744       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8745       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8746       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8747       vv(1)=pizda(1,1)-pizda(2,2)
8748       vv(2)=pizda(1,2)+pizda(2,1)
8749       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8750 #ifdef MOMENT
8751       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8752 #else
8753       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8754 #endif
8755 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8756 C Derivatives in gamma(j-1) or gamma(l-1)
8757       if (j.gt.1) then
8758 #ifdef MOMENT
8759         s1=dipderg(3,jj,i)*dip(1,kk,k)
8760 #endif
8761         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8762         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8763         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8764         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8765         vv(1)=pizda(1,1)-pizda(2,2)
8766         vv(2)=pizda(1,2)+pizda(2,1)
8767         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8768 #ifdef MOMENT
8769         if (swap) then
8770           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8771         else
8772           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8773         endif
8774 #endif
8775         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8776 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8777       endif
8778 C Derivatives in gamma(l-1) or gamma(j-1)
8779       if (l.gt.1) then
8780 #ifdef MOMENT
8781         s1=dip(1,jj,i)*dipderg(3,kk,k)
8782 #endif
8783         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8784         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8785         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8786         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8787         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8788         vv(1)=pizda(1,1)-pizda(2,2)
8789         vv(2)=pizda(1,2)+pizda(2,1)
8790         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8791 #ifdef MOMENT
8792         if (swap) then
8793           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8794         else
8795           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8796         endif
8797 #endif
8798         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8799 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8800       endif
8801 C Cartesian derivatives.
8802       if (lprn) then
8803         write (2,*) 'In eello6_graph2'
8804         do iii=1,2
8805           write (2,*) 'iii=',iii
8806           do kkk=1,5
8807             write (2,*) 'kkk=',kkk
8808             do jjj=1,2
8809               write (2,'(3(2f10.5),5x)')
8810      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8811             enddo
8812           enddo
8813         enddo
8814       endif
8815       do iii=1,2
8816         do kkk=1,5
8817           do lll=1,3
8818 #ifdef MOMENT
8819             if (iii.eq.1) then
8820               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8821             else
8822               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8823             endif
8824 #endif
8825             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8826      &        auxvec(1))
8827             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8828             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8829      &        auxvec(1))
8830             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8831             call transpose2(EUg(1,1,k),auxmat(1,1))
8832             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8833      &        pizda(1,1))
8834             vv(1)=pizda(1,1)-pizda(2,2)
8835             vv(2)=pizda(1,2)+pizda(2,1)
8836             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8837 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8838 #ifdef MOMENT
8839             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8840 #else
8841             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8842 #endif
8843             if (swap) then
8844               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8845             else
8846               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8847             endif
8848           enddo
8849         enddo
8850       enddo
8851       endif ! calc_grad
8852       return
8853       end
8854 c----------------------------------------------------------------------------
8855       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8856       implicit real*8 (a-h,o-z)
8857       include 'DIMENSIONS'
8858       include 'DIMENSIONS.ZSCOPT'
8859       include 'COMMON.IOUNITS'
8860       include 'COMMON.CHAIN'
8861       include 'COMMON.DERIV'
8862       include 'COMMON.INTERACT'
8863       include 'COMMON.CONTACTS'
8864       include 'COMMON.TORSION'
8865       include 'COMMON.VAR'
8866       include 'COMMON.GEO'
8867       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8868       logical swap
8869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8870 C                                                                              C
8871 C      Parallel       Antiparallel                                             C
8872 C                                                                              C
8873 C          o             o                                                     C
8874 C         /l\   /   \   /j\                                                    C
8875 C        /   \ /     \ /   \                                                   C
8876 C       /| o |o       o| o |\                                                  C
8877 C       j|/k\|  /      |/k\|l /                                                C
8878 C        /   \ /       /   \ /                                                 C
8879 C       /     o       /     o                                                  C
8880 C       i             i                                                        C
8881 C                                                                              C
8882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8883 C
8884 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8885 C           energy moment and not to the cluster cumulant.
8886       iti=itortyp(itype(i))
8887       if (j.lt.nres-1) then
8888         itj1=itype2loc(itype(j+1))
8889       else
8890         itj1=nloctyp
8891       endif
8892       itk=itype2loc(itype(k))
8893       itk1=itype2loc(itype(k+1))
8894       if (l.lt.nres-1) then
8895         itl1=itype2loc(itype(l+1))
8896       else
8897         itl1=nloctyp
8898       endif
8899 #ifdef MOMENT
8900       s1=dip(4,jj,i)*dip(4,kk,k)
8901 #endif
8902       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8903       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8904       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8905       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8906       call transpose2(EE(1,1,k),auxmat(1,1))
8907       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8908       vv(1)=pizda(1,1)+pizda(2,2)
8909       vv(2)=pizda(2,1)-pizda(1,2)
8910       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8911 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8912 cd     & "sum",-(s2+s3+s4)
8913 #ifdef MOMENT
8914       eello6_graph3=-(s1+s2+s3+s4)
8915 #else
8916       eello6_graph3=-(s2+s3+s4)
8917 #endif
8918 c      eello6_graph3=-s4
8919 C Derivatives in gamma(k-1)
8920       if (calc_grad) then
8921       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8922       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8923       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8924       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8925 C Derivatives in gamma(l-1)
8926       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8927       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8928       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8929       vv(1)=pizda(1,1)+pizda(2,2)
8930       vv(2)=pizda(2,1)-pizda(1,2)
8931       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8932       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8933 C Cartesian derivatives.
8934       do iii=1,2
8935         do kkk=1,5
8936           do lll=1,3
8937 #ifdef MOMENT
8938             if (iii.eq.1) then
8939               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8940             else
8941               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8942             endif
8943 #endif
8944             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8945      &        auxvec(1))
8946             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8947             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8948      &        auxvec(1))
8949             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8950             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8951      &        pizda(1,1))
8952             vv(1)=pizda(1,1)+pizda(2,2)
8953             vv(2)=pizda(2,1)-pizda(1,2)
8954             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8955 #ifdef MOMENT
8956             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8957 #else
8958             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8959 #endif
8960             if (swap) then
8961               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8962             else
8963               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8964             endif
8965 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8966           enddo
8967         enddo
8968       enddo
8969       endif ! calc_grad
8970       return
8971       end
8972 c----------------------------------------------------------------------------
8973       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8974       implicit real*8 (a-h,o-z)
8975       include 'DIMENSIONS'
8976       include 'DIMENSIONS.ZSCOPT'
8977       include 'COMMON.IOUNITS'
8978       include 'COMMON.CHAIN'
8979       include 'COMMON.DERIV'
8980       include 'COMMON.INTERACT'
8981       include 'COMMON.CONTACTS'
8982       include 'COMMON.TORSION'
8983       include 'COMMON.VAR'
8984       include 'COMMON.GEO'
8985       include 'COMMON.FFIELD'
8986       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8987      & auxvec1(2),auxmat1(2,2)
8988       logical swap
8989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8990 C                                                                              C
8991 C      Parallel       Antiparallel                                             C
8992 C                                                                              C
8993 C          o             o                                                     C
8994 C         /l\   /   \   /j\                                                    C
8995 C        /   \ /     \ /   \                                                   C
8996 C       /| o |o       o| o |\                                                  C
8997 C     \ j|/k\|      \  |/k\|l                                                  C
8998 C      \ /   \       \ /   \                                                   C
8999 C       o     \       o     \                                                  C
9000 C       i             i                                                        C
9001 C                                                                              C
9002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9003 C
9004 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9005 C           energy moment and not to the cluster cumulant.
9006 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9007       iti=itype2loc(itype(i))
9008       itj=itype2loc(itype(j))
9009       if (j.lt.nres-1) then
9010         itj1=itype2loc(itype(j+1))
9011       else
9012         itj1=nloctyp
9013       endif
9014       itk=itype2loc(itype(k))
9015       if (k.lt.nres-1) then
9016         itk1=itype2loc(itype(k+1))
9017       else
9018         itk1=nloctyp
9019       endif
9020       itl=itype2loc(itype(l))
9021       if (l.lt.nres-1) then
9022         itl1=itype2loc(itype(l+1))
9023       else
9024         itl1=nloctyp
9025       endif
9026 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9027 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9028 cd     & ' itl',itl,' itl1',itl1
9029 #ifdef MOMENT
9030       if (imat.eq.1) then
9031         s1=dip(3,jj,i)*dip(3,kk,k)
9032       else
9033         s1=dip(2,jj,j)*dip(2,kk,l)
9034       endif
9035 #endif
9036       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9037       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9038       if (j.eq.l+1) then
9039         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9040         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9041       else
9042         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9043         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9044       endif
9045       call transpose2(EUg(1,1,k),auxmat(1,1))
9046       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9047       vv(1)=pizda(1,1)-pizda(2,2)
9048       vv(2)=pizda(2,1)+pizda(1,2)
9049       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9050 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9051 #ifdef MOMENT
9052       eello6_graph4=-(s1+s2+s3+s4)
9053 #else
9054       eello6_graph4=-(s2+s3+s4)
9055 #endif
9056 C Derivatives in gamma(i-1)
9057       if (calc_grad) then
9058       if (i.gt.1) then
9059 #ifdef MOMENT
9060         if (imat.eq.1) then
9061           s1=dipderg(2,jj,i)*dip(3,kk,k)
9062         else
9063           s1=dipderg(4,jj,j)*dip(2,kk,l)
9064         endif
9065 #endif
9066         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9067         if (j.eq.l+1) then
9068           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9069           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9070         else
9071           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9072           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9073         endif
9074         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9075         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9076 cd          write (2,*) 'turn6 derivatives'
9077 #ifdef MOMENT
9078           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9079 #else
9080           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9081 #endif
9082         else
9083 #ifdef MOMENT
9084           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9085 #else
9086           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9087 #endif
9088         endif
9089       endif
9090 C Derivatives in gamma(k-1)
9091 #ifdef MOMENT
9092       if (imat.eq.1) then
9093         s1=dip(3,jj,i)*dipderg(2,kk,k)
9094       else
9095         s1=dip(2,jj,j)*dipderg(4,kk,l)
9096       endif
9097 #endif
9098       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9099       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9100       if (j.eq.l+1) then
9101         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9102         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9103       else
9104         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9105         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9106       endif
9107       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9108       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9109       vv(1)=pizda(1,1)-pizda(2,2)
9110       vv(2)=pizda(2,1)+pizda(1,2)
9111       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9112       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9113 #ifdef MOMENT
9114         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9115 #else
9116         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9117 #endif
9118       else
9119 #ifdef MOMENT
9120         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9121 #else
9122         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9123 #endif
9124       endif
9125 C Derivatives in gamma(j-1) or gamma(l-1)
9126       if (l.eq.j+1 .and. l.gt.1) then
9127         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9128         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9129         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9130         vv(1)=pizda(1,1)-pizda(2,2)
9131         vv(2)=pizda(2,1)+pizda(1,2)
9132         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9133         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9134       else if (j.gt.1) then
9135         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9136         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9137         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9138         vv(1)=pizda(1,1)-pizda(2,2)
9139         vv(2)=pizda(2,1)+pizda(1,2)
9140         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9141         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9142           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9143         else
9144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9145         endif
9146       endif
9147 C Cartesian derivatives.
9148       do iii=1,2
9149         do kkk=1,5
9150           do lll=1,3
9151 #ifdef MOMENT
9152             if (iii.eq.1) then
9153               if (imat.eq.1) then
9154                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9155               else
9156                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9157               endif
9158             else
9159               if (imat.eq.1) then
9160                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9161               else
9162                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9163               endif
9164             endif
9165 #endif
9166             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9167      &        auxvec(1))
9168             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9169             if (j.eq.l+1) then
9170               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9171      &          b1(1,j+1),auxvec(1))
9172               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9173             else
9174               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9175      &          b1(1,l+1),auxvec(1))
9176               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9177             endif
9178             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9179      &        pizda(1,1))
9180             vv(1)=pizda(1,1)-pizda(2,2)
9181             vv(2)=pizda(2,1)+pizda(1,2)
9182             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9183             if (swap) then
9184               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9185 #ifdef MOMENT
9186                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9187      &             -(s1+s2+s4)
9188 #else
9189                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9190      &             -(s2+s4)
9191 #endif
9192                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9193               else
9194 #ifdef MOMENT
9195                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9196 #else
9197                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9198 #endif
9199                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9200               endif
9201             else
9202 #ifdef MOMENT
9203               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9204 #else
9205               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9206 #endif
9207               if (l.eq.j+1) then
9208                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9209               else
9210                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9211               endif
9212             endif
9213           enddo
9214         enddo
9215       enddo
9216       endif ! calc_grad
9217       return
9218       end
9219 c----------------------------------------------------------------------------
9220       double precision function eello_turn6(i,jj,kk)
9221       implicit real*8 (a-h,o-z)
9222       include 'DIMENSIONS'
9223       include 'DIMENSIONS.ZSCOPT'
9224       include 'COMMON.IOUNITS'
9225       include 'COMMON.CHAIN'
9226       include 'COMMON.DERIV'
9227       include 'COMMON.INTERACT'
9228       include 'COMMON.CONTACTS'
9229       include 'COMMON.TORSION'
9230       include 'COMMON.VAR'
9231       include 'COMMON.GEO'
9232       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9233      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9234      &  ggg1(3),ggg2(3)
9235       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9236      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9237 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9238 C           the respective energy moment and not to the cluster cumulant.
9239       s1=0.0d0
9240       s8=0.0d0
9241       s13=0.0d0
9242 c
9243       eello_turn6=0.0d0
9244       j=i+4
9245       k=i+1
9246       l=i+3
9247       iti=itype2loc(itype(i))
9248       itk=itype2loc(itype(k))
9249       itk1=itype2loc(itype(k+1))
9250       itl=itype2loc(itype(l))
9251       itj=itype2loc(itype(j))
9252 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9253 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9254 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9255 cd        eello6=0.0d0
9256 cd        return
9257 cd      endif
9258 cd      write (iout,*)
9259 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9260 cd     &   ' and',k,l
9261 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9262       do iii=1,2
9263         do kkk=1,5
9264           do lll=1,3
9265             derx_turn(lll,kkk,iii)=0.0d0
9266           enddo
9267         enddo
9268       enddo
9269 cd      eij=1.0d0
9270 cd      ekl=1.0d0
9271 cd      ekont=1.0d0
9272       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9273 cd      eello6_5=0.0d0
9274 cd      write (2,*) 'eello6_5',eello6_5
9275 #ifdef MOMENT
9276       call transpose2(AEA(1,1,1),auxmat(1,1))
9277       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9278       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9279       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9280 #endif
9281       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9282       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9283       s2 = scalar2(b1(1,k),vtemp1(1))
9284 #ifdef MOMENT
9285       call transpose2(AEA(1,1,2),atemp(1,1))
9286       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9287       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9288       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9289 #endif
9290       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9291       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9292       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9293 #ifdef MOMENT
9294       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9295       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9296       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9297       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9298       ss13 = scalar2(b1(1,k),vtemp4(1))
9299       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9300 #endif
9301 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9302 c      s1=0.0d0
9303 c      s2=0.0d0
9304 c      s8=0.0d0
9305 c      s12=0.0d0
9306 c      s13=0.0d0
9307       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9308 C Derivatives in gamma(i+2)
9309       if (calc_grad) then
9310       s1d =0.0d0
9311       s8d =0.0d0
9312 #ifdef MOMENT
9313       call transpose2(AEA(1,1,1),auxmatd(1,1))
9314       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9315       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9316       call transpose2(AEAderg(1,1,2),atempd(1,1))
9317       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9318       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9319 #endif
9320       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9321       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9322       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9323 c      s1d=0.0d0
9324 c      s2d=0.0d0
9325 c      s8d=0.0d0
9326 c      s12d=0.0d0
9327 c      s13d=0.0d0
9328       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9329 C Derivatives in gamma(i+3)
9330 #ifdef MOMENT
9331       call transpose2(AEA(1,1,1),auxmatd(1,1))
9332       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9333       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9334       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9335 #endif
9336       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9337       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9338       s2d = scalar2(b1(1,k),vtemp1d(1))
9339 #ifdef MOMENT
9340       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9341       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9342 #endif
9343       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9344 #ifdef MOMENT
9345       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9346       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9347       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9348 #endif
9349 c      s1d=0.0d0
9350 c      s2d=0.0d0
9351 c      s8d=0.0d0
9352 c      s12d=0.0d0
9353 c      s13d=0.0d0
9354 #ifdef MOMENT
9355       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9356      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9357 #else
9358       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9359      &               -0.5d0*ekont*(s2d+s12d)
9360 #endif
9361 C Derivatives in gamma(i+4)
9362       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9363       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9364       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9365 #ifdef MOMENT
9366       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9367       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9368       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9369 #endif
9370 c      s1d=0.0d0
9371 c      s2d=0.0d0
9372 c      s8d=0.0d0
9373 C      s12d=0.0d0
9374 c      s13d=0.0d0
9375 #ifdef MOMENT
9376       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9377 #else
9378       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9379 #endif
9380 C Derivatives in gamma(i+5)
9381 #ifdef MOMENT
9382       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9383       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9384       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9385 #endif
9386       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9387       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9388       s2d = scalar2(b1(1,k),vtemp1d(1))
9389 #ifdef MOMENT
9390       call transpose2(AEA(1,1,2),atempd(1,1))
9391       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9392       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9393 #endif
9394       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9395       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9396 #ifdef MOMENT
9397       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9398       ss13d = scalar2(b1(1,k),vtemp4d(1))
9399       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9400 #endif
9401 c      s1d=0.0d0
9402 c      s2d=0.0d0
9403 c      s8d=0.0d0
9404 c      s12d=0.0d0
9405 c      s13d=0.0d0
9406 #ifdef MOMENT
9407       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9408      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9409 #else
9410       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9411      &               -0.5d0*ekont*(s2d+s12d)
9412 #endif
9413 C Cartesian derivatives
9414       do iii=1,2
9415         do kkk=1,5
9416           do lll=1,3
9417 #ifdef MOMENT
9418             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9419             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9420             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9421 #endif
9422             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9423             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9424      &          vtemp1d(1))
9425             s2d = scalar2(b1(1,k),vtemp1d(1))
9426 #ifdef MOMENT
9427             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9428             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9429             s8d = -(atempd(1,1)+atempd(2,2))*
9430      &           scalar2(cc(1,1,l),vtemp2(1))
9431 #endif
9432             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9433      &           auxmatd(1,1))
9434             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9435             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9436 c      s1d=0.0d0
9437 c      s2d=0.0d0
9438 c      s8d=0.0d0
9439 c      s12d=0.0d0
9440 c      s13d=0.0d0
9441 #ifdef MOMENT
9442             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9443      &        - 0.5d0*(s1d+s2d)
9444 #else
9445             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9446      &        - 0.5d0*s2d
9447 #endif
9448 #ifdef MOMENT
9449             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9450      &        - 0.5d0*(s8d+s12d)
9451 #else
9452             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9453      &        - 0.5d0*s12d
9454 #endif
9455           enddo
9456         enddo
9457       enddo
9458 #ifdef MOMENT
9459       do kkk=1,5
9460         do lll=1,3
9461           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9462      &      achuj_tempd(1,1))
9463           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9464           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9465           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9466           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9467           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9468      &      vtemp4d(1))
9469           ss13d = scalar2(b1(1,k),vtemp4d(1))
9470           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9471           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9472         enddo
9473       enddo
9474 #endif
9475 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9476 cd     &  16*eel_turn6_num
9477 cd      goto 1112
9478       if (j.lt.nres-1) then
9479         j1=j+1
9480         j2=j-1
9481       else
9482         j1=j-1
9483         j2=j-2
9484       endif
9485       if (l.lt.nres-1) then
9486         l1=l+1
9487         l2=l-1
9488       else
9489         l1=l-1
9490         l2=l-2
9491       endif
9492       do ll=1,3
9493 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9494 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9495 cgrad        ghalf=0.5d0*ggg1(ll)
9496 cd        ghalf=0.0d0
9497         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9498         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9499         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9500      &    +ekont*derx_turn(ll,2,1)
9501         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9502         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9503      &    +ekont*derx_turn(ll,4,1)
9504         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9505         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9506         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9507 cgrad        ghalf=0.5d0*ggg2(ll)
9508 cd        ghalf=0.0d0
9509         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9510      &    +ekont*derx_turn(ll,2,2)
9511         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9512         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9513      &    +ekont*derx_turn(ll,4,2)
9514         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9515         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9516         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9517       enddo
9518 cd      goto 1112
9519 cgrad      do m=i+1,j-1
9520 cgrad        do ll=1,3
9521 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9522 cgrad        enddo
9523 cgrad      enddo
9524 cgrad      do m=k+1,l-1
9525 cgrad        do ll=1,3
9526 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9527 cgrad        enddo
9528 cgrad      enddo
9529 cgrad1112  continue
9530 cgrad      do m=i+2,j2
9531 cgrad        do ll=1,3
9532 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9533 cgrad        enddo
9534 cgrad      enddo
9535 cgrad      do m=k+2,l2
9536 cgrad        do ll=1,3
9537 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9538 cgrad        enddo
9539 cgrad      enddo
9540 cd      do iii=1,nres-3
9541 cd        write (2,*) iii,g_corr6_loc(iii)
9542 cd      enddo
9543       endif ! calc_grad
9544       eello_turn6=ekont*eel_turn6
9545 cd      write (2,*) 'ekont',ekont
9546 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9547       return
9548       end
9549
9550 crc-------------------------------------------------
9551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9552       subroutine Eliptransfer(eliptran)
9553       implicit real*8 (a-h,o-z)
9554       include 'DIMENSIONS'
9555       include 'DIMENSIONS.ZSCOPT'
9556       include 'COMMON.GEO'
9557       include 'COMMON.VAR'
9558       include 'COMMON.LOCAL'
9559       include 'COMMON.CHAIN'
9560       include 'COMMON.DERIV'
9561       include 'COMMON.INTERACT'
9562       include 'COMMON.IOUNITS'
9563       include 'COMMON.CALC'
9564       include 'COMMON.CONTROL'
9565       include 'COMMON.SPLITELE'
9566       include 'COMMON.SBRIDGE'
9567 C this is done by Adasko
9568 C      print *,"wchodze"
9569 C structure of box:
9570 C      water
9571 C--bordliptop-- buffore starts
9572 C--bufliptop--- here true lipid starts
9573 C      lipid
9574 C--buflipbot--- lipid ends buffore starts
9575 C--bordlipbot--buffore ends
9576       eliptran=0.0
9577       do i=1,nres
9578 C       do i=1,1
9579         if (itype(i).eq.ntyp1) cycle
9580
9581         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9582         if (positi.le.0) positi=positi+boxzsize
9583 C        print *,i
9584 C first for peptide groups
9585 c for each residue check if it is in lipid or lipid water border area
9586        if ((positi.gt.bordlipbot)
9587      &.and.(positi.lt.bordliptop)) then
9588 C the energy transfer exist
9589         if (positi.lt.buflipbot) then
9590 C what fraction I am in
9591          fracinbuf=1.0d0-
9592      &        ((positi-bordlipbot)/lipbufthick)
9593 C lipbufthick is thickenes of lipid buffore
9594          sslip=sscalelip(fracinbuf)
9595          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9596          eliptran=eliptran+sslip*pepliptran
9597          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9598          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9599 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9600         elseif (positi.gt.bufliptop) then
9601          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9602          sslip=sscalelip(fracinbuf)
9603          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9604          eliptran=eliptran+sslip*pepliptran
9605          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9606          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9607 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9608 C          print *, "doing sscalefor top part"
9609 C         print *,i,sslip,fracinbuf,ssgradlip
9610         else
9611          eliptran=eliptran+pepliptran
9612 C         print *,"I am in true lipid"
9613         endif
9614 C       else
9615 C       eliptran=elpitran+0.0 ! I am in water
9616        endif
9617        enddo
9618 C       print *, "nic nie bylo w lipidzie?"
9619 C now multiply all by the peptide group transfer factor
9620 C       eliptran=eliptran*pepliptran
9621 C now the same for side chains
9622 CV       do i=1,1
9623        do i=1,nres
9624         if (itype(i).eq.ntyp1) cycle
9625         positi=(mod(c(3,i+nres),boxzsize))
9626         if (positi.le.0) positi=positi+boxzsize
9627 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9628 c for each residue check if it is in lipid or lipid water border area
9629 C       respos=mod(c(3,i+nres),boxzsize)
9630 C       print *,positi,bordlipbot,buflipbot
9631        if ((positi.gt.bordlipbot)
9632      & .and.(positi.lt.bordliptop)) then
9633 C the energy transfer exist
9634         if (positi.lt.buflipbot) then
9635          fracinbuf=1.0d0-
9636      &     ((positi-bordlipbot)/lipbufthick)
9637 C lipbufthick is thickenes of lipid buffore
9638          sslip=sscalelip(fracinbuf)
9639          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9640          eliptran=eliptran+sslip*liptranene(itype(i))
9641          gliptranx(3,i)=gliptranx(3,i)
9642      &+ssgradlip*liptranene(itype(i))
9643          gliptranc(3,i-1)= gliptranc(3,i-1)
9644      &+ssgradlip*liptranene(itype(i))
9645 C         print *,"doing sccale for lower part"
9646         elseif (positi.gt.bufliptop) then
9647          fracinbuf=1.0d0-
9648      &((bordliptop-positi)/lipbufthick)
9649          sslip=sscalelip(fracinbuf)
9650          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9651          eliptran=eliptran+sslip*liptranene(itype(i))
9652          gliptranx(3,i)=gliptranx(3,i)
9653      &+ssgradlip*liptranene(itype(i))
9654          gliptranc(3,i-1)= gliptranc(3,i-1)
9655      &+ssgradlip*liptranene(itype(i))
9656 C          print *, "doing sscalefor top part",sslip,fracinbuf
9657         else
9658          eliptran=eliptran+liptranene(itype(i))
9659 C         print *,"I am in true lipid"
9660         endif
9661         endif ! if in lipid or buffor
9662 C       else
9663 C       eliptran=elpitran+0.0 ! I am in water
9664        enddo
9665        return
9666        end
9667
9668
9669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9670
9671       SUBROUTINE MATVEC2(A1,V1,V2)
9672       implicit real*8 (a-h,o-z)
9673       include 'DIMENSIONS'
9674       DIMENSION A1(2,2),V1(2),V2(2)
9675 c      DO 1 I=1,2
9676 c        VI=0.0
9677 c        DO 3 K=1,2
9678 c    3     VI=VI+A1(I,K)*V1(K)
9679 c        Vaux(I)=VI
9680 c    1 CONTINUE
9681
9682       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9683       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9684
9685       v2(1)=vaux1
9686       v2(2)=vaux2
9687       END
9688 C---------------------------------------
9689       SUBROUTINE MATMAT2(A1,A2,A3)
9690       implicit real*8 (a-h,o-z)
9691       include 'DIMENSIONS'
9692       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9693 c      DIMENSION AI3(2,2)
9694 c        DO  J=1,2
9695 c          A3IJ=0.0
9696 c          DO K=1,2
9697 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9698 c          enddo
9699 c          A3(I,J)=A3IJ
9700 c       enddo
9701 c      enddo
9702
9703       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9704       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9705       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9706       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9707
9708       A3(1,1)=AI3_11
9709       A3(2,1)=AI3_21
9710       A3(1,2)=AI3_12
9711       A3(2,2)=AI3_22
9712       END
9713
9714 c-------------------------------------------------------------------------
9715       double precision function scalar2(u,v)
9716       implicit none
9717       double precision u(2),v(2)
9718       double precision sc
9719       integer i
9720       scalar2=u(1)*v(1)+u(2)*v(2)
9721       return
9722       end
9723
9724 C-----------------------------------------------------------------------------
9725
9726       subroutine transpose2(a,at)
9727       implicit none
9728       double precision a(2,2),at(2,2)
9729       at(1,1)=a(1,1)
9730       at(1,2)=a(2,1)
9731       at(2,1)=a(1,2)
9732       at(2,2)=a(2,2)
9733       return
9734       end
9735 c--------------------------------------------------------------------------
9736       subroutine transpose(n,a,at)
9737       implicit none
9738       integer n,i,j
9739       double precision a(n,n),at(n,n)
9740       do i=1,n
9741         do j=1,n
9742           at(j,i)=a(i,j)
9743         enddo
9744       enddo
9745       return
9746       end
9747 C---------------------------------------------------------------------------
9748       subroutine prodmat3(a1,a2,kk,transp,prod)
9749       implicit none
9750       integer i,j
9751       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9752       logical transp
9753 crc      double precision auxmat(2,2),prod_(2,2)
9754
9755       if (transp) then
9756 crc        call transpose2(kk(1,1),auxmat(1,1))
9757 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9758 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9759
9760            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9761      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9762            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9763      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9764            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9765      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9766            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9767      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9768
9769       else
9770 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9771 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9772
9773            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9774      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9775            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9776      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9777            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9778      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9779            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9780      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9781
9782       endif
9783 c      call transpose2(a2(1,1),a2t(1,1))
9784
9785 crc      print *,transp
9786 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9787 crc      print *,((prod(i,j),i=1,2),j=1,2)
9788
9789       return
9790       end
9791 C-----------------------------------------------------------------------------
9792       double precision function scalar(u,v)
9793       implicit none
9794       double precision u(3),v(3)
9795       double precision sc
9796       integer i
9797       sc=0.0d0
9798       do i=1,3
9799         sc=sc+u(i)*v(i)
9800       enddo
9801       scalar=sc
9802       return
9803       end
9804 C-----------------------------------------------------------------------
9805       double precision function sscale(r)
9806       double precision r,gamm
9807       include "COMMON.SPLITELE"
9808       if(r.lt.r_cut-rlamb) then
9809         sscale=1.0d0
9810       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9811         gamm=(r-(r_cut-rlamb))/rlamb
9812         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9813       else
9814         sscale=0d0
9815       endif
9816       return
9817       end
9818 C-----------------------------------------------------------------------
9819 C-----------------------------------------------------------------------
9820       double precision function sscagrad(r)
9821       double precision r,gamm
9822       include "COMMON.SPLITELE"
9823       if(r.lt.r_cut-rlamb) then
9824         sscagrad=0.0d0
9825       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9826         gamm=(r-(r_cut-rlamb))/rlamb
9827         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9828       else
9829         sscagrad=0.0d0
9830       endif
9831       return
9832       end
9833 C-----------------------------------------------------------------------
9834 C-----------------------------------------------------------------------
9835       double precision function sscalelip(r)
9836       double precision r,gamm
9837       include "COMMON.SPLITELE"
9838 C      if(r.lt.r_cut-rlamb) then
9839 C        sscale=1.0d0
9840 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9841 C        gamm=(r-(r_cut-rlamb))/rlamb
9842         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9843 C      else
9844 C        sscale=0d0
9845 C      endif
9846       return
9847       end
9848 C-----------------------------------------------------------------------
9849       double precision function sscagradlip(r)
9850       double precision r,gamm
9851       include "COMMON.SPLITELE"
9852 C     if(r.lt.r_cut-rlamb) then
9853 C        sscagrad=0.0d0
9854 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9855 C        gamm=(r-(r_cut-rlamb))/rlamb
9856         sscagradlip=r*(6*r-6.0d0)
9857 C      else
9858 C        sscagrad=0.0d0
9859 C      endif
9860       return
9861       end
9862
9863 C-----------------------------------------------------------------------
9864        subroutine set_shield_fac
9865       implicit real*8 (a-h,o-z)
9866       include 'DIMENSIONS'
9867       include 'DIMENSIONS.ZSCOPT'
9868       include 'COMMON.CHAIN'
9869       include 'COMMON.DERIV'
9870       include 'COMMON.IOUNITS'
9871       include 'COMMON.SHIELD'
9872       include 'COMMON.INTERACT'
9873 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9874       double precision div77_81/0.974996043d0/,
9875      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9876
9877 C the vector between center of side_chain and peptide group
9878        double precision pep_side(3),long,side_calf(3),
9879      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9880      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9881 C the line belowe needs to be changed for FGPROC>1
9882       do i=1,nres-1
9883       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9884       ishield_list(i)=0
9885 Cif there two consequtive dummy atoms there is no peptide group between them
9886 C the line below has to be changed for FGPROC>1
9887       VolumeTotal=0.0
9888       do k=1,nres
9889        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9890        dist_pep_side=0.0
9891        dist_side_calf=0.0
9892        do j=1,3
9893 C first lets set vector conecting the ithe side-chain with kth side-chain
9894       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9895 C      pep_side(j)=2.0d0
9896 C and vector conecting the side-chain with its proper calfa
9897       side_calf(j)=c(j,k+nres)-c(j,k)
9898 C      side_calf(j)=2.0d0
9899       pept_group(j)=c(j,i)-c(j,i+1)
9900 C lets have their lenght
9901       dist_pep_side=pep_side(j)**2+dist_pep_side
9902       dist_side_calf=dist_side_calf+side_calf(j)**2
9903       dist_pept_group=dist_pept_group+pept_group(j)**2
9904       enddo
9905        dist_pep_side=dsqrt(dist_pep_side)
9906        dist_pept_group=dsqrt(dist_pept_group)
9907        dist_side_calf=dsqrt(dist_side_calf)
9908       do j=1,3
9909         pep_side_norm(j)=pep_side(j)/dist_pep_side
9910         side_calf_norm(j)=dist_side_calf
9911       enddo
9912 C now sscale fraction
9913        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9914 C       print *,buff_shield,"buff"
9915 C now sscale
9916         if (sh_frac_dist.le.0.0) cycle
9917 C If we reach here it means that this side chain reaches the shielding sphere
9918 C Lets add him to the list for gradient
9919         ishield_list(i)=ishield_list(i)+1
9920 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9921 C this list is essential otherwise problem would be O3
9922         shield_list(ishield_list(i),i)=k
9923 C Lets have the sscale value
9924         if (sh_frac_dist.gt.1.0) then
9925          scale_fac_dist=1.0d0
9926          do j=1,3
9927          sh_frac_dist_grad(j)=0.0d0
9928          enddo
9929         else
9930          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9931      &                   *(2.0*sh_frac_dist-3.0d0)
9932          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9933      &                  /dist_pep_side/buff_shield*0.5
9934 C remember for the final gradient multiply sh_frac_dist_grad(j)
9935 C for side_chain by factor -2 !
9936          do j=1,3
9937          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9938 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9939 C     &                    sh_frac_dist_grad(j)
9940          enddo
9941         endif
9942 C        if ((i.eq.3).and.(k.eq.2)) then
9943 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9944 C     & ,"TU"
9945 C        endif
9946
9947 C this is what is now we have the distance scaling now volume...
9948       short=short_r_sidechain(itype(k))
9949       long=long_r_sidechain(itype(k))
9950       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9951 C now costhet_grad
9952 C       costhet=0.0d0
9953        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9954 C       costhet_fac=0.0d0
9955        do j=1,3
9956          costhet_grad(j)=costhet_fac*pep_side(j)
9957        enddo
9958 C remember for the final gradient multiply costhet_grad(j)
9959 C for side_chain by factor -2 !
9960 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9961 C pep_side0pept_group is vector multiplication
9962       pep_side0pept_group=0.0
9963       do j=1,3
9964       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9965       enddo
9966       cosalfa=(pep_side0pept_group/
9967      & (dist_pep_side*dist_side_calf))
9968       fac_alfa_sin=1.0-cosalfa**2
9969       fac_alfa_sin=dsqrt(fac_alfa_sin)
9970       rkprim=fac_alfa_sin*(long-short)+short
9971 C now costhet_grad
9972        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9973        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9974
9975        do j=1,3
9976          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9977      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9978      &*(long-short)/fac_alfa_sin*cosalfa/
9979      &((dist_pep_side*dist_side_calf))*
9980      &((side_calf(j))-cosalfa*
9981      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9982
9983         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9984      &*(long-short)/fac_alfa_sin*cosalfa
9985      &/((dist_pep_side*dist_side_calf))*
9986      &(pep_side(j)-
9987      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9988        enddo
9989
9990       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9991      &                    /VSolvSphere_div
9992      &                    *wshield
9993 C now the gradient...
9994 C grad_shield is gradient of Calfa for peptide groups
9995 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9996 C     &               costhet,cosphi
9997 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9998 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9999       do j=1,3
10000       grad_shield(j,i)=grad_shield(j,i)
10001 C gradient po skalowaniu
10002      &                +(sh_frac_dist_grad(j)
10003 C  gradient po costhet
10004      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10005      &-scale_fac_dist*(cosphi_grad_long(j))
10006      &/(1.0-cosphi) )*div77_81
10007      &*VofOverlap
10008 C grad_shield_side is Cbeta sidechain gradient
10009       grad_shield_side(j,ishield_list(i),i)=
10010      &        (sh_frac_dist_grad(j)*(-2.0d0)
10011      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10012      &       +scale_fac_dist*(cosphi_grad_long(j))
10013      &        *2.0d0/(1.0-cosphi))
10014      &        *div77_81*VofOverlap
10015
10016        grad_shield_loc(j,ishield_list(i),i)=
10017      &   scale_fac_dist*cosphi_grad_loc(j)
10018      &        *2.0d0/(1.0-cosphi)
10019      &        *div77_81*VofOverlap
10020       enddo
10021       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10022       enddo
10023       fac_shield(i)=VolumeTotal*div77_81+div4_81
10024 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10025       enddo
10026       return
10027       end
10028 C--------------------------------------------------------------------------
10029 C first for shielding is setting of function of side-chains
10030        subroutine set_shield_fac2
10031       implicit real*8 (a-h,o-z)
10032       include 'DIMENSIONS'
10033       include 'DIMENSIONS.ZSCOPT'
10034       include 'COMMON.CHAIN'
10035       include 'COMMON.DERIV'
10036       include 'COMMON.IOUNITS'
10037       include 'COMMON.SHIELD'
10038       include 'COMMON.INTERACT'
10039 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10040       double precision div77_81/0.974996043d0/,
10041      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10042
10043 C the vector between center of side_chain and peptide group
10044        double precision pep_side(3),long,side_calf(3),
10045      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10046      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10047 C the line belowe needs to be changed for FGPROC>1
10048       do i=1,nres-1
10049       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10050       ishield_list(i)=0
10051 Cif there two consequtive dummy atoms there is no peptide group between them
10052 C the line below has to be changed for FGPROC>1
10053       VolumeTotal=0.0
10054       do k=1,nres
10055        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10056        dist_pep_side=0.0
10057        dist_side_calf=0.0
10058        do j=1,3
10059 C first lets set vector conecting the ithe side-chain with kth side-chain
10060       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10061 C      pep_side(j)=2.0d0
10062 C and vector conecting the side-chain with its proper calfa
10063       side_calf(j)=c(j,k+nres)-c(j,k)
10064 C      side_calf(j)=2.0d0
10065       pept_group(j)=c(j,i)-c(j,i+1)
10066 C lets have their lenght
10067       dist_pep_side=pep_side(j)**2+dist_pep_side
10068       dist_side_calf=dist_side_calf+side_calf(j)**2
10069       dist_pept_group=dist_pept_group+pept_group(j)**2
10070       enddo
10071        dist_pep_side=dsqrt(dist_pep_side)
10072        dist_pept_group=dsqrt(dist_pept_group)
10073        dist_side_calf=dsqrt(dist_side_calf)
10074       do j=1,3
10075         pep_side_norm(j)=pep_side(j)/dist_pep_side
10076         side_calf_norm(j)=dist_side_calf
10077       enddo
10078 C now sscale fraction
10079        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10080 C       print *,buff_shield,"buff"
10081 C now sscale
10082         if (sh_frac_dist.le.0.0) cycle
10083 C If we reach here it means that this side chain reaches the shielding sphere
10084 C Lets add him to the list for gradient
10085         ishield_list(i)=ishield_list(i)+1
10086 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10087 C this list is essential otherwise problem would be O3
10088         shield_list(ishield_list(i),i)=k
10089 C Lets have the sscale value
10090         if (sh_frac_dist.gt.1.0) then
10091          scale_fac_dist=1.0d0
10092          do j=1,3
10093          sh_frac_dist_grad(j)=0.0d0
10094          enddo
10095         else
10096          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10097      &                   *(2.0d0*sh_frac_dist-3.0d0)
10098          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10099      &                  /dist_pep_side/buff_shield*0.5d0
10100 C remember for the final gradient multiply sh_frac_dist_grad(j)
10101 C for side_chain by factor -2 !
10102          do j=1,3
10103          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10104 C         sh_frac_dist_grad(j)=0.0d0
10105 C         scale_fac_dist=1.0d0
10106 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10107 C     &                    sh_frac_dist_grad(j)
10108          enddo
10109         endif
10110 C this is what is now we have the distance scaling now volume...
10111       short=short_r_sidechain(itype(k))
10112       long=long_r_sidechain(itype(k))
10113       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10114       sinthet=short/dist_pep_side*costhet
10115 C now costhet_grad
10116 C       costhet=0.6d0
10117 C       sinthet=0.8
10118        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10119 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10120 C     &             -short/dist_pep_side**2/costhet)
10121 C       costhet_fac=0.0d0
10122        do j=1,3
10123          costhet_grad(j)=costhet_fac*pep_side(j)
10124        enddo
10125 C remember for the final gradient multiply costhet_grad(j)
10126 C for side_chain by factor -2 !
10127 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10128 C pep_side0pept_group is vector multiplication
10129       pep_side0pept_group=0.0d0
10130       do j=1,3
10131       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10132       enddo
10133       cosalfa=(pep_side0pept_group/
10134      & (dist_pep_side*dist_side_calf))
10135       fac_alfa_sin=1.0d0-cosalfa**2
10136       fac_alfa_sin=dsqrt(fac_alfa_sin)
10137       rkprim=fac_alfa_sin*(long-short)+short
10138 C      rkprim=short
10139
10140 C now costhet_grad
10141        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10142 C       cosphi=0.6
10143        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10144        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10145      &      dist_pep_side**2)
10146 C       sinphi=0.8
10147        do j=1,3
10148          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10149      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10150      &*(long-short)/fac_alfa_sin*cosalfa/
10151      &((dist_pep_side*dist_side_calf))*
10152      &((side_calf(j))-cosalfa*
10153      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10154 C       cosphi_grad_long(j)=0.0d0
10155         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10156      &*(long-short)/fac_alfa_sin*cosalfa
10157      &/((dist_pep_side*dist_side_calf))*
10158      &(pep_side(j)-
10159      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10160 C       cosphi_grad_loc(j)=0.0d0
10161        enddo
10162 C      print *,sinphi,sinthet
10163       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10164      &                    /VSolvSphere_div
10165 C     &                    *wshield
10166 C now the gradient...
10167       do j=1,3
10168       grad_shield(j,i)=grad_shield(j,i)
10169 C gradient po skalowaniu
10170      &                +(sh_frac_dist_grad(j)*VofOverlap
10171 C  gradient po costhet
10172      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10173      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10174      &       sinphi/sinthet*costhet*costhet_grad(j)
10175      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10176      & )*wshield
10177 C grad_shield_side is Cbeta sidechain gradient
10178       grad_shield_side(j,ishield_list(i),i)=
10179      &        (sh_frac_dist_grad(j)*(-2.0d0)
10180      &        *VofOverlap
10181      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10182      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10183      &       sinphi/sinthet*costhet*costhet_grad(j)
10184      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10185      &       )*wshield
10186
10187        grad_shield_loc(j,ishield_list(i),i)=
10188      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10189      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10190      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10191      &        ))
10192      &        *wshield
10193       enddo
10194       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10195       enddo
10196       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10197 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10198 c     &  " wshield",wshield
10199 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10200       enddo
10201       return
10202       end
10203 C--------------------------------------------------------------------------
10204       double precision function tschebyshev(m,n,x,y)
10205       implicit none
10206       include "DIMENSIONS"
10207       integer i,m,n
10208       double precision x(n),y,yy(0:maxvar),aux
10209 c Tschebyshev polynomial. Note that the first term is omitted
10210 c m=0: the constant term is included
10211 c m=1: the constant term is not included
10212       yy(0)=1.0d0
10213       yy(1)=y
10214       do i=2,n
10215         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10216       enddo
10217       aux=0.0d0
10218       do i=m,n
10219         aux=aux+x(i)*yy(i)
10220       enddo
10221       tschebyshev=aux
10222       return
10223       end
10224 C--------------------------------------------------------------------------
10225       double precision function gradtschebyshev(m,n,x,y)
10226       implicit none
10227       include "DIMENSIONS"
10228       integer i,m,n
10229       double precision x(n+1),y,yy(0:maxvar),aux
10230 c Tschebyshev polynomial. Note that the first term is omitted
10231 c m=0: the constant term is included
10232 c m=1: the constant term is not included
10233       yy(0)=1.0d0
10234       yy(1)=2.0d0*y
10235       do i=2,n
10236         yy(i)=2*y*yy(i-1)-yy(i-2)
10237       enddo
10238       aux=0.0d0
10239       do i=m,n
10240         aux=aux+x(i+1)*yy(i)*(i+1)
10241 C        print *, x(i+1),yy(i),i
10242       enddo
10243       gradtschebyshev=aux
10244       return
10245       end
10246 c----------------------------------------------------------------------------
10247       double precision function sscale2(r,r_cut,r0,rlamb)
10248       implicit none
10249       double precision r,gamm,r_cut,r0,rlamb,rr
10250       rr = dabs(r-r0)
10251 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10252 c      write (2,*) "rr",rr
10253       if(rr.lt.r_cut-rlamb) then
10254         sscale2=1.0d0
10255       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10256         gamm=(rr-(r_cut-rlamb))/rlamb
10257         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10258       else
10259         sscale2=0d0
10260       endif
10261       return
10262       end
10263 C-----------------------------------------------------------------------
10264       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10265       implicit none
10266       double precision r,gamm,r_cut,r0,rlamb,rr
10267       rr = dabs(r-r0)
10268       if(rr.lt.r_cut-rlamb) then
10269         sscalgrad2=0.0d0
10270       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10271         gamm=(rr-(r_cut-rlamb))/rlamb
10272         if (r.ge.r0) then
10273           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10274         else
10275           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10276         endif
10277       else
10278         sscalgrad2=0.0d0
10279       endif
10280       return
10281       end
10282 c----------------------------------------------------------------------------
10283       subroutine e_saxs(Esaxs_constr)
10284       implicit none
10285       include 'DIMENSIONS'
10286       include 'DIMENSIONS.ZSCOPT'
10287       include 'DIMENSIONS.FREE'
10288 #ifdef MPI
10289       include "mpif.h"
10290       include "COMMON.SETUP"
10291       integer IERR
10292 #endif
10293       include 'COMMON.SBRIDGE'
10294       include 'COMMON.CHAIN'
10295       include 'COMMON.GEO'
10296       include 'COMMON.LOCAL'
10297       include 'COMMON.INTERACT'
10298       include 'COMMON.VAR'
10299       include 'COMMON.IOUNITS'
10300       include 'COMMON.DERIV'
10301       include 'COMMON.CONTROL'
10302       include 'COMMON.NAMES'
10303       include 'COMMON.FFIELD'
10304       include 'COMMON.LANGEVIN'
10305 c
10306       double precision Esaxs_constr
10307       integer i,iint,j,k,l
10308       double precision PgradC(maxSAXS,3,maxres),
10309      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10310 #ifdef MPI
10311       double precision PgradC_(maxSAXS,3,maxres),
10312      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10313 #endif
10314       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10315      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10316      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10317      & auxX,auxX1,CACAgrad,Cnorm
10318       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10319       double precision dist
10320       external dist
10321 c  SAXS restraint penalty function
10322 #ifdef DEBUG
10323       write(iout,*) "------- SAXS penalty function start -------"
10324       write (iout,*) "nsaxs",nsaxs
10325       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10326       write (iout,*) "Psaxs"
10327       do i=1,nsaxs
10328         write (iout,'(i5,e15.5)') i, Psaxs(i)
10329       enddo
10330 #endif
10331       Esaxs_constr = 0.0d0
10332       do k=1,nsaxs
10333         Pcalc(k)=0.0d0
10334         do j=1,nres
10335           do l=1,3
10336             PgradC(k,l,j)=0.0d0
10337             PgradX(k,l,j)=0.0d0
10338           enddo
10339         enddo
10340       enddo
10341       do i=iatsc_s,iatsc_e
10342        if (itype(i).eq.ntyp1) cycle
10343        do iint=1,nint_gr(i)
10344          do j=istart(i,iint),iend(i,iint)
10345            if (itype(j).eq.ntyp1) cycle
10346 #ifdef ALLSAXS
10347            dijCACA=dist(i,j)
10348            dijCASC=dist(i,j+nres)
10349            dijSCCA=dist(i+nres,j)
10350            dijSCSC=dist(i+nres,j+nres)
10351            sigma2CACA=2.0d0/(pstok**2)
10352            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10353            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10354            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10355            do k=1,nsaxs
10356              dk = distsaxs(k)
10357              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10358              if (itype(j).ne.10) then
10359              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10360              else
10361              endif
10362              expCASC = 0.0d0
10363              if (itype(i).ne.10) then
10364              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10365              else
10366              expSCCA = 0.0d0
10367              endif
10368              if (itype(i).ne.10 .and. itype(j).ne.10) then
10369              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10370              else
10371              expSCSC = 0.0d0
10372              endif
10373              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10374 #ifdef DEBUG
10375              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10376 #endif
10377              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10378              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10379              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10380              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10381              do l=1,3
10382 c CA CA
10383                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10384                PgradC(k,l,i) = PgradC(k,l,i)-aux
10385                PgradC(k,l,j) = PgradC(k,l,j)+aux
10386 c CA SC
10387                if (itype(j).ne.10) then
10388                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10389                PgradC(k,l,i) = PgradC(k,l,i)-aux
10390                PgradC(k,l,j) = PgradC(k,l,j)+aux
10391                PgradX(k,l,j) = PgradX(k,l,j)+aux
10392                endif
10393 c SC CA
10394                if (itype(i).ne.10) then
10395                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10396                PgradX(k,l,i) = PgradX(k,l,i)-aux
10397                PgradC(k,l,i) = PgradC(k,l,i)-aux
10398                PgradC(k,l,j) = PgradC(k,l,j)+aux
10399                endif
10400 c SC SC
10401                if (itype(i).ne.10 .and. itype(j).ne.10) then
10402                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10403                PgradC(k,l,i) = PgradC(k,l,i)-aux
10404                PgradC(k,l,j) = PgradC(k,l,j)+aux
10405                PgradX(k,l,i) = PgradX(k,l,i)-aux
10406                PgradX(k,l,j) = PgradX(k,l,j)+aux
10407                endif
10408              enddo ! l
10409            enddo ! k
10410 #else
10411            dijCACA=dist(i,j)
10412            sigma2CACA=scal_rad**2*0.25d0/
10413      &        (restok(itype(j))**2+restok(itype(i))**2)
10414
10415            IF (saxs_cutoff.eq.0) THEN
10416            do k=1,nsaxs
10417              dk = distsaxs(k)
10418              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10419              Pcalc(k) = Pcalc(k)+expCACA
10420              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10421              do l=1,3
10422                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10423                PgradC(k,l,i) = PgradC(k,l,i)-aux
10424                PgradC(k,l,j) = PgradC(k,l,j)+aux
10425              enddo ! l
10426            enddo ! k
10427            ELSE
10428            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10429            do k=1,nsaxs
10430              dk = distsaxs(k)
10431 c             write (2,*) "ijk",i,j,k
10432              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10433              if (sss2.eq.0.0d0) cycle
10434              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10435              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10436              Pcalc(k) = Pcalc(k)+expCACA
10437 #ifdef DEBUG
10438              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10439 #endif
10440              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10441      &             ssgrad2*expCACA/sss2
10442              do l=1,3
10443 c CA CA
10444                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10445                PgradC(k,l,i) = PgradC(k,l,i)+aux
10446                PgradC(k,l,j) = PgradC(k,l,j)-aux
10447              enddo ! l
10448            enddo ! k
10449            ENDIF
10450 #endif
10451          enddo ! j
10452        enddo ! iint
10453       enddo ! i
10454 #ifdef MPI
10455       if (nfgtasks.gt.1) then
10456         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10457      &    MPI_SUM,king,FG_COMM,IERR)
10458         if (fg_rank.eq.king) then
10459           do k=1,nsaxs
10460             Pcalc(k) = Pcalc_(k)
10461           enddo
10462         endif
10463         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10464      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10465         if (fg_rank.eq.king) then
10466           do i=1,nres
10467             do l=1,3
10468               do k=1,nsaxs
10469                 PgradC(k,l,i) = PgradC_(k,l,i)
10470               enddo
10471             enddo
10472           enddo
10473         endif
10474 #ifdef ALLSAXS
10475         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10476      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10477         if (fg_rank.eq.king) then
10478           do i=1,nres
10479             do l=1,3
10480               do k=1,nsaxs
10481                 PgradX(k,l,i) = PgradX_(k,l,i)
10482               enddo
10483             enddo
10484           enddo
10485         endif
10486 #endif
10487       endif
10488 #endif
10489 #ifdef MPI
10490       if (fg_rank.eq.king) then
10491 #endif
10492       Cnorm = 0.0d0
10493       do k=1,nsaxs
10494         Cnorm = Cnorm + Pcalc(k)
10495       enddo
10496       Esaxs_constr = dlog(Cnorm)-wsaxs0
10497       do k=1,nsaxs
10498         if (Pcalc(k).gt.0.0d0)
10499      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10500 #ifdef DEBUG
10501         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10502 #endif
10503       enddo
10504 #ifdef DEBUG
10505       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10506 #endif
10507       do i=nnt,nct
10508         do l=1,3
10509           auxC=0.0d0
10510           auxC1=0.0d0
10511           auxX=0.0d0
10512           auxX1=0.d0
10513           do k=1,nsaxs
10514             if (Pcalc(k).gt.0)
10515      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10516             auxC1 = auxC1+PgradC(k,l,i)
10517 #ifdef ALLSAXS
10518             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10519             auxX1 = auxX1+PgradX(k,l,i)
10520 #endif
10521           enddo
10522           gsaxsC(l,i) = auxC - auxC1/Cnorm
10523 #ifdef ALLSAXS
10524           gsaxsX(l,i) = auxX - auxX1/Cnorm
10525 #endif
10526 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10527 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10528         enddo
10529       enddo
10530 #ifdef MPI
10531       endif
10532 #endif
10533       return
10534       end
10535 c----------------------------------------------------------------------------
10536       subroutine e_saxsC(Esaxs_constr)
10537       implicit none
10538       include 'DIMENSIONS'
10539       include 'DIMENSIONS.ZSCOPT'
10540       include 'DIMENSIONS.FREE'
10541 #ifdef MPI
10542       include "mpif.h"
10543       include "COMMON.SETUP"
10544       integer IERR
10545 #endif
10546       include 'COMMON.SBRIDGE'
10547       include 'COMMON.CHAIN'
10548       include 'COMMON.GEO'
10549       include 'COMMON.LOCAL'
10550       include 'COMMON.INTERACT'
10551       include 'COMMON.VAR'
10552       include 'COMMON.IOUNITS'
10553       include 'COMMON.DERIV'
10554       include 'COMMON.CONTROL'
10555       include 'COMMON.NAMES'
10556       include 'COMMON.FFIELD'
10557       include 'COMMON.LANGEVIN'
10558 c
10559       double precision Esaxs_constr
10560       integer i,iint,j,k,l
10561       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10562 #ifdef MPI
10563       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10564 #endif
10565       double precision dk,dijCASPH,dijSCSPH,
10566      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10567      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10568      & auxX,auxX1,Cnorm
10569 c  SAXS restraint penalty function
10570 #ifdef DEBUG
10571       write(iout,*) "------- SAXS penalty function start -------"
10572       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10573      & " isaxs_end",isaxs_end
10574       write (iout,*) "nnt",nnt," ntc",nct
10575       do i=nnt,nct
10576         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10577      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10578       enddo
10579       do i=nnt,nct
10580         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10581       enddo
10582 #endif
10583       Esaxs_constr = 0.0d0
10584       logPtot=0.0d0
10585       do j=isaxs_start,isaxs_end
10586         Pcalc=0.0d0
10587         do i=1,nres
10588           do l=1,3
10589             PgradC(l,i)=0.0d0
10590             PgradX(l,i)=0.0d0
10591           enddo
10592         enddo
10593         do i=nnt,nct
10594           dijCASPH=0.0d0
10595           dijSCSPH=0.0d0
10596           do l=1,3
10597             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10598           enddo
10599           if (itype(i).ne.10) then
10600           do l=1,3
10601             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10602           enddo
10603           endif
10604           sigma2CA=2.0d0/pstok**2
10605           sigma2SC=4.0d0/restok(itype(i))**2
10606           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10607           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10608           Pcalc = Pcalc+expCASPH+expSCSPH
10609 #ifdef DEBUG
10610           write(*,*) "processor i j Pcalc",
10611      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10612 #endif
10613           CASPHgrad = sigma2CA*expCASPH
10614           SCSPHgrad = sigma2SC*expSCSPH
10615           do l=1,3
10616             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10617             PgradX(l,i) = PgradX(l,i) + aux
10618             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10619           enddo ! l
10620         enddo ! i
10621         do i=nnt,nct
10622           do l=1,3
10623             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10624             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10625           enddo
10626         enddo
10627         logPtot = logPtot - dlog(Pcalc)
10628 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10629 c     &    " logPtot",logPtot
10630       enddo ! j
10631 #ifdef MPI
10632       if (nfgtasks.gt.1) then
10633 c        write (iout,*) "logPtot before reduction",logPtot
10634         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10635      &    MPI_SUM,king,FG_COMM,IERR)
10636         logPtot = logPtot_
10637 c        write (iout,*) "logPtot after reduction",logPtot
10638         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10639      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10640         if (fg_rank.eq.king) then
10641           do i=1,nres
10642             do l=1,3
10643               gsaxsC(l,i) = gsaxsC_(l,i)
10644             enddo
10645           enddo
10646         endif
10647         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10648      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10649         if (fg_rank.eq.king) then
10650           do i=1,nres
10651             do l=1,3
10652               gsaxsX(l,i) = gsaxsX_(l,i)
10653             enddo
10654           enddo
10655         endif
10656       endif
10657 #endif
10658       Esaxs_constr = logPtot
10659       return
10660       end
10661