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*fact(1),evdw1,wvdwpp,
 508      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 509      &  etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3),
 510      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),eel_loc,
 511      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 512      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 513      &  esccor,wsccor*fact(1),edihcnstr,
 514      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 515      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 516      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 517      &  edfabet,wdfa_beta,
 518      &  etot
 519    10 format (/'Virtual-chain energies:'//
 520      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 521      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 522      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 523      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 524      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 525      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 526      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 527      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 528      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 529      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 530      & ' (SS bridges & dist. cnstr.)'/
 531      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 532      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 533      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 534      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 535      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 536      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 537      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 538      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 539      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 540      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 541      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 542      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 543      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 544      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 545      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 546      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 547      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 548      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 549      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 550      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 551      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 552      & 'ETOT=  ',1pE16.6,' (total)')
 553
 554 #else
 555       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 556      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 557      &  etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3),
 558      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 559      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 560      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 561      &  esccor,wsccor*fact(1),edihcnstr,
 562      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 563      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 564      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 565      &  edfabet,wdfa_beta,
 566      &  etot
 567    10 format (/'Virtual-chain energies:'//
 568      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 569      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 570      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 571      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 572      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 573      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 574      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 575      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 576      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 577      & ' (SS bridges & dist. restr.)'/
 578      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 579      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 580      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 581      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 582      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 583      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 584      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 585      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 586      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 587      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 588      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 589      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 590      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 591      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 592      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 593      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 594      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 595      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 596      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 597      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 598      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 599      & 'ETOT=  ',1pE16.6,' (total)')
 600 #endif
 601       return
 602       end
 603 C-----------------------------------------------------------------------
 604       subroutine elj(evdw,evdw_t)
 605 C
 606 C This subroutine calculates the interaction energy of nonbonded side chains
 607 C assuming the LJ potential of interaction.
 608 C
 609       implicit real*8 (a-h,o-z)
 610       include 'DIMENSIONS'
 611       include 'DIMENSIONS.ZSCOPT'
 612       include "DIMENSIONS.COMPAR"
 613       parameter (accur=1.0d-10)
 614       include 'COMMON.GEO'
 615       include 'COMMON.VAR'
 616       include 'COMMON.LOCAL'
 617       include 'COMMON.CHAIN'
 618       include 'COMMON.DERIV'
 619       include 'COMMON.INTERACT'
 620       include 'COMMON.TORSION'
 621       include 'COMMON.ENEPS'
 622       include 'COMMON.SBRIDGE'
 623       include 'COMMON.NAMES'
 624       include 'COMMON.IOUNITS'
 625       include 'COMMON.CONTACTS'
 626       dimension gg(3)
 627       integer icant
 628       external icant
 629 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 630 c ROZNICA z cluster
 631       do i=1,210
 632         do j=1,2
 633           eneps_temp(j,i)=0.0d0
 634         enddo
 635       enddo
 636 cROZNICA
 637
 638       evdw=0.0D0
 639       evdw_t=0.0d0
 640       do i=iatsc_s,iatsc_e
 641         itypi=iabs(itype(i))
 642         if (itypi.eq.ntyp1) cycle
 643         itypi1=iabs(itype(i+1))
 644         xi=c(1,nres+i)
 645         yi=c(2,nres+i)
 646         zi=c(3,nres+i)
 647 C Change 12/1/95
 648         num_conti=0
 649 C
 650 C Calculate SC interaction energy.
 651 C
 652         do iint=1,nint_gr(i)
 653 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 654 cd   &                  'iend=',iend(i,iint)
 655           do j=istart(i,iint),iend(i,iint)
 656             itypj=iabs(itype(j))
 657             if (itypj.eq.ntyp1) cycle
 658             xj=c(1,nres+j)-xi
 659             yj=c(2,nres+j)-yi
 660             zj=c(3,nres+j)-zi
 661 C Change 12/1/95 to calculate four-body interactions
 662             rij=xj*xj+yj*yj+zj*zj
 663             rrij=1.0D0/rij
 664 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 665             eps0ij=eps(itypi,itypj)
 666             fac=rrij**expon2
 667             e1=fac*fac*aa
 668             e2=fac*bb
 669             evdwij=e1+e2
 670             ij=icant(itypi,itypj)
 671 c ROZNICA z cluster
 672             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 673             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 674 c
 675
 676 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 677 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 678 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 679 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 680 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 681 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 682             if (bb.gt.0.0d0) then
 683               evdw=evdw+evdwij
 684             else
 685               evdw_t=evdw_t+evdwij
 686             endif
 687             if (calc_grad) then
 688 C
 689 C Calculate the components of the gradient in DC and X
 690 C
 691             fac=-rrij*(e1+evdwij)
 692             gg(1)=xj*fac
 693             gg(2)=yj*fac
 694             gg(3)=zj*fac
 695             do k=1,3
 696               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 697               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 698             enddo
 699             do k=i,j-1
 700               do l=1,3
 701                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 702               enddo
 703             enddo
 704             endif
 705 C
 706 C 12/1/95, revised on 5/20/97
 707 C
 708 C Calculate the contact function. The ith column of the array JCONT will
 709 C contain the numbers of atoms that make contacts with the atom I (of numbers
 710 C greater than I). The arrays FACONT and GACONT will contain the values of
 711 C the contact function and its derivative.
 712 C
 713 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 714 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 715 C Uncomment next line, if the correlation interactions are contact function only
 716             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 717               rij=dsqrt(rij)
 718               sigij=sigma(itypi,itypj)
 719               r0ij=rs0(itypi,itypj)
 720 C
 721 C Check whether the SC's are not too far to make a contact.
 722 C
 723               rcut=1.5d0*r0ij
 724               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 725 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 726 C
 727               if (fcont.gt.0.0D0) then
 728 C If the SC-SC distance if close to sigma, apply spline.
 729 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 730 cAdam &             fcont1,fprimcont1)
 731 cAdam           fcont1=1.0d0-fcont1
 732 cAdam           if (fcont1.gt.0.0d0) then
 733 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 734 cAdam             fcont=fcont*fcont1
 735 cAdam           endif
 736 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 737 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 738 cga             do k=1,3
 739 cga               gg(k)=gg(k)*eps0ij
 740 cga             enddo
 741 cga             eps0ij=-evdwij*eps0ij
 742 C Uncomment for AL's type of SC correlation interactions.
 743 cadam           eps0ij=-evdwij
 744                 num_conti=num_conti+1
 745                 jcont(num_conti,i)=j
 746                 facont(num_conti,i)=fcont*eps0ij
 747                 fprimcont=eps0ij*fprimcont/rij
 748                 fcont=expon*fcont
 749 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 750 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 751 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 752 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 753                 gacont(1,num_conti,i)=-fprimcont*xj
 754                 gacont(2,num_conti,i)=-fprimcont*yj
 755                 gacont(3,num_conti,i)=-fprimcont*zj
 756 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 757 cd              write (iout,'(2i3,3f10.5)')
 758 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 759               endif
 760             endif
 761           enddo      ! j
 762         enddo        ! iint
 763 C Change 12/1/95
 764         num_cont(i)=num_conti
 765       enddo          ! i
 766       if (calc_grad) then
 767       do i=1,nct
 768         do j=1,3
 769           gvdwc(j,i)=expon*gvdwc(j,i)
 770           gvdwx(j,i)=expon*gvdwx(j,i)
 771         enddo
 772       enddo
 773       endif
 774 C******************************************************************************
 775 C
 776 C                              N O T E !!!
 777 C
 778 C To save time, the factor of EXPON has been extracted from ALL components
 779 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 780 C use!
 781 C
 782 C******************************************************************************
 783       return
 784       end
 785 C-----------------------------------------------------------------------------
 786       subroutine eljk(evdw,evdw_t)
 787 C
 788 C This subroutine calculates the interaction energy of nonbonded side chains
 789 C assuming the LJK potential of interaction.
 790 C
 791       implicit real*8 (a-h,o-z)
 792       include 'DIMENSIONS'
 793       include 'DIMENSIONS.ZSCOPT'
 794       include "DIMENSIONS.COMPAR"
 795       include 'COMMON.GEO'
 796       include 'COMMON.VAR'
 797       include 'COMMON.LOCAL'
 798       include 'COMMON.CHAIN'
 799       include 'COMMON.DERIV'
 800       include 'COMMON.INTERACT'
 801       include 'COMMON.ENEPS'
 802       include 'COMMON.IOUNITS'
 803       include 'COMMON.NAMES'
 804       dimension gg(3)
 805       logical scheck
 806       integer icant
 807       external icant
 808 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 809       do i=1,210
 810         do j=1,2
 811           eneps_temp(j,i)=0.0d0
 812         enddo
 813       enddo
 814       evdw=0.0D0
 815       evdw_t=0.0d0
 816       do i=iatsc_s,iatsc_e
 817         itypi=iabs(itype(i))
 818         if (itypi.eq.ntyp1) cycle
 819         itypi1=iabs(itype(i+1))
 820         xi=c(1,nres+i)
 821         yi=c(2,nres+i)
 822         zi=c(3,nres+i)
 823 C
 824 C Calculate SC interaction energy.
 825 C
 826         do iint=1,nint_gr(i)
 827           do j=istart(i,iint),iend(i,iint)
 828             itypj=iabs(itype(j))
 829             if (itypj.eq.ntyp1) cycle
 830             xj=c(1,nres+j)-xi
 831             yj=c(2,nres+j)-yi
 832             zj=c(3,nres+j)-zi
 833             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 834             fac_augm=rrij**expon
 835             e_augm=augm(itypi,itypj)*fac_augm
 836             r_inv_ij=dsqrt(rrij)
 837             rij=1.0D0/r_inv_ij
 838             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 839             fac=r_shift_inv**expon
 840             e1=fac*fac*aa
 841             e2=fac*bb
 842             evdwij=e_augm+e1+e2
 843             ij=icant(itypi,itypj)
 844             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 845      &        /dabs(eps(itypi,itypj))
 846             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 847 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 848 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 849 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 850 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 851 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 852 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 853 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 854             if (bb.gt.0.0d0) then
 855               evdw=evdw+evdwij
 856             else
 857               evdw_t=evdw_t+evdwij
 858             endif
 859             if (calc_grad) then
 860 C
 861 C Calculate the components of the gradient in DC and X
 862 C
 863             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 864             gg(1)=xj*fac
 865             gg(2)=yj*fac
 866             gg(3)=zj*fac
 867             do k=1,3
 868               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 869               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 870             enddo
 871             do k=i,j-1
 872               do l=1,3
 873                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 874               enddo
 875             enddo
 876             endif
 877           enddo      ! j
 878         enddo        ! iint
 879       enddo          ! i
 880       if (calc_grad) then
 881       do i=1,nct
 882         do j=1,3
 883           gvdwc(j,i)=expon*gvdwc(j,i)
 884           gvdwx(j,i)=expon*gvdwx(j,i)
 885         enddo
 886       enddo
 887       endif
 888       return
 889       end
 890 C-----------------------------------------------------------------------------
 891       subroutine ebp(evdw,evdw_t)
 892 C
 893 C This subroutine calculates the interaction energy of nonbonded side chains
 894 C assuming the Berne-Pechukas potential of interaction.
 895 C
 896       implicit real*8 (a-h,o-z)
 897       include 'DIMENSIONS'
 898       include 'DIMENSIONS.ZSCOPT'
 899       include "DIMENSIONS.COMPAR"
 900       include 'COMMON.GEO'
 901       include 'COMMON.VAR'
 902       include 'COMMON.LOCAL'
 903       include 'COMMON.CHAIN'
 904       include 'COMMON.DERIV'
 905       include 'COMMON.NAMES'
 906       include 'COMMON.INTERACT'
 907       include 'COMMON.ENEPS'
 908       include 'COMMON.IOUNITS'
 909       include 'COMMON.CALC'
 910       common /srutu/ icall
 911 c     double precision rrsave(maxdim)
 912       logical lprn
 913       integer icant
 914       external icant
 915       do i=1,210
 916         do j=1,2
 917           eneps_temp(j,i)=0.0d0
 918         enddo
 919       enddo
 920       evdw=0.0D0
 921       evdw_t=0.0d0
 922 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 923 c     if (icall.eq.0) then
 924 c       lprn=.true.
 925 c     else
 926         lprn=.false.
 927 c     endif
 928       ind=0
 929       do i=iatsc_s,iatsc_e
 930         itypi=iabs(itype(i))
 931         if (itypi.eq.ntyp1) cycle
 932         itypi1=iabs(itype(i+1))
 933         xi=c(1,nres+i)
 934         yi=c(2,nres+i)
 935         zi=c(3,nres+i)
 936         dxi=dc_norm(1,nres+i)
 937         dyi=dc_norm(2,nres+i)
 938         dzi=dc_norm(3,nres+i)
 939         dsci_inv=vbld_inv(i+nres)
 940 C
 941 C Calculate SC interaction energy.
 942 C
 943         do iint=1,nint_gr(i)
 944           do j=istart(i,iint),iend(i,iint)
 945             ind=ind+1
 946             itypj=iabs(itype(j))
 947             if (itypj.eq.ntyp1) cycle
 948             dscj_inv=vbld_inv(j+nres)
 949             chi1=chi(itypi,itypj)
 950             chi2=chi(itypj,itypi)
 951             chi12=chi1*chi2
 952             chip1=chip(itypi)
 953             chip2=chip(itypj)
 954             chip12=chip1*chip2
 955             alf1=alp(itypi)
 956             alf2=alp(itypj)
 957             alf12=0.5D0*(alf1+alf2)
 958 C For diagnostics only!!!
 959 c           chi1=0.0D0
 960 c           chi2=0.0D0
 961 c           chi12=0.0D0
 962 c           chip1=0.0D0
 963 c           chip2=0.0D0
 964 c           chip12=0.0D0
 965 c           alf1=0.0D0
 966 c           alf2=0.0D0
 967 c           alf12=0.0D0
 968             xj=c(1,nres+j)-xi
 969             yj=c(2,nres+j)-yi
 970             zj=c(3,nres+j)-zi
 971             dxj=dc_norm(1,nres+j)
 972             dyj=dc_norm(2,nres+j)
 973             dzj=dc_norm(3,nres+j)
 974             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 975 cd          if (icall.eq.0) then
 976 cd            rrsave(ind)=rrij
 977 cd          else
 978 cd            rrij=rrsave(ind)
 979 cd          endif
 980             rij=dsqrt(rrij)
 981 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 982             call sc_angular
 983 C Calculate whole angle-dependent part of epsilon and contributions
 984 C to its derivatives
 985             fac=(rrij*sigsq)**expon2
 986             e1=fac*fac*aa
 987             e2=fac*bb
 988             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 989             eps2der=evdwij*eps3rt
 990             eps3der=evdwij*eps2rt
 991             evdwij=evdwij*eps2rt*eps3rt
 992             ij=icant(itypi,itypj)
 993             aux=eps1*eps2rt**2*eps3rt**2
 994             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 995      &        /dabs(eps(itypi,itypj))
 996             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 997             if (bb.gt.0.0d0) then
 998               evdw=evdw+evdwij
 999             else
1000               evdw_t=evdw_t+evdwij
1001             endif
1002             if (calc_grad) then
1003             if (lprn) then
1004             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1005             epsi=bb**2/aa
1006             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1007      &        restyp(itypi),i,restyp(itypj),j,
1008      &        epsi,sigm,chi1,chi2,chip1,chip2,
1009      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1010      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1011      &        evdwij
1012             endif
1013 C Calculate gradient components.
1014             e1=e1*eps1*eps2rt**2*eps3rt**2
1015             fac=-expon*(e1+evdwij)
1016             sigder=fac/sigsq
1017             fac=rrij*fac
1018 C Calculate radial part of the gradient
1019             gg(1)=xj*fac
1020             gg(2)=yj*fac
1021             gg(3)=zj*fac
1022 C Calculate the angular part of the gradient and sum add the contributions
1023 C to the appropriate components of the Cartesian gradient.
1024             call sc_grad
1025             endif
1026           enddo      ! j
1027         enddo        ! iint
1028       enddo          ! i
1029 c     stop
1030       return
1031       end
1032 C-----------------------------------------------------------------------------
1033       subroutine egb(evdw,evdw_t)
1034 C
1035 C This subroutine calculates the interaction energy of nonbonded side chains
1036 C assuming the Gay-Berne potential of interaction.
1037 C
1038       implicit real*8 (a-h,o-z)
1039       include 'DIMENSIONS'
1040       include 'DIMENSIONS.ZSCOPT'
1041       include "DIMENSIONS.COMPAR"
1042       include 'COMMON.CONTROL'
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.NAMES'
1049       include 'COMMON.INTERACT'
1050       include 'COMMON.ENEPS'
1051       include 'COMMON.IOUNITS'
1052       include 'COMMON.CALC'
1053       include 'COMMON.SBRIDGE'
1054       logical lprn
1055       common /srutu/icall
1056       integer icant,xshift,yshift,zshift
1057       external icant
1058       do i=1,210
1059         do j=1,2
1060           eneps_temp(j,i)=0.0d0
1061         enddo
1062       enddo
1063 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1064       evdw=0.0D0
1065       evdw_t=0.0d0
1066       lprn=.false.
1067 c      if (icall.gt.0) lprn=.true.
1068       ind=0
1069       do i=iatsc_s,iatsc_e
1070         itypi=iabs(itype(i))
1071         if (itypi.eq.ntyp1) cycle
1072         itypi1=iabs(itype(i+1))
1073         xi=c(1,nres+i)
1074         yi=c(2,nres+i)
1075         zi=c(3,nres+i)
1076 C returning the ith atom to box
1077           xi=mod(xi,boxxsize)
1078           if (xi.lt.0) xi=xi+boxxsize
1079           yi=mod(yi,boxysize)
1080           if (yi.lt.0) yi=yi+boxysize
1081           zi=mod(zi,boxzsize)
1082           if (zi.lt.0) zi=zi+boxzsize
1083        if ((zi.gt.bordlipbot)
1084      &.and.(zi.lt.bordliptop)) then
1085 C the energy transfer exist
1086         if (zi.lt.buflipbot) then
1087 C what fraction I am in
1088          fracinbuf=1.0d0-
1089      &        ((zi-bordlipbot)/lipbufthick)
1090 C lipbufthick is thickenes of lipid buffore
1091          sslipi=sscalelip(fracinbuf)
1092          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1093         elseif (zi.gt.bufliptop) then
1094          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1095          sslipi=sscalelip(fracinbuf)
1096          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1097         else
1098          sslipi=1.0d0
1099          ssgradlipi=0.0
1100         endif
1101        else
1102          sslipi=0.0d0
1103          ssgradlipi=0.0
1104        endif
1105
1106         dxi=dc_norm(1,nres+i)
1107         dyi=dc_norm(2,nres+i)
1108         dzi=dc_norm(3,nres+i)
1109         dsci_inv=vbld_inv(i+nres)
1110 C
1111 C Calculate SC interaction energy.
1112 C
1113         do iint=1,nint_gr(i)
1114           do j=istart(i,iint),iend(i,iint)
1115             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1116               call dyn_ssbond_ene(i,j,evdwij)
1117               evdw=evdw+evdwij
1118 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1119 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1120 C triple bond artifac removal
1121              do k=j+1,iend(i,iint)
1122 C search over all next residues
1123               if (dyn_ss_mask(k)) then
1124 C check if they are cysteins
1125 C              write(iout,*) 'k=',k
1126               call triple_ssbond_ene(i,j,k,evdwij)
1127 C call the energy function that removes the artifical triple disulfide
1128 C bond the soubroutine is located in ssMD.F
1129               evdw=evdw+evdwij
1130 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1131 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1132               endif!dyn_ss_mask(k)
1133              enddo! k
1134             ELSE
1135             ind=ind+1
1136             itypj=iabs(itype(j))
1137             if (itypj.eq.ntyp1) cycle
1138             dscj_inv=vbld_inv(j+nres)
1139             sig0ij=sigma(itypi,itypj)
1140             chi1=chi(itypi,itypj)
1141             chi2=chi(itypj,itypi)
1142             chi12=chi1*chi2
1143             chip1=chip(itypi)
1144             chip2=chip(itypj)
1145             chip12=chip1*chip2
1146             alf1=alp(itypi)
1147             alf2=alp(itypj)
1148             alf12=0.5D0*(alf1+alf2)
1149 C For diagnostics only!!!
1150 c           chi1=0.0D0
1151 c           chi2=0.0D0
1152 c           chi12=0.0D0
1153 c           chip1=0.0D0
1154 c           chip2=0.0D0
1155 c           chip12=0.0D0
1156 c           alf1=0.0D0
1157 c           alf2=0.0D0
1158 c           alf12=0.0D0
1159             xj=c(1,nres+j)
1160             yj=c(2,nres+j)
1161             zj=c(3,nres+j)
1162 C returning jth atom to box
1163           xj=mod(xj,boxxsize)
1164           if (xj.lt.0) xj=xj+boxxsize
1165           yj=mod(yj,boxysize)
1166           if (yj.lt.0) yj=yj+boxysize
1167           zj=mod(zj,boxzsize)
1168           if (zj.lt.0) zj=zj+boxzsize
1169        if ((zj.gt.bordlipbot)
1170      &.and.(zj.lt.bordliptop)) then
1171 C the energy transfer exist
1172         if (zj.lt.buflipbot) then
1173 C what fraction I am in
1174          fracinbuf=1.0d0-
1175      &        ((zj-bordlipbot)/lipbufthick)
1176 C lipbufthick is thickenes of lipid buffore
1177          sslipj=sscalelip(fracinbuf)
1178          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1179         elseif (zj.gt.bufliptop) then
1180          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1181          sslipj=sscalelip(fracinbuf)
1182          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1183         else
1184          sslipj=1.0d0
1185          ssgradlipj=0.0
1186         endif
1187        else
1188          sslipj=0.0d0
1189          ssgradlipj=0.0
1190        endif
1191       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1192      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1193       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1194      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1195 C       if (aa.ne.aa_aq(itypi,itypj)) then
1196
1197 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1198 C     & bb_aq(itypi,itypj)-bb,
1199 C     & sslipi,sslipj
1200 C         endif
1201
1202 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1203 C checking the distance
1204       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1205       xj_safe=xj
1206       yj_safe=yj
1207       zj_safe=zj
1208       subchap=0
1209 C finding the closest
1210       do xshift=-1,1
1211       do yshift=-1,1
1212       do zshift=-1,1
1213           xj=xj_safe+xshift*boxxsize
1214           yj=yj_safe+yshift*boxysize
1215           zj=zj_safe+zshift*boxzsize
1216           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1217           if(dist_temp.lt.dist_init) then
1218             dist_init=dist_temp
1219             xj_temp=xj
1220             yj_temp=yj
1221             zj_temp=zj
1222             subchap=1
1223           endif
1224        enddo
1225        enddo
1226        enddo
1227        if (subchap.eq.1) then
1228           xj=xj_temp-xi
1229           yj=yj_temp-yi
1230           zj=zj_temp-zi
1231        else
1232           xj=xj_safe-xi
1233           yj=yj_safe-yi
1234           zj=zj_safe-zi
1235        endif
1236
1237             dxj=dc_norm(1,nres+j)
1238             dyj=dc_norm(2,nres+j)
1239             dzj=dc_norm(3,nres+j)
1240 c            write (iout,*) i,j,xj,yj,zj
1241             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1242             rij=dsqrt(rrij)
1243             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1244             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1245             if (sss.le.0.0) cycle
1246 C Calculate angle-dependent terms of energy and contributions to their
1247 C derivatives.
1248
1249             call sc_angular
1250             sigsq=1.0D0/sigsq
1251             sig=sig0ij*dsqrt(sigsq)
1252             rij_shift=1.0D0/rij-sig+sig0ij
1253 C I hate to put IF's in the loops, but here don't have another choice!!!!
1254             if (rij_shift.le.0.0D0) then
1255               evdw=1.0D20
1256               return
1257             endif
1258             sigder=-sig*sigsq
1259 c---------------------------------------------------------------
1260             rij_shift=1.0D0/rij_shift
1261             fac=rij_shift**expon
1262             e1=fac*fac*aa
1263             e2=fac*bb
1264             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1265             eps2der=evdwij*eps3rt
1266             eps3der=evdwij*eps2rt
1267             evdwij=evdwij*eps2rt*eps3rt
1268             if (bb.gt.0) then
1269               evdw=evdw+evdwij*sss
1270             else
1271               evdw_t=evdw_t+evdwij*sss
1272             endif
1273             ij=icant(itypi,itypj)
1274             aux=eps1*eps2rt**2*eps3rt**2
1275             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1276      &        /dabs(eps(itypi,itypj))
1277             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1278 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1279 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1280 c     &         aux*e2/eps(itypi,itypj)
1281 c            if (lprn) then
1282             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1283             epsi=bb**2/aa
1284 c#define DEBUG
1285 #ifdef DEBUG
1286             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1287      &        restyp(itypi),i,restyp(itypj),j,
1288      &        epsi,sigm,chi1,chi2,chip1,chip2,
1289      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1290      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1291      &        evdwij
1292              write (iout,*) "partial sum", evdw, evdw_t
1293 #endif
1294 c#undef DEBUG
1295 c            endif
1296             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1297      &                        'evdw',i,j,evdwij
1298             if (calc_grad) then
1299 C Calculate gradient components.
1300             e1=e1*eps1*eps2rt**2*eps3rt**2
1301             fac=-expon*(e1+evdwij)*rij_shift
1302             sigder=fac*sigder
1303             fac=rij*fac
1304             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1305 C Calculate the radial part of the gradient
1306             gg(1)=xj*fac
1307             gg(2)=yj*fac
1308             gg(3)=zj*fac
1309 C Calculate angular part of the gradient.
1310             call sc_grad
1311             endif
1312 C            write(iout,*)  "partial sum", evdw, evdw_t
1313             ENDIF    ! dyn_ss
1314           enddo      ! j
1315         enddo        ! iint
1316       enddo          ! i
1317       return
1318       end
1319 C-----------------------------------------------------------------------------
1320       subroutine egbv(evdw,evdw_t)
1321 C
1322 C This subroutine calculates the interaction energy of nonbonded side chains
1323 C assuming the Gay-Berne-Vorobjev potential of interaction.
1324 C
1325       implicit real*8 (a-h,o-z)
1326       include 'DIMENSIONS'
1327       include 'DIMENSIONS.ZSCOPT'
1328       include "DIMENSIONS.COMPAR"
1329       include 'COMMON.GEO'
1330       include 'COMMON.VAR'
1331       include 'COMMON.LOCAL'
1332       include 'COMMON.CHAIN'
1333       include 'COMMON.DERIV'
1334       include 'COMMON.NAMES'
1335       include 'COMMON.INTERACT'
1336       include 'COMMON.ENEPS'
1337       include 'COMMON.IOUNITS'
1338       include 'COMMON.CALC'
1339       common /srutu/ icall
1340       logical lprn
1341       integer icant
1342       external icant
1343       do i=1,210
1344         do j=1,2
1345           eneps_temp(j,i)=0.0d0
1346         enddo
1347       enddo
1348       evdw=0.0D0
1349       evdw_t=0.0d0
1350 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1351       evdw=0.0D0
1352       lprn=.false.
1353 c      if (icall.gt.0) lprn=.true.
1354       ind=0
1355       do i=iatsc_s,iatsc_e
1356         itypi=iabs(itype(i))
1357         if (itypi.eq.ntyp1) cycle
1358         itypi1=iabs(itype(i+1))
1359         xi=c(1,nres+i)
1360         yi=c(2,nres+i)
1361         zi=c(3,nres+i)
1362         dxi=dc_norm(1,nres+i)
1363         dyi=dc_norm(2,nres+i)
1364         dzi=dc_norm(3,nres+i)
1365         dsci_inv=vbld_inv(i+nres)
1366 C
1367 C Calculate SC interaction energy.
1368 C
1369         do iint=1,nint_gr(i)
1370           do j=istart(i,iint),iend(i,iint)
1371             ind=ind+1
1372             itypj=iabs(itype(j))
1373             if (itypj.eq.ntyp1) cycle
1374             dscj_inv=vbld_inv(j+nres)
1375             sig0ij=sigma(itypi,itypj)
1376             r0ij=r0(itypi,itypj)
1377             chi1=chi(itypi,itypj)
1378             chi2=chi(itypj,itypi)
1379             chi12=chi1*chi2
1380             chip1=chip(itypi)
1381             chip2=chip(itypj)
1382             chip12=chip1*chip2
1383             alf1=alp(itypi)
1384             alf2=alp(itypj)
1385             alf12=0.5D0*(alf1+alf2)
1386 C For diagnostics only!!!
1387 c           chi1=0.0D0
1388 c           chi2=0.0D0
1389 c           chi12=0.0D0
1390 c           chip1=0.0D0
1391 c           chip2=0.0D0
1392 c           chip12=0.0D0
1393 c           alf1=0.0D0
1394 c           alf2=0.0D0
1395 c           alf12=0.0D0
1396             xj=c(1,nres+j)-xi
1397             yj=c(2,nres+j)-yi
1398             zj=c(3,nres+j)-zi
1399             dxj=dc_norm(1,nres+j)
1400             dyj=dc_norm(2,nres+j)
1401             dzj=dc_norm(3,nres+j)
1402             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1403             rij=dsqrt(rrij)
1404 C Calculate angle-dependent terms of energy and contributions to their
1405 C derivatives.
1406             call sc_angular
1407             sigsq=1.0D0/sigsq
1408             sig=sig0ij*dsqrt(sigsq)
1409             rij_shift=1.0D0/rij-sig+r0ij
1410 C I hate to put IF's in the loops, but here don't have another choice!!!!
1411             if (rij_shift.le.0.0D0) then
1412               evdw=1.0D20
1413               return
1414             endif
1415             sigder=-sig*sigsq
1416 c---------------------------------------------------------------
1417             rij_shift=1.0D0/rij_shift
1418             fac=rij_shift**expon
1419             e1=fac*fac*aa
1420             e2=fac*bb
1421             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1422             eps2der=evdwij*eps3rt
1423             eps3der=evdwij*eps2rt
1424             fac_augm=rrij**expon
1425             e_augm=augm(itypi,itypj)*fac_augm
1426             evdwij=evdwij*eps2rt*eps3rt
1427             if (bb.gt.0.0d0) then
1428               evdw=evdw+evdwij+e_augm
1429             else
1430               evdw_t=evdw_t+evdwij+e_augm
1431             endif
1432             ij=icant(itypi,itypj)
1433             aux=eps1*eps2rt**2*eps3rt**2
1434             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1435      &        /dabs(eps(itypi,itypj))
1436             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1437 c            eneps_temp(ij)=eneps_temp(ij)
1438 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1439 c            if (lprn) then
1440 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1441 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1442 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1443 c     &        restyp(itypi),i,restyp(itypj),j,
1444 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1445 c     &        chi1,chi2,chip1,chip2,
1446 c     &        eps1,eps2rt**2,eps3rt**2,
1447 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1448 c     &        evdwij+e_augm
1449 c            endif
1450             if (calc_grad) then
1451 C Calculate gradient components.
1452             e1=e1*eps1*eps2rt**2*eps3rt**2
1453             fac=-expon*(e1+evdwij)*rij_shift
1454             sigder=fac*sigder
1455             fac=rij*fac-2*expon*rrij*e_augm
1456 C Calculate the radial part of the gradient
1457             gg(1)=xj*fac
1458             gg(2)=yj*fac
1459             gg(3)=zj*fac
1460 C Calculate angular part of the gradient.
1461             call sc_grad
1462             endif
1463           enddo      ! j
1464         enddo        ! iint
1465       enddo          ! i
1466       return
1467       end
1468 C-----------------------------------------------------------------------------
1469       subroutine sc_angular
1470 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1471 C om12. Called by ebp, egb, and egbv.
1472       implicit none
1473       include 'COMMON.CALC'
1474       erij(1)=xj*rij
1475       erij(2)=yj*rij
1476       erij(3)=zj*rij
1477       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1478       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1479       om12=dxi*dxj+dyi*dyj+dzi*dzj
1480       chiom12=chi12*om12
1481 C Calculate eps1(om12) and its derivative in om12
1482       faceps1=1.0D0-om12*chiom12
1483       faceps1_inv=1.0D0/faceps1
1484       eps1=dsqrt(faceps1_inv)
1485 C Following variable is eps1*deps1/dom12
1486       eps1_om12=faceps1_inv*chiom12
1487 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1488 C and om12.
1489       om1om2=om1*om2
1490       chiom1=chi1*om1
1491       chiom2=chi2*om2
1492       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1493       sigsq=1.0D0-facsig*faceps1_inv
1494       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1495       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1496       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1497 C Calculate eps2 and its derivatives in om1, om2, and om12.
1498       chipom1=chip1*om1
1499       chipom2=chip2*om2
1500       chipom12=chip12*om12
1501       facp=1.0D0-om12*chipom12
1502       facp_inv=1.0D0/facp
1503       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1504 C Following variable is the square root of eps2
1505       eps2rt=1.0D0-facp1*facp_inv
1506 C Following three variables are the derivatives of the square root of eps
1507 C in om1, om2, and om12.
1508       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1509       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1510       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1511 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1512       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1513 C Calculate whole angle-dependent part of epsilon and contributions
1514 C to its derivatives
1515       return
1516       end
1517 C----------------------------------------------------------------------------
1518       subroutine sc_grad
1519       implicit real*8 (a-h,o-z)
1520       include 'DIMENSIONS'
1521       include 'DIMENSIONS.ZSCOPT'
1522       include 'COMMON.CHAIN'
1523       include 'COMMON.DERIV'
1524       include 'COMMON.CALC'
1525       double precision dcosom1(3),dcosom2(3)
1526       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1527       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1528       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1529      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1530       do k=1,3
1531         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1532         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1533       enddo
1534       do k=1,3
1535         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1536       enddo
1537       do k=1,3
1538         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1539      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1540      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1541         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1542      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1543      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1544       enddo
1545 C
1546 C Calculate the components of the gradient in DC and X
1547 C
1548       do k=i,j-1
1549         do l=1,3
1550           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1551         enddo
1552       enddo
1553       return
1554       end
1555 c------------------------------------------------------------------------------
1556       subroutine vec_and_deriv
1557       implicit real*8 (a-h,o-z)
1558       include 'DIMENSIONS'
1559       include 'DIMENSIONS.ZSCOPT'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.GEO'
1562       include 'COMMON.VAR'
1563       include 'COMMON.LOCAL'
1564       include 'COMMON.CHAIN'
1565       include 'COMMON.VECTORS'
1566       include 'COMMON.DERIV'
1567       include 'COMMON.INTERACT'
1568       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1569 C Compute the local reference systems. For reference system (i), the
1570 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1571 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1572       do i=1,nres-1
1573 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1574           if (i.eq.nres-1) then
1575 C Case of the last full residue
1576 C Compute the Z-axis
1577             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1578             costh=dcos(pi-theta(nres))
1579             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1580 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1581 c     &         " uz",uz(:,i)
1582             do k=1,3
1583               uz(k,i)=fac*uz(k,i)
1584             enddo
1585             if (calc_grad) then
1586 C Compute the derivatives of uz
1587             uzder(1,1,1)= 0.0d0
1588             uzder(2,1,1)=-dc_norm(3,i-1)
1589             uzder(3,1,1)= dc_norm(2,i-1)
1590             uzder(1,2,1)= dc_norm(3,i-1)
1591             uzder(2,2,1)= 0.0d0
1592             uzder(3,2,1)=-dc_norm(1,i-1)
1593             uzder(1,3,1)=-dc_norm(2,i-1)
1594             uzder(2,3,1)= dc_norm(1,i-1)
1595             uzder(3,3,1)= 0.0d0
1596             uzder(1,1,2)= 0.0d0
1597             uzder(2,1,2)= dc_norm(3,i)
1598             uzder(3,1,2)=-dc_norm(2,i)
1599             uzder(1,2,2)=-dc_norm(3,i)
1600             uzder(2,2,2)= 0.0d0
1601             uzder(3,2,2)= dc_norm(1,i)
1602             uzder(1,3,2)= dc_norm(2,i)
1603             uzder(2,3,2)=-dc_norm(1,i)
1604             uzder(3,3,2)= 0.0d0
1605             endif ! calc_grad
1606 C Compute the Y-axis
1607             facy=fac
1608             do k=1,3
1609               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1610             enddo
1611             if (calc_grad) then
1612 C Compute the derivatives of uy
1613             do j=1,3
1614               do k=1,3
1615                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1616      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1617                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1618               enddo
1619               uyder(j,j,1)=uyder(j,j,1)-costh
1620               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1621             enddo
1622             do j=1,2
1623               do k=1,3
1624                 do l=1,3
1625                   uygrad(l,k,j,i)=uyder(l,k,j)
1626                   uzgrad(l,k,j,i)=uzder(l,k,j)
1627                 enddo
1628               enddo
1629             enddo
1630             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1631             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1632             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1633             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1634             endif
1635           else
1636 C Other residues
1637 C Compute the Z-axis
1638             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1639             costh=dcos(pi-theta(i+2))
1640             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1641             do k=1,3
1642               uz(k,i)=fac*uz(k,i)
1643             enddo
1644             if (calc_grad) then
1645 C Compute the derivatives of uz
1646             uzder(1,1,1)= 0.0d0
1647             uzder(2,1,1)=-dc_norm(3,i+1)
1648             uzder(3,1,1)= dc_norm(2,i+1)
1649             uzder(1,2,1)= dc_norm(3,i+1)
1650             uzder(2,2,1)= 0.0d0
1651             uzder(3,2,1)=-dc_norm(1,i+1)
1652             uzder(1,3,1)=-dc_norm(2,i+1)
1653             uzder(2,3,1)= dc_norm(1,i+1)
1654             uzder(3,3,1)= 0.0d0
1655             uzder(1,1,2)= 0.0d0
1656             uzder(2,1,2)= dc_norm(3,i)
1657             uzder(3,1,2)=-dc_norm(2,i)
1658             uzder(1,2,2)=-dc_norm(3,i)
1659             uzder(2,2,2)= 0.0d0
1660             uzder(3,2,2)= dc_norm(1,i)
1661             uzder(1,3,2)= dc_norm(2,i)
1662             uzder(2,3,2)=-dc_norm(1,i)
1663             uzder(3,3,2)= 0.0d0
1664             endif
1665 C Compute the Y-axis
1666             facy=fac
1667             do k=1,3
1668               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1669             enddo
1670             if (calc_grad) then
1671 C Compute the derivatives of uy
1672             do j=1,3
1673               do k=1,3
1674                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1675      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1676                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1677               enddo
1678               uyder(j,j,1)=uyder(j,j,1)-costh
1679               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1680             enddo
1681             do j=1,2
1682               do k=1,3
1683                 do l=1,3
1684                   uygrad(l,k,j,i)=uyder(l,k,j)
1685                   uzgrad(l,k,j,i)=uzder(l,k,j)
1686                 enddo
1687               enddo
1688             enddo
1689             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1690             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1691             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1692             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1693           endif
1694           endif
1695       enddo
1696       if (calc_grad) then
1697       do i=1,nres-1
1698         vbld_inv_temp(1)=vbld_inv(i+1)
1699         if (i.lt.nres-1) then
1700           vbld_inv_temp(2)=vbld_inv(i+2)
1701         else
1702           vbld_inv_temp(2)=vbld_inv(i)
1703         endif
1704         do j=1,2
1705           do k=1,3
1706             do l=1,3
1707               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1708               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1709             enddo
1710           enddo
1711         enddo
1712       enddo
1713       endif
1714       return
1715       end
1716 C--------------------------------------------------------------------------
1717       subroutine set_matrices
1718       implicit real*8 (a-h,o-z)
1719       include 'DIMENSIONS'
1720 #ifdef MPI
1721       include "mpif.h"
1722       integer IERR
1723       integer status(MPI_STATUS_SIZE)
1724 #endif
1725       include 'DIMENSIONS.ZSCOPT'
1726       include 'COMMON.IOUNITS'
1727       include 'COMMON.GEO'
1728       include 'COMMON.VAR'
1729       include 'COMMON.LOCAL'
1730       include 'COMMON.CHAIN'
1731       include 'COMMON.DERIV'
1732       include 'COMMON.INTERACT'
1733       include 'COMMON.CONTACTS'
1734       include 'COMMON.TORSION'
1735       include 'COMMON.VECTORS'
1736       include 'COMMON.FFIELD'
1737       double precision auxvec(2),auxmat(2,2)
1738 C
1739 C Compute the virtual-bond-torsional-angle dependent quantities needed
1740 C to calculate the el-loc multibody terms of various order.
1741 C
1742 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1743       do i=3,nres+1
1744         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1745           iti = itype2loc(itype(i-2))
1746         else
1747           iti=nloctyp
1748         endif
1749 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1750         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1751           iti1 = itype2loc(itype(i-1))
1752         else
1753           iti1=nloctyp
1754         endif
1755 #ifdef NEWCORR
1756         cost1=dcos(theta(i-1))
1757         sint1=dsin(theta(i-1))
1758         sint1sq=sint1*sint1
1759         sint1cub=sint1sq*sint1
1760         sint1cost1=2*sint1*cost1
1761 #ifdef DEBUG
1762         write (iout,*) "bnew1",i,iti
1763         write (iout,*) (bnew1(k,1,iti),k=1,3)
1764         write (iout,*) (bnew1(k,2,iti),k=1,3)
1765         write (iout,*) "bnew2",i,iti
1766         write (iout,*) (bnew2(k,1,iti),k=1,3)
1767         write (iout,*) (bnew2(k,2,iti),k=1,3)
1768 #endif
1769         do k=1,2
1770           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1771           b1(k,i-2)=sint1*b1k
1772           gtb1(k,i-2)=cost1*b1k-sint1sq*
1773      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1774           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1775           b2(k,i-2)=sint1*b2k
1776           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1777      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1778         enddo
1779         do k=1,2
1780           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1781           cc(1,k,i-2)=sint1sq*aux
1782           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1783      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1784           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1785           dd(1,k,i-2)=sint1sq*aux
1786           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1787      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1788         enddo
1789         cc(2,1,i-2)=cc(1,2,i-2)
1790         cc(2,2,i-2)=-cc(1,1,i-2)
1791         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1792         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1793         dd(2,1,i-2)=dd(1,2,i-2)
1794         dd(2,2,i-2)=-dd(1,1,i-2)
1795         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1796         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1797         do k=1,2
1798           do l=1,2
1799             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1800             EE(l,k,i-2)=sint1sq*aux
1801             if (calc_grad)
1802      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1803           enddo
1804         enddo
1805         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1806         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1807         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1808         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1809         if (calc_grad) then
1810         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1811         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1812         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1813         endif
1814 c        b1tilde(1,i-2)=b1(1,i-2)
1815 c        b1tilde(2,i-2)=-b1(2,i-2)
1816 c        b2tilde(1,i-2)=b2(1,i-2)
1817 c        b2tilde(2,i-2)=-b2(2,i-2)
1818 #ifdef DEBUG
1819         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1820         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1821         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1822         write (iout,*) 'theta=', theta(i-1)
1823 #endif
1824 #else
1825 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1826 c          iti = itype2loc(itype(i-2))
1827 c        else
1828 c          iti=nloctyp
1829 c        endif
1830 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1831 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1832 c          iti1 = itype2loc(itype(i-1))
1833 c        else
1834 c          iti1=nloctyp
1835 c        endif
1836         b1(1,i-2)=b(3,iti)
1837         b1(2,i-2)=b(5,iti)
1838         b2(1,i-2)=b(2,iti)
1839         b2(2,i-2)=b(4,iti)
1840         do k=1,2
1841           do l=1,2
1842            CC(k,l,i-2)=ccold(k,l,iti)
1843            DD(k,l,i-2)=ddold(k,l,iti)
1844            EE(k,l,i-2)=eeold(k,l,iti)
1845           enddo
1846         enddo
1847 #endif
1848         b1tilde(1,i-2)= b1(1,i-2)
1849         b1tilde(2,i-2)=-b1(2,i-2)
1850         b2tilde(1,i-2)= b2(1,i-2)
1851         b2tilde(2,i-2)=-b2(2,i-2)
1852 c
1853         Ctilde(1,1,i-2)= CC(1,1,i-2)
1854         Ctilde(1,2,i-2)= CC(1,2,i-2)
1855         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1856         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1857 c
1858         Dtilde(1,1,i-2)= DD(1,1,i-2)
1859         Dtilde(1,2,i-2)= DD(1,2,i-2)
1860         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1861         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1862 #ifdef DEBUG
1863         write(iout,*) "i",i," iti",iti
1864         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1865         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1866 #endif
1867       enddo
1868       do i=3,nres+1
1869         if (i .lt. nres+1) then
1870           sin1=dsin(phi(i))
1871           cos1=dcos(phi(i))
1872           sintab(i-2)=sin1
1873           costab(i-2)=cos1
1874           obrot(1,i-2)=cos1
1875           obrot(2,i-2)=sin1
1876           sin2=dsin(2*phi(i))
1877           cos2=dcos(2*phi(i))
1878           sintab2(i-2)=sin2
1879           costab2(i-2)=cos2
1880           obrot2(1,i-2)=cos2
1881           obrot2(2,i-2)=sin2
1882           Ug(1,1,i-2)=-cos1
1883           Ug(1,2,i-2)=-sin1
1884           Ug(2,1,i-2)=-sin1
1885           Ug(2,2,i-2)= cos1
1886           Ug2(1,1,i-2)=-cos2
1887           Ug2(1,2,i-2)=-sin2
1888           Ug2(2,1,i-2)=-sin2
1889           Ug2(2,2,i-2)= cos2
1890         else
1891           costab(i-2)=1.0d0
1892           sintab(i-2)=0.0d0
1893           obrot(1,i-2)=1.0d0
1894           obrot(2,i-2)=0.0d0
1895           obrot2(1,i-2)=0.0d0
1896           obrot2(2,i-2)=0.0d0
1897           Ug(1,1,i-2)=1.0d0
1898           Ug(1,2,i-2)=0.0d0
1899           Ug(2,1,i-2)=0.0d0
1900           Ug(2,2,i-2)=1.0d0
1901           Ug2(1,1,i-2)=0.0d0
1902           Ug2(1,2,i-2)=0.0d0
1903           Ug2(2,1,i-2)=0.0d0
1904           Ug2(2,2,i-2)=0.0d0
1905         endif
1906         if (i .gt. 3 .and. i .lt. nres+1) then
1907           obrot_der(1,i-2)=-sin1
1908           obrot_der(2,i-2)= cos1
1909           Ugder(1,1,i-2)= sin1
1910           Ugder(1,2,i-2)=-cos1
1911           Ugder(2,1,i-2)=-cos1
1912           Ugder(2,2,i-2)=-sin1
1913           dwacos2=cos2+cos2
1914           dwasin2=sin2+sin2
1915           obrot2_der(1,i-2)=-dwasin2
1916           obrot2_der(2,i-2)= dwacos2
1917           Ug2der(1,1,i-2)= dwasin2
1918           Ug2der(1,2,i-2)=-dwacos2
1919           Ug2der(2,1,i-2)=-dwacos2
1920           Ug2der(2,2,i-2)=-dwasin2
1921         else
1922           obrot_der(1,i-2)=0.0d0
1923           obrot_der(2,i-2)=0.0d0
1924           Ugder(1,1,i-2)=0.0d0
1925           Ugder(1,2,i-2)=0.0d0
1926           Ugder(2,1,i-2)=0.0d0
1927           Ugder(2,2,i-2)=0.0d0
1928           obrot2_der(1,i-2)=0.0d0
1929           obrot2_der(2,i-2)=0.0d0
1930           Ug2der(1,1,i-2)=0.0d0
1931           Ug2der(1,2,i-2)=0.0d0
1932           Ug2der(2,1,i-2)=0.0d0
1933           Ug2der(2,2,i-2)=0.0d0
1934         endif
1935 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1936         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1937           iti = itype2loc(itype(i-2))
1938         else
1939           iti=nloctyp
1940         endif
1941 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1942         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1943           iti1 = itype2loc(itype(i-1))
1944         else
1945           iti1=nloctyp
1946         endif
1947 cd        write (iout,*) '*******i',i,' iti1',iti
1948 cd        write (iout,*) 'b1',b1(:,iti)
1949 cd        write (iout,*) 'b2',b2(:,iti)
1950 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1951 c        if (i .gt. iatel_s+2) then
1952         if (i .gt. nnt+2) then
1953           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1954 #ifdef NEWCORR
1955           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1956 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1957 #endif
1958 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1959 c     &    EE(1,2,iti),EE(2,2,i)
1960           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1961           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1962 c          write(iout,*) "Macierz EUG",
1963 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1964 c     &    eug(2,2,i-2)
1965           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1966      &    then
1967           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1968           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1969           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1970           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1971           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1972           endif
1973         else
1974           do k=1,2
1975             Ub2(k,i-2)=0.0d0
1976             Ctobr(k,i-2)=0.0d0
1977             Dtobr2(k,i-2)=0.0d0
1978             do l=1,2
1979               EUg(l,k,i-2)=0.0d0
1980               CUg(l,k,i-2)=0.0d0
1981               DUg(l,k,i-2)=0.0d0
1982               DtUg2(l,k,i-2)=0.0d0
1983             enddo
1984           enddo
1985         endif
1986         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1987         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1988         do k=1,2
1989           muder(k,i-2)=Ub2der(k,i-2)
1990         enddo
1991 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1992         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1993           if (itype(i-1).le.ntyp) then
1994             iti1 = itype2loc(itype(i-1))
1995           else
1996             iti1=nloctyp
1997           endif
1998         else
1999           iti1=nloctyp
2000         endif
2001         do k=1,2
2002           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2003         enddo
2004 #ifdef MUOUT
2005         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2006      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2007      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2008      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2009      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2010      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2011 #endif
2012 cd        write (iout,*) 'mu1',mu1(:,i-2)
2013 cd        write (iout,*) 'mu2',mu2(:,i-2)
2014         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2015      &  then
2016         if (calc_grad) then
2017         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2018         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2019         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2020         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2021         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2022         endif
2023 C Vectors and matrices dependent on a single virtual-bond dihedral.
2024         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2025         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2026         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2027         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2028         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2029         if (calc_grad) then
2030         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2031         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2032         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2033         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2034         endif
2035         endif
2036       enddo
2037 C Matrices dependent on two consecutive virtual-bond dihedrals.
2038 C The order of matrices is from left to right.
2039       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2040      &then
2041       do i=2,nres-1
2042         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2043         if (calc_grad) then
2044         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2045         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2046         endif
2047         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2048         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2049         if (calc_grad) then
2050         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2051         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2052         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2053         endif
2054       enddo
2055       endif
2056       return
2057       end
2058 C--------------------------------------------------------------------------
2059       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2060 C
2061 C This subroutine calculates the average interaction energy and its gradient
2062 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2063 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2064 C The potential depends both on the distance of peptide-group centers and on
2065 C the orientation of the CA-CA virtual bonds.
2066 C
2067       implicit real*8 (a-h,o-z)
2068 #ifdef MPI
2069       include 'mpif.h'
2070 #endif
2071       include 'DIMENSIONS'
2072       include 'DIMENSIONS.ZSCOPT'
2073       include 'COMMON.CONTROL'
2074       include 'COMMON.IOUNITS'
2075       include 'COMMON.GEO'
2076       include 'COMMON.VAR'
2077       include 'COMMON.LOCAL'
2078       include 'COMMON.CHAIN'
2079       include 'COMMON.DERIV'
2080       include 'COMMON.INTERACT'
2081       include 'COMMON.CONTACTS'
2082       include 'COMMON.TORSION'
2083       include 'COMMON.VECTORS'
2084       include 'COMMON.FFIELD'
2085       include 'COMMON.TIME1'
2086       include 'COMMON.SPLITELE'
2087       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2088      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2089       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2090      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2091       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2092      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2093      &    num_conti,j1,j2
2094 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2095 #ifdef MOMENT
2096       double precision scal_el /1.0d0/
2097 #else
2098       double precision scal_el /0.5d0/
2099 #endif
2100 C 12/13/98
2101 C 13-go grudnia roku pamietnego...
2102       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2103      &                   0.0d0,1.0d0,0.0d0,
2104      &                   0.0d0,0.0d0,1.0d0/
2105 cd      write(iout,*) 'In EELEC'
2106 cd      do i=1,nloctyp
2107 cd        write(iout,*) 'Type',i
2108 cd        write(iout,*) 'B1',B1(:,i)
2109 cd        write(iout,*) 'B2',B2(:,i)
2110 cd        write(iout,*) 'CC',CC(:,:,i)
2111 cd        write(iout,*) 'DD',DD(:,:,i)
2112 cd        write(iout,*) 'EE',EE(:,:,i)
2113 cd      enddo
2114 cd      call check_vecgrad
2115 cd      stop
2116       if (icheckgrad.eq.1) then
2117         do i=1,nres-1
2118           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2119           do k=1,3
2120             dc_norm(k,i)=dc(k,i)*fac
2121           enddo
2122 c          write (iout,*) 'i',i,' fac',fac
2123         enddo
2124       endif
2125       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2126      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2127      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2128 c        call vec_and_deriv
2129 #ifdef TIMING
2130         time01=MPI_Wtime()
2131 #endif
2132         call set_matrices
2133 #ifdef TIMING
2134         time_mat=time_mat+MPI_Wtime()-time01
2135 #endif
2136       endif
2137 cd      do i=1,nres-1
2138 cd        write (iout,*) 'i=',i
2139 cd        do k=1,3
2140 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2141 cd        enddo
2142 cd        do k=1,3
2143 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2144 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2145 cd        enddo
2146 cd      enddo
2147       t_eelecij=0.0d0
2148       ees=0.0D0
2149       evdw1=0.0D0
2150       eel_loc=0.0d0
2151       eello_turn3=0.0d0
2152       eello_turn4=0.0d0
2153       ind=0
2154       do i=1,nres
2155         num_cont_hb(i)=0
2156       enddo
2157 cd      print '(a)','Enter EELEC'
2158 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2159       do i=1,nres
2160         gel_loc_loc(i)=0.0d0
2161         gcorr_loc(i)=0.0d0
2162       enddo
2163 c
2164 c
2165 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2166 C
2167 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2168 C
2169 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2170       do i=iturn3_start,iturn3_end
2171 c        if (i.le.1) cycle
2172 C        write(iout,*) "tu jest i",i
2173         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2174 C changes suggested by Ana to avoid out of bounds
2175 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2176 c     & .or.((i+4).gt.nres)
2177 c     & .or.((i-1).le.0)
2178 C end of changes by Ana
2179 C dobra zmiana wycofana
2180      &  .or. itype(i+2).eq.ntyp1
2181      &  .or. itype(i+3).eq.ntyp1) cycle
2182 C Adam: Instructions below will switch off existing interactions
2183 c        if(i.gt.1)then
2184 c          if(itype(i-1).eq.ntyp1)cycle
2185 c        end if
2186 c        if(i.LT.nres-3)then
2187 c          if (itype(i+4).eq.ntyp1) cycle
2188 c        end if
2189         dxi=dc(1,i)
2190         dyi=dc(2,i)
2191         dzi=dc(3,i)
2192         dx_normi=dc_norm(1,i)
2193         dy_normi=dc_norm(2,i)
2194         dz_normi=dc_norm(3,i)
2195         xmedi=c(1,i)+0.5d0*dxi
2196         ymedi=c(2,i)+0.5d0*dyi
2197         zmedi=c(3,i)+0.5d0*dzi
2198           xmedi=mod(xmedi,boxxsize)
2199           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2200           ymedi=mod(ymedi,boxysize)
2201           if (ymedi.lt.0) ymedi=ymedi+boxysize
2202           zmedi=mod(zmedi,boxzsize)
2203           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2204         num_conti=0
2205         call eelecij(i,i+2,ees,evdw1,eel_loc)
2206         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2207         num_cont_hb(i)=num_conti
2208       enddo
2209       do i=iturn4_start,iturn4_end
2210         if (i.lt.1) cycle
2211         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2212 C changes suggested by Ana to avoid out of bounds
2213 c     & .or.((i+5).gt.nres)
2214 c     & .or.((i-1).le.0)
2215 C end of changes suggested by Ana
2216      &    .or. itype(i+3).eq.ntyp1
2217      &    .or. itype(i+4).eq.ntyp1
2218 c     &    .or. itype(i+5).eq.ntyp1
2219 c     &    .or. itype(i).eq.ntyp1
2220 c     &    .or. itype(i-1).eq.ntyp1
2221      &                             ) cycle
2222         dxi=dc(1,i)
2223         dyi=dc(2,i)
2224         dzi=dc(3,i)
2225         dx_normi=dc_norm(1,i)
2226         dy_normi=dc_norm(2,i)
2227         dz_normi=dc_norm(3,i)
2228         xmedi=c(1,i)+0.5d0*dxi
2229         ymedi=c(2,i)+0.5d0*dyi
2230         zmedi=c(3,i)+0.5d0*dzi
2231 C Return atom into box, boxxsize is size of box in x dimension
2232 c  194   continue
2233 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2234 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2235 C Condition for being inside the proper box
2236 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2237 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2238 c        go to 194
2239 c        endif
2240 c  195   continue
2241 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2242 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2243 C Condition for being inside the proper box
2244 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2245 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2246 c        go to 195
2247 c        endif
2248 c  196   continue
2249 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2250 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2251 C Condition for being inside the proper box
2252 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2253 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2254 c        go to 196
2255 c        endif
2256           xmedi=mod(xmedi,boxxsize)
2257           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2258           ymedi=mod(ymedi,boxysize)
2259           if (ymedi.lt.0) ymedi=ymedi+boxysize
2260           zmedi=mod(zmedi,boxzsize)
2261           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2262
2263         num_conti=num_cont_hb(i)
2264 c        write(iout,*) "JESTEM W PETLI"
2265         call eelecij(i,i+3,ees,evdw1,eel_loc)
2266         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2267      &   call eturn4(i,eello_turn4)
2268         num_cont_hb(i)=num_conti
2269       enddo   ! i
2270 C Loop over all neighbouring boxes
2271 C      do xshift=-1,1
2272 C      do yshift=-1,1
2273 C      do zshift=-1,1
2274 c
2275 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2276 c
2277 CTU KURWA
2278       do i=iatel_s,iatel_e
2279 C        do i=75,75
2280 c        if (i.le.1) cycle
2281         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2282 C changes suggested by Ana to avoid out of bounds
2283 c     & .or.((i+2).gt.nres)
2284 c     & .or.((i-1).le.0)
2285 C end of changes by Ana
2286 c     &  .or. itype(i+2).eq.ntyp1
2287 c     &  .or. itype(i-1).eq.ntyp1
2288      &                ) cycle
2289         dxi=dc(1,i)
2290         dyi=dc(2,i)
2291         dzi=dc(3,i)
2292         dx_normi=dc_norm(1,i)
2293         dy_normi=dc_norm(2,i)
2294         dz_normi=dc_norm(3,i)
2295         xmedi=c(1,i)+0.5d0*dxi
2296         ymedi=c(2,i)+0.5d0*dyi
2297         zmedi=c(3,i)+0.5d0*dzi
2298           xmedi=mod(xmedi,boxxsize)
2299           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2300           ymedi=mod(ymedi,boxysize)
2301           if (ymedi.lt.0) ymedi=ymedi+boxysize
2302           zmedi=mod(zmedi,boxzsize)
2303           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2304 C          xmedi=xmedi+xshift*boxxsize
2305 C          ymedi=ymedi+yshift*boxysize
2306 C          zmedi=zmedi+zshift*boxzsize
2307
2308 C Return tom into box, boxxsize is size of box in x dimension
2309 c  164   continue
2310 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2311 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2312 C Condition for being inside the proper box
2313 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2314 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2315 c        go to 164
2316 c        endif
2317 c  165   continue
2318 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2319 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2320 C Condition for being inside the proper box
2321 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2322 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2323 c        go to 165
2324 c        endif
2325 c  166   continue
2326 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2327 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2328 cC Condition for being inside the proper box
2329 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2330 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2331 c        go to 166
2332 c        endif
2333
2334 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2335         num_conti=num_cont_hb(i)
2336 C I TU KURWA
2337         do j=ielstart(i),ielend(i)
2338 C          do j=16,17
2339 C          write (iout,*) i,j
2340 C         if (j.le.1) cycle
2341           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2342 C changes suggested by Ana to avoid out of bounds
2343 c     & .or.((j+2).gt.nres)
2344 c     & .or.((j-1).le.0)
2345 C end of changes by Ana
2346 c     & .or.itype(j+2).eq.ntyp1
2347 c     & .or.itype(j-1).eq.ntyp1
2348      &) cycle
2349           call eelecij(i,j,ees,evdw1,eel_loc)
2350         enddo ! j
2351         num_cont_hb(i)=num_conti
2352       enddo   ! i
2353 C     enddo   ! zshift
2354 C      enddo   ! yshift
2355 C      enddo   ! xshift
2356
2357 c      write (iout,*) "Number of loop steps in EELEC:",ind
2358 cd      do i=1,nres
2359 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2360 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2361 cd      enddo
2362 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2363 ccc      eel_loc=eel_loc+eello_turn3
2364 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2365       return
2366       end
2367 C-------------------------------------------------------------------------------
2368       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2369       implicit real*8 (a-h,o-z)
2370       include 'DIMENSIONS'
2371       include 'DIMENSIONS.ZSCOPT'
2372 #ifdef MPI
2373       include "mpif.h"
2374 #endif
2375       include 'COMMON.CONTROL'
2376       include 'COMMON.IOUNITS'
2377       include 'COMMON.GEO'
2378       include 'COMMON.VAR'
2379       include 'COMMON.LOCAL'
2380       include 'COMMON.CHAIN'
2381       include 'COMMON.DERIV'
2382       include 'COMMON.INTERACT'
2383       include 'COMMON.CONTACTS'
2384       include 'COMMON.TORSION'
2385       include 'COMMON.VECTORS'
2386       include 'COMMON.FFIELD'
2387       include 'COMMON.TIME1'
2388       include 'COMMON.SPLITELE'
2389       include 'COMMON.SHIELD'
2390       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2391      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2392       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2393      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2394      &    gmuij2(4),gmuji2(4)
2395       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2396      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2397      &    num_conti,j1,j2
2398 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2399 #ifdef MOMENT
2400       double precision scal_el /1.0d0/
2401 #else
2402       double precision scal_el /0.5d0/
2403 #endif
2404 C 12/13/98
2405 C 13-go grudnia roku pamietnego...
2406       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2407      &                   0.0d0,1.0d0,0.0d0,
2408      &                   0.0d0,0.0d0,1.0d0/
2409        integer xshift,yshift,zshift
2410 c          time00=MPI_Wtime()
2411 cd      write (iout,*) "eelecij",i,j
2412 c          ind=ind+1
2413           iteli=itel(i)
2414           itelj=itel(j)
2415           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2416           aaa=app(iteli,itelj)
2417           bbb=bpp(iteli,itelj)
2418           ael6i=ael6(iteli,itelj)
2419           ael3i=ael3(iteli,itelj)
2420           dxj=dc(1,j)
2421           dyj=dc(2,j)
2422           dzj=dc(3,j)
2423           dx_normj=dc_norm(1,j)
2424           dy_normj=dc_norm(2,j)
2425           dz_normj=dc_norm(3,j)
2426 C          xj=c(1,j)+0.5D0*dxj-xmedi
2427 C          yj=c(2,j)+0.5D0*dyj-ymedi
2428 C          zj=c(3,j)+0.5D0*dzj-zmedi
2429           xj=c(1,j)+0.5D0*dxj
2430           yj=c(2,j)+0.5D0*dyj
2431           zj=c(3,j)+0.5D0*dzj
2432           xj=mod(xj,boxxsize)
2433           if (xj.lt.0) xj=xj+boxxsize
2434           yj=mod(yj,boxysize)
2435           if (yj.lt.0) yj=yj+boxysize
2436           zj=mod(zj,boxzsize)
2437           if (zj.lt.0) zj=zj+boxzsize
2438           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2439       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2440       xj_safe=xj
2441       yj_safe=yj
2442       zj_safe=zj
2443       isubchap=0
2444       do xshift=-1,1
2445       do yshift=-1,1
2446       do zshift=-1,1
2447           xj=xj_safe+xshift*boxxsize
2448           yj=yj_safe+yshift*boxysize
2449           zj=zj_safe+zshift*boxzsize
2450           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2451           if(dist_temp.lt.dist_init) then
2452             dist_init=dist_temp
2453             xj_temp=xj
2454             yj_temp=yj
2455             zj_temp=zj
2456             isubchap=1
2457           endif
2458        enddo
2459        enddo
2460        enddo
2461        if (isubchap.eq.1) then
2462           xj=xj_temp-xmedi
2463           yj=yj_temp-ymedi
2464           zj=zj_temp-zmedi
2465        else
2466           xj=xj_safe-xmedi
2467           yj=yj_safe-ymedi
2468           zj=zj_safe-zmedi
2469        endif
2470 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2471 c  174   continue
2472 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2473 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2474 C Condition for being inside the proper box
2475 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2476 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2477 c        go to 174
2478 c        endif
2479 c  175   continue
2480 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2481 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2482 C Condition for being inside the proper box
2483 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2484 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2485 c        go to 175
2486 c        endif
2487 c  176   continue
2488 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2489 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2490 C Condition for being inside the proper box
2491 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2492 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2493 c        go to 176
2494 c        endif
2495 C        endif !endPBC condintion
2496 C        xj=xj-xmedi
2497 C        yj=yj-ymedi
2498 C        zj=zj-zmedi
2499           rij=xj*xj+yj*yj+zj*zj
2500
2501             sss=sscale(sqrt(rij))
2502             sssgrad=sscagrad(sqrt(rij))
2503 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2504 c     &       " rlamb",rlamb," sss",sss
2505 c            if (sss.gt.0.0d0) then
2506           rrmij=1.0D0/rij
2507           rij=dsqrt(rij)
2508           rmij=1.0D0/rij
2509           r3ij=rrmij*rmij
2510           r6ij=r3ij*r3ij
2511           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2512           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2513           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2514           fac=cosa-3.0D0*cosb*cosg
2515           ev1=aaa*r6ij*r6ij
2516 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2517           if (j.eq.i+2) ev1=scal_el*ev1
2518           ev2=bbb*r6ij
2519           fac3=ael6i*r6ij
2520           fac4=ael3i*r3ij
2521           evdwij=(ev1+ev2)
2522           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2523           el2=fac4*fac
2524 C MARYSIA
2525 C          eesij=(el1+el2)
2526 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2527           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2528           if (shield_mode.gt.0) then
2529 C          fac_shield(i)=0.4
2530 C          fac_shield(j)=0.6
2531           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2532           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2533           eesij=(el1+el2)
2534           ees=ees+eesij
2535           else
2536           fac_shield(i)=1.0
2537           fac_shield(j)=1.0
2538           eesij=(el1+el2)
2539           ees=ees+eesij
2540           endif
2541           evdw1=evdw1+evdwij*sss
2542 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2543 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2544 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2545 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2546
2547           if (energy_dec) then
2548               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2549      &'evdw1',i,j,evdwij
2550      &,iteli,itelj,aaa,evdw1,sss
2551               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2552      &fac_shield(i),fac_shield(j)
2553           endif
2554
2555 C
2556 C Calculate contributions to the Cartesian gradient.
2557 C
2558 #ifdef SPLITELE
2559           facvdw=-6*rrmij*(ev1+evdwij)*sss
2560           facel=-3*rrmij*(el1+eesij)
2561           fac1=fac
2562           erij(1)=xj*rmij
2563           erij(2)=yj*rmij
2564           erij(3)=zj*rmij
2565
2566 *
2567 * Radial derivatives. First process both termini of the fragment (i,j)
2568 *
2569           if (calc_grad) then
2570           ggg(1)=facel*xj
2571           ggg(2)=facel*yj
2572           ggg(3)=facel*zj
2573           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2574      &  (shield_mode.gt.0)) then
2575 C          print *,i,j
2576           do ilist=1,ishield_list(i)
2577            iresshield=shield_list(ilist,i)
2578            do k=1,3
2579            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2580      &      *2.0
2581            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2582      &              rlocshield
2583      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2584             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2585 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2586 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2587 C             if (iresshield.gt.i) then
2588 C               do ishi=i+1,iresshield-1
2589 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2590 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2591 C
2592 C              enddo
2593 C             else
2594 C               do ishi=iresshield,i
2595 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2596 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2597 C
2598 C               enddo
2599 C              endif
2600            enddo
2601           enddo
2602           do ilist=1,ishield_list(j)
2603            iresshield=shield_list(ilist,j)
2604            do k=1,3
2605            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2606      &     *2.0
2607            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2608      &              rlocshield
2609      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2610            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2611
2612 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2613 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2614 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2615 C             if (iresshield.gt.j) then
2616 C               do ishi=j+1,iresshield-1
2617 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2618 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2619 C
2620 C               enddo
2621 C            else
2622 C               do ishi=iresshield,j
2623 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2624 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2625 C               enddo
2626 C              endif
2627            enddo
2628           enddo
2629
2630           do k=1,3
2631             gshieldc(k,i)=gshieldc(k,i)+
2632      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2633             gshieldc(k,j)=gshieldc(k,j)+
2634      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2635             gshieldc(k,i-1)=gshieldc(k,i-1)+
2636      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2637             gshieldc(k,j-1)=gshieldc(k,j-1)+
2638      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2639
2640            enddo
2641            endif
2642 c          do k=1,3
2643 c            ghalf=0.5D0*ggg(k)
2644 c            gelc(k,i)=gelc(k,i)+ghalf
2645 c            gelc(k,j)=gelc(k,j)+ghalf
2646 c          enddo
2647 c 9/28/08 AL Gradient compotents will be summed only at the end
2648 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2649           do k=1,3
2650             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2651 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2652             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2653 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2654 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2655 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2656 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2657 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2658           enddo
2659 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2660
2661 *
2662 * Loop over residues i+1 thru j-1.
2663 *
2664 cgrad          do k=i+1,j-1
2665 cgrad            do l=1,3
2666 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2667 cgrad            enddo
2668 cgrad          enddo
2669           if (sss.gt.0.0) then
2670           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2671           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2672           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2673           else
2674           ggg(1)=0.0
2675           ggg(2)=0.0
2676           ggg(3)=0.0
2677           endif
2678 c          do k=1,3
2679 c            ghalf=0.5D0*ggg(k)
2680 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2681 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2682 c          enddo
2683 c 9/28/08 AL Gradient compotents will be summed only at the end
2684           do k=1,3
2685             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2686             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2687           enddo
2688 *
2689 * Loop over residues i+1 thru j-1.
2690 *
2691 cgrad          do k=i+1,j-1
2692 cgrad            do l=1,3
2693 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2694 cgrad            enddo
2695 cgrad          enddo
2696           endif ! calc_grad
2697 #else
2698 C MARYSIA
2699           facvdw=(ev1+evdwij)*sss
2700           facel=(el1+eesij)
2701           fac1=fac
2702           fac=-3*rrmij*(facvdw+facvdw+facel)
2703           erij(1)=xj*rmij
2704           erij(2)=yj*rmij
2705           erij(3)=zj*rmij
2706 *
2707 * Radial derivatives. First process both termini of the fragment (i,j)
2708 *
2709           if (calc_grad) then
2710           ggg(1)=fac*xj
2711 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2712           ggg(2)=fac*yj
2713 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2714           ggg(3)=fac*zj
2715 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2716 c          do k=1,3
2717 c            ghalf=0.5D0*ggg(k)
2718 c            gelc(k,i)=gelc(k,i)+ghalf
2719 c            gelc(k,j)=gelc(k,j)+ghalf
2720 c          enddo
2721 c 9/28/08 AL Gradient compotents will be summed only at the end
2722           do k=1,3
2723             gelc_long(k,j)=gelc(k,j)+ggg(k)
2724             gelc_long(k,i)=gelc(k,i)-ggg(k)
2725           enddo
2726 *
2727 * Loop over residues i+1 thru j-1.
2728 *
2729 cgrad          do k=i+1,j-1
2730 cgrad            do l=1,3
2731 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2732 cgrad            enddo
2733 cgrad          enddo
2734 c 9/28/08 AL Gradient compotents will be summed only at the end
2735           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2736           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2737           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2738           do k=1,3
2739             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2740             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2741           enddo
2742           endif ! calc_grad
2743 #endif
2744 *
2745 * Angular part
2746 *
2747           if (calc_grad) then
2748           ecosa=2.0D0*fac3*fac1+fac4
2749           fac4=-3.0D0*fac4
2750           fac3=-6.0D0*fac3
2751           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2752           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2753           do k=1,3
2754             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2755             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2756           enddo
2757 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2758 cd   &          (dcosg(k),k=1,3)
2759           do k=1,3
2760             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2761      &      fac_shield(i)**2*fac_shield(j)**2
2762           enddo
2763 c          do k=1,3
2764 c            ghalf=0.5D0*ggg(k)
2765 c            gelc(k,i)=gelc(k,i)+ghalf
2766 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2767 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2768 c            gelc(k,j)=gelc(k,j)+ghalf
2769 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2770 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2771 c          enddo
2772 cgrad          do k=i+1,j-1
2773 cgrad            do l=1,3
2774 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2775 cgrad            enddo
2776 cgrad          enddo
2777 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2778           do k=1,3
2779             gelc(k,i)=gelc(k,i)
2780      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2781      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2782      &           *fac_shield(i)**2*fac_shield(j)**2
2783             gelc(k,j)=gelc(k,j)
2784      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2785      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2786      &           *fac_shield(i)**2*fac_shield(j)**2
2787             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2788             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2789           enddo
2790 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2791
2792 C MARYSIA
2793 c          endif !sscale
2794           endif ! calc_grad
2795           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2796      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2797      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2798 C
2799 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2800 C   energy of a peptide unit is assumed in the form of a second-order
2801 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2802 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2803 C   are computed for EVERY pair of non-contiguous peptide groups.
2804 C
2805
2806           if (j.lt.nres-1) then
2807             j1=j+1
2808             j2=j-1
2809           else
2810             j1=j-1
2811             j2=j-2
2812           endif
2813           kkk=0
2814           lll=0
2815           do k=1,2
2816             do l=1,2
2817               kkk=kkk+1
2818               muij(kkk)=mu(k,i)*mu(l,j)
2819 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2820 #ifdef NEWCORR
2821              if (calc_grad) then
2822              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2823 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2824              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2825              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2826 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2827              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2828              endif
2829 #endif
2830             enddo
2831           enddo
2832 #ifdef DEBUG
2833           write (iout,*) 'EELEC: i',i,' j',j
2834           write (iout,*) 'j',j,' j1',j1,' j2',j2
2835           write(iout,*) 'muij',muij
2836           write (iout,*) "uy",uy(:,i)
2837           write (iout,*) "uz",uz(:,j)
2838           write (iout,*) "erij",erij
2839 #endif
2840           ury=scalar(uy(1,i),erij)
2841           urz=scalar(uz(1,i),erij)
2842           vry=scalar(uy(1,j),erij)
2843           vrz=scalar(uz(1,j),erij)
2844           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2845           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2846           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2847           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2848           fac=dsqrt(-ael6i)*r3ij
2849           a22=a22*fac
2850           a23=a23*fac
2851           a32=a32*fac
2852           a33=a33*fac
2853 cd          write (iout,'(4i5,4f10.5)')
2854 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2855 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2856 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2857 cd     &      uy(:,j),uz(:,j)
2858 cd          write (iout,'(4f10.5)')
2859 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2860 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2861 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2862 cd           write (iout,'(9f10.5/)')
2863 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2864 C Derivatives of the elements of A in virtual-bond vectors
2865           if (calc_grad) then
2866           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2867           do k=1,3
2868             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2869             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2870             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2871             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2872             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2873             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2874             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2875             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2876             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2877             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2878             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2879             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2880           enddo
2881 C Compute radial contributions to the gradient
2882           facr=-3.0d0*rrmij
2883           a22der=a22*facr
2884           a23der=a23*facr
2885           a32der=a32*facr
2886           a33der=a33*facr
2887           agg(1,1)=a22der*xj
2888           agg(2,1)=a22der*yj
2889           agg(3,1)=a22der*zj
2890           agg(1,2)=a23der*xj
2891           agg(2,2)=a23der*yj
2892           agg(3,2)=a23der*zj
2893           agg(1,3)=a32der*xj
2894           agg(2,3)=a32der*yj
2895           agg(3,3)=a32der*zj
2896           agg(1,4)=a33der*xj
2897           agg(2,4)=a33der*yj
2898           agg(3,4)=a33der*zj
2899 C Add the contributions coming from er
2900           fac3=-3.0d0*fac
2901           do k=1,3
2902             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2903             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2904             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2905             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2906           enddo
2907           do k=1,3
2908 C Derivatives in DC(i)
2909 cgrad            ghalf1=0.5d0*agg(k,1)
2910 cgrad            ghalf2=0.5d0*agg(k,2)
2911 cgrad            ghalf3=0.5d0*agg(k,3)
2912 cgrad            ghalf4=0.5d0*agg(k,4)
2913             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2914      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2915             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2916      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2917             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2918      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2919             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2920      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2921 C Derivatives in DC(i+1)
2922             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2923      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2924             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2925      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2926             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2927      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2928             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2929      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2930 C Derivatives in DC(j)
2931             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2932      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2933             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2934      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2935             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2936      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2937             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2938      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2939 C Derivatives in DC(j+1) or DC(nres-1)
2940             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2941      &      -3.0d0*vryg(k,3)*ury)
2942             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2943      &      -3.0d0*vrzg(k,3)*ury)
2944             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2945      &      -3.0d0*vryg(k,3)*urz)
2946             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2947      &      -3.0d0*vrzg(k,3)*urz)
2948 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2949 cgrad              do l=1,4
2950 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2951 cgrad              enddo
2952 cgrad            endif
2953           enddo
2954           endif ! calc_grad
2955           acipa(1,1)=a22
2956           acipa(1,2)=a23
2957           acipa(2,1)=a32
2958           acipa(2,2)=a33
2959           a22=-a22
2960           a23=-a23
2961           if (calc_grad) then
2962           do l=1,2
2963             do k=1,3
2964               agg(k,l)=-agg(k,l)
2965               aggi(k,l)=-aggi(k,l)
2966               aggi1(k,l)=-aggi1(k,l)
2967               aggj(k,l)=-aggj(k,l)
2968               aggj1(k,l)=-aggj1(k,l)
2969             enddo
2970           enddo
2971           endif ! calc_grad
2972           if (j.lt.nres-1) then
2973             a22=-a22
2974             a32=-a32
2975             do l=1,3,2
2976               do k=1,3
2977                 agg(k,l)=-agg(k,l)
2978                 aggi(k,l)=-aggi(k,l)
2979                 aggi1(k,l)=-aggi1(k,l)
2980                 aggj(k,l)=-aggj(k,l)
2981                 aggj1(k,l)=-aggj1(k,l)
2982               enddo
2983             enddo
2984           else
2985             a22=-a22
2986             a23=-a23
2987             a32=-a32
2988             a33=-a33
2989             do l=1,4
2990               do k=1,3
2991                 agg(k,l)=-agg(k,l)
2992                 aggi(k,l)=-aggi(k,l)
2993                 aggi1(k,l)=-aggi1(k,l)
2994                 aggj(k,l)=-aggj(k,l)
2995                 aggj1(k,l)=-aggj1(k,l)
2996               enddo
2997             enddo
2998           endif
2999           ENDIF ! WCORR
3000           IF (wel_loc.gt.0.0d0) THEN
3001 C Contribution to the local-electrostatic energy coming from the i-j pair
3002           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3003      &     +a33*muij(4)
3004 #ifdef DEBUG
3005           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3006      &     " a33",a33
3007           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3008      &     " wel_loc",wel_loc
3009 #endif
3010           if (shield_mode.eq.0) then
3011            fac_shield(i)=1.0
3012            fac_shield(j)=1.0
3013 C          else
3014 C           fac_shield(i)=0.4
3015 C           fac_shield(j)=0.6
3016           endif
3017           eel_loc_ij=eel_loc_ij
3018      &    *fac_shield(i)*fac_shield(j)
3019           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3020      &            'eelloc',i,j,eel_loc_ij
3021 c           if (eel_loc_ij.ne.0)
3022 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3023 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3024
3025           eel_loc=eel_loc+eel_loc_ij
3026 C Now derivative over eel_loc
3027           if (calc_grad) then
3028           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3029      &  (shield_mode.gt.0)) then
3030 C          print *,i,j
3031
3032           do ilist=1,ishield_list(i)
3033            iresshield=shield_list(ilist,i)
3034            do k=1,3
3035            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3036      &                                          /fac_shield(i)
3037 C     &      *2.0
3038            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3039      &              rlocshield
3040      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3041             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3042      &      +rlocshield
3043            enddo
3044           enddo
3045           do ilist=1,ishield_list(j)
3046            iresshield=shield_list(ilist,j)
3047            do k=1,3
3048            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3049      &                                       /fac_shield(j)
3050 C     &     *2.0
3051            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3052      &              rlocshield
3053      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3054            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3055      &             +rlocshield
3056
3057            enddo
3058           enddo
3059
3060           do k=1,3
3061             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3062      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3063             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3064      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3065             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3066      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3067             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3068      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3069            enddo
3070            endif
3071
3072
3073 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3074 c     &                     ' eel_loc_ij',eel_loc_ij
3075 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3076 C Calculate patrial derivative for theta angle
3077 #ifdef NEWCORR
3078          geel_loc_ij=(a22*gmuij1(1)
3079      &     +a23*gmuij1(2)
3080      &     +a32*gmuij1(3)
3081      &     +a33*gmuij1(4))
3082      &    *fac_shield(i)*fac_shield(j)
3083 c         write(iout,*) "derivative over thatai"
3084 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3085 c     &   a33*gmuij1(4)
3086          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3087      &      geel_loc_ij*wel_loc
3088 c         write(iout,*) "derivative over thatai-1"
3089 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3090 c     &   a33*gmuij2(4)
3091          geel_loc_ij=
3092      &     a22*gmuij2(1)
3093      &     +a23*gmuij2(2)
3094      &     +a32*gmuij2(3)
3095      &     +a33*gmuij2(4)
3096          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3097      &      geel_loc_ij*wel_loc
3098      &    *fac_shield(i)*fac_shield(j)
3099
3100 c  Derivative over j residue
3101          geel_loc_ji=a22*gmuji1(1)
3102      &     +a23*gmuji1(2)
3103      &     +a32*gmuji1(3)
3104      &     +a33*gmuji1(4)
3105 c         write(iout,*) "derivative over thataj"
3106 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3107 c     &   a33*gmuji1(4)
3108
3109         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3110      &      geel_loc_ji*wel_loc
3111      &    *fac_shield(i)*fac_shield(j)
3112
3113          geel_loc_ji=
3114      &     +a22*gmuji2(1)
3115      &     +a23*gmuji2(2)
3116      &     +a32*gmuji2(3)
3117      &     +a33*gmuji2(4)
3118 c         write(iout,*) "derivative over thataj-1"
3119 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3120 c     &   a33*gmuji2(4)
3121          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3122      &      geel_loc_ji*wel_loc
3123      &    *fac_shield(i)*fac_shield(j)
3124 #endif
3125 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3126
3127 C Partial derivatives in virtual-bond dihedral angles gamma
3128           if (i.gt.1)
3129      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3130      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3131      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3132      &    *fac_shield(i)*fac_shield(j)
3133
3134           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3135      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3136      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3137      &    *fac_shield(i)*fac_shield(j)
3138 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3139           do l=1,3
3140             ggg(l)=(agg(l,1)*muij(1)+
3141      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3142      &    *fac_shield(i)*fac_shield(j)
3143             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3144             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3145 cgrad            ghalf=0.5d0*ggg(l)
3146 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3147 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3148           enddo
3149 cgrad          do k=i+1,j2
3150 cgrad            do l=1,3
3151 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3152 cgrad            enddo
3153 cgrad          enddo
3154 C Remaining derivatives of eello
3155           do l=1,3
3156             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3157      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3158      &    *fac_shield(i)*fac_shield(j)
3159
3160             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3161      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3162      &    *fac_shield(i)*fac_shield(j)
3163
3164             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3165      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3166      &    *fac_shield(i)*fac_shield(j)
3167
3168             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3169      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3170      &    *fac_shield(i)*fac_shield(j)
3171
3172           enddo
3173           endif ! calc_grad
3174           ENDIF
3175
3176
3177 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3178 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3179           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3180      &       .and. num_conti.le.maxconts) then
3181 c            write (iout,*) i,j," entered corr"
3182 C
3183 C Calculate the contact function. The ith column of the array JCONT will
3184 C contain the numbers of atoms that make contacts with the atom I (of numbers
3185 C greater than I). The arrays FACONT and GACONT will contain the values of
3186 C the contact function and its derivative.
3187 c           r0ij=1.02D0*rpp(iteli,itelj)
3188 c           r0ij=1.11D0*rpp(iteli,itelj)
3189             r0ij=2.20D0*rpp(iteli,itelj)
3190 c           r0ij=1.55D0*rpp(iteli,itelj)
3191             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3192             if (fcont.gt.0.0D0) then
3193               num_conti=num_conti+1
3194               if (num_conti.gt.maxconts) then
3195                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3196      &                         ' will skip next contacts for this conf.'
3197               else
3198                 jcont_hb(num_conti,i)=j
3199 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3200 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3201                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3202      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3203 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3204 C  terms.
3205                 d_cont(num_conti,i)=rij
3206 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3207 C     --- Electrostatic-interaction matrix ---
3208                 a_chuj(1,1,num_conti,i)=a22
3209                 a_chuj(1,2,num_conti,i)=a23
3210                 a_chuj(2,1,num_conti,i)=a32
3211                 a_chuj(2,2,num_conti,i)=a33
3212 C     --- Gradient of rij
3213                 if (calc_grad) then
3214                 do kkk=1,3
3215                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3216                 enddo
3217                 kkll=0
3218                 do k=1,2
3219                   do l=1,2
3220                     kkll=kkll+1
3221                     do m=1,3
3222                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3223                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3224                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3225                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3226                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3227                     enddo
3228                   enddo
3229                 enddo
3230                 endif ! calc_grad
3231                 ENDIF
3232                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3233 C Calculate contact energies
3234                 cosa4=4.0D0*cosa
3235                 wij=cosa-3.0D0*cosb*cosg
3236                 cosbg1=cosb+cosg
3237                 cosbg2=cosb-cosg
3238 c               fac3=dsqrt(-ael6i)/r0ij**3
3239                 fac3=dsqrt(-ael6i)*r3ij
3240 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3241                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3242                 if (ees0tmp.gt.0) then
3243                   ees0pij=dsqrt(ees0tmp)
3244                 else
3245                   ees0pij=0
3246                 endif
3247 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3248                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3249                 if (ees0tmp.gt.0) then
3250                   ees0mij=dsqrt(ees0tmp)
3251                 else
3252                   ees0mij=0
3253                 endif
3254 c               ees0mij=0.0D0
3255                 if (shield_mode.eq.0) then
3256                 fac_shield(i)=1.0d0
3257                 fac_shield(j)=1.0d0
3258                 else
3259                 ees0plist(num_conti,i)=j
3260 C                fac_shield(i)=0.4d0
3261 C                fac_shield(j)=0.6d0
3262                 endif
3263                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3264      &          *fac_shield(i)*fac_shield(j)
3265                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3266      &          *fac_shield(i)*fac_shield(j)
3267 C Diagnostics. Comment out or remove after debugging!
3268 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3269 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3270 c               ees0m(num_conti,i)=0.0D0
3271 C End diagnostics.
3272 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3273 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3274 C Angular derivatives of the contact function
3275
3276                 ees0pij1=fac3/ees0pij
3277                 ees0mij1=fac3/ees0mij
3278                 fac3p=-3.0D0*fac3*rrmij
3279                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3280                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3281 c               ees0mij1=0.0D0
3282                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3283                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3284                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3285                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3286                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3287                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3288                 ecosap=ecosa1+ecosa2
3289                 ecosbp=ecosb1+ecosb2
3290                 ecosgp=ecosg1+ecosg2
3291                 ecosam=ecosa1-ecosa2
3292                 ecosbm=ecosb1-ecosb2
3293                 ecosgm=ecosg1-ecosg2
3294 C Diagnostics
3295 c               ecosap=ecosa1
3296 c               ecosbp=ecosb1
3297 c               ecosgp=ecosg1
3298 c               ecosam=0.0D0
3299 c               ecosbm=0.0D0
3300 c               ecosgm=0.0D0
3301 C End diagnostics
3302                 facont_hb(num_conti,i)=fcont
3303
3304                 if (calc_grad) then
3305                 fprimcont=fprimcont/rij
3306 cd              facont_hb(num_conti,i)=1.0D0
3307 C Following line is for diagnostics.
3308 cd              fprimcont=0.0D0
3309                 do k=1,3
3310                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3311                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3312                 enddo
3313                 do k=1,3
3314                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3315                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3316                 enddo
3317                 gggp(1)=gggp(1)+ees0pijp*xj
3318                 gggp(2)=gggp(2)+ees0pijp*yj
3319                 gggp(3)=gggp(3)+ees0pijp*zj
3320                 gggm(1)=gggm(1)+ees0mijp*xj
3321                 gggm(2)=gggm(2)+ees0mijp*yj
3322                 gggm(3)=gggm(3)+ees0mijp*zj
3323 C Derivatives due to the contact function
3324                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3325                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3326                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3327                 do k=1,3
3328 c
3329 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3330 c          following the change of gradient-summation algorithm.
3331 c
3332 cgrad                  ghalfp=0.5D0*gggp(k)
3333 cgrad                  ghalfm=0.5D0*gggm(k)
3334                   gacontp_hb1(k,num_conti,i)=!ghalfp
3335      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3336      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3337      &          *fac_shield(i)*fac_shield(j)
3338
3339                   gacontp_hb2(k,num_conti,i)=!ghalfp
3340      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3341      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3342      &          *fac_shield(i)*fac_shield(j)
3343
3344                   gacontp_hb3(k,num_conti,i)=gggp(k)
3345      &          *fac_shield(i)*fac_shield(j)
3346
3347                   gacontm_hb1(k,num_conti,i)=!ghalfm
3348      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3349      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3350      &          *fac_shield(i)*fac_shield(j)
3351
3352                   gacontm_hb2(k,num_conti,i)=!ghalfm
3353      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3354      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3355      &          *fac_shield(i)*fac_shield(j)
3356
3357                   gacontm_hb3(k,num_conti,i)=gggm(k)
3358      &          *fac_shield(i)*fac_shield(j)
3359
3360                 enddo
3361 C Diagnostics. Comment out or remove after debugging!
3362 cdiag           do k=1,3
3363 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3364 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3365 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3366 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3367 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3368 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3369 cdiag           enddo
3370
3371                  endif ! calc_grad
3372
3373               ENDIF ! wcorr
3374               endif  ! num_conti.le.maxconts
3375             endif  ! fcont.gt.0
3376           endif    ! j.gt.i+1
3377           if (calc_grad) then
3378           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3379             do k=1,4
3380               do l=1,3
3381                 ghalf=0.5d0*agg(l,k)
3382                 aggi(l,k)=aggi(l,k)+ghalf
3383                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3384                 aggj(l,k)=aggj(l,k)+ghalf
3385               enddo
3386             enddo
3387             if (j.eq.nres-1 .and. i.lt.j-2) then
3388               do k=1,4
3389                 do l=1,3
3390                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3391                 enddo
3392               enddo
3393             endif
3394           endif
3395           endif ! calc_grad
3396 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3397       return
3398       end
3399 C-----------------------------------------------------------------------------
3400       subroutine eturn3(i,eello_turn3)
3401 C Third- and fourth-order contributions from turns
3402       implicit real*8 (a-h,o-z)
3403       include 'DIMENSIONS'
3404       include 'DIMENSIONS.ZSCOPT'
3405       include 'COMMON.IOUNITS'
3406       include 'COMMON.GEO'
3407       include 'COMMON.VAR'
3408       include 'COMMON.LOCAL'
3409       include 'COMMON.CHAIN'
3410       include 'COMMON.DERIV'
3411       include 'COMMON.INTERACT'
3412       include 'COMMON.CONTACTS'
3413       include 'COMMON.TORSION'
3414       include 'COMMON.VECTORS'
3415       include 'COMMON.FFIELD'
3416       include 'COMMON.CONTROL'
3417       include 'COMMON.SHIELD'
3418       dimension ggg(3)
3419       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3420      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3421      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3422      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3423      &  auxgmat2(2,2),auxgmatt2(2,2)
3424       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3425      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3426       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3427      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3428      &    num_conti,j1,j2
3429       j=i+2
3430 c      write (iout,*) "eturn3",i,j,j1,j2
3431       a_temp(1,1)=a22
3432       a_temp(1,2)=a23
3433       a_temp(2,1)=a32
3434       a_temp(2,2)=a33
3435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3436 C
3437 C               Third-order contributions
3438 C
3439 C                 (i+2)o----(i+3)
3440 C                      | |
3441 C                      | |
3442 C                 (i+1)o----i
3443 C
3444 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3445 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3446         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3447 c auxalary matices for theta gradient
3448 c auxalary matrix for i+1 and constant i+2
3449         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3450 c auxalary matrix for i+2 and constant i+1
3451         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3452         call transpose2(auxmat(1,1),auxmat1(1,1))
3453         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3454         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3455         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3456         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3457         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3458         if (shield_mode.eq.0) then
3459         fac_shield(i)=1.0
3460         fac_shield(j)=1.0
3461 C        else
3462 C        fac_shield(i)=0.4
3463 C        fac_shield(j)=0.6
3464         endif
3465         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3466      &  *fac_shield(i)*fac_shield(j)
3467         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3468      &  *fac_shield(i)*fac_shield(j)
3469         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3470      &    eello_t3
3471         if (calc_grad) then
3472 C#ifdef NEWCORR
3473 C Derivatives in theta
3474         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3475      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3476      &   *fac_shield(i)*fac_shield(j)
3477         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3478      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3479      &   *fac_shield(i)*fac_shield(j)
3480 C#endif
3481
3482 C Derivatives in shield mode
3483           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3484      &  (shield_mode.gt.0)) then
3485 C          print *,i,j
3486
3487           do ilist=1,ishield_list(i)
3488            iresshield=shield_list(ilist,i)
3489            do k=1,3
3490            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3491 C     &      *2.0
3492            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3493      &              rlocshield
3494      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3495             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3496      &      +rlocshield
3497            enddo
3498           enddo
3499           do ilist=1,ishield_list(j)
3500            iresshield=shield_list(ilist,j)
3501            do k=1,3
3502            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3503 C     &     *2.0
3504            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3505      &              rlocshield
3506      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3507            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3508      &             +rlocshield
3509
3510            enddo
3511           enddo
3512
3513           do k=1,3
3514             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3515      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3516             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3517      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3518             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3519      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3520             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3521      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3522            enddo
3523            endif
3524
3525 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3526 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3527 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3528 cd     &    ' eello_turn3_num',4*eello_turn3_num
3529 C Derivatives in gamma(i)
3530         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3531         call transpose2(auxmat2(1,1),auxmat3(1,1))
3532         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3533         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3534      &   *fac_shield(i)*fac_shield(j)
3535 C Derivatives in gamma(i+1)
3536         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3537         call transpose2(auxmat2(1,1),auxmat3(1,1))
3538         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3539         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3540      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3541      &   *fac_shield(i)*fac_shield(j)
3542 C Cartesian derivatives
3543         do l=1,3
3544 c            ghalf1=0.5d0*agg(l,1)
3545 c            ghalf2=0.5d0*agg(l,2)
3546 c            ghalf3=0.5d0*agg(l,3)
3547 c            ghalf4=0.5d0*agg(l,4)
3548           a_temp(1,1)=aggi(l,1)!+ghalf1
3549           a_temp(1,2)=aggi(l,2)!+ghalf2
3550           a_temp(2,1)=aggi(l,3)!+ghalf3
3551           a_temp(2,2)=aggi(l,4)!+ghalf4
3552           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3553           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3554      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3555      &   *fac_shield(i)*fac_shield(j)
3556
3557           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3558           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3559           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3560           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3561           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3562           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3563      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3564      &   *fac_shield(i)*fac_shield(j)
3565           a_temp(1,1)=aggj(l,1)!+ghalf1
3566           a_temp(1,2)=aggj(l,2)!+ghalf2
3567           a_temp(2,1)=aggj(l,3)!+ghalf3
3568           a_temp(2,2)=aggj(l,4)!+ghalf4
3569           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3570           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3571      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3572      &   *fac_shield(i)*fac_shield(j)
3573           a_temp(1,1)=aggj1(l,1)
3574           a_temp(1,2)=aggj1(l,2)
3575           a_temp(2,1)=aggj1(l,3)
3576           a_temp(2,2)=aggj1(l,4)
3577           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3578           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3579      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3580      &   *fac_shield(i)*fac_shield(j)
3581         enddo
3582
3583         endif ! calc_grad
3584
3585       return
3586       end
3587 C-------------------------------------------------------------------------------
3588       subroutine eturn4(i,eello_turn4)
3589 C Third- and fourth-order contributions from turns
3590       implicit real*8 (a-h,o-z)
3591       include 'DIMENSIONS'
3592       include 'DIMENSIONS.ZSCOPT'
3593       include 'COMMON.IOUNITS'
3594       include 'COMMON.GEO'
3595       include 'COMMON.VAR'
3596       include 'COMMON.LOCAL'
3597       include 'COMMON.CHAIN'
3598       include 'COMMON.DERIV'
3599       include 'COMMON.INTERACT'
3600       include 'COMMON.CONTACTS'
3601       include 'COMMON.TORSION'
3602       include 'COMMON.VECTORS'
3603       include 'COMMON.FFIELD'
3604       include 'COMMON.CONTROL'
3605       include 'COMMON.SHIELD'
3606       dimension ggg(3)
3607       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3608      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3609      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3610      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3611      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3612      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3613      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3614       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3615      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3616       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3617      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3618      &    num_conti,j1,j2
3619       j=i+3
3620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3621 C
3622 C               Fourth-order contributions
3623 C
3624 C                 (i+3)o----(i+4)
3625 C                     /  |
3626 C               (i+2)o   |
3627 C                     \  |
3628 C                 (i+1)o----i
3629 C
3630 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3631 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3632 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3633 c        write(iout,*)"WCHODZE W PROGRAM"
3634         a_temp(1,1)=a22
3635         a_temp(1,2)=a23
3636         a_temp(2,1)=a32
3637         a_temp(2,2)=a33
3638         iti1=itype2loc(itype(i+1))
3639         iti2=itype2loc(itype(i+2))
3640         iti3=itype2loc(itype(i+3))
3641 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3642         call transpose2(EUg(1,1,i+1),e1t(1,1))
3643         call transpose2(Eug(1,1,i+2),e2t(1,1))
3644         call transpose2(Eug(1,1,i+3),e3t(1,1))
3645 C Ematrix derivative in theta
3646         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3647         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3648         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3649         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3650 c       eta1 in derivative theta
3651         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3652         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3653 c       auxgvec is derivative of Ub2 so i+3 theta
3654         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3655 c       auxalary matrix of E i+1
3656         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3657 c        s1=0.0
3658 c        gs1=0.0
3659         s1=scalar2(b1(1,i+2),auxvec(1))
3660 c derivative of theta i+2 with constant i+3
3661         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3662 c derivative of theta i+2 with constant i+2
3663         gs32=scalar2(b1(1,i+2),auxgvec(1))
3664 c derivative of E matix in theta of i+1
3665         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3666
3667         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3668 c       ea31 in derivative theta
3669         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3670         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3671 c auxilary matrix auxgvec of Ub2 with constant E matirx
3672         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3673 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3674         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3675
3676 c        s2=0.0
3677 c        gs2=0.0
3678         s2=scalar2(b1(1,i+1),auxvec(1))
3679 c derivative of theta i+1 with constant i+3
3680         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3681 c derivative of theta i+2 with constant i+1
3682         gs21=scalar2(b1(1,i+1),auxgvec(1))
3683 c derivative of theta i+3 with constant i+1
3684         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3685 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3686 c     &  gtb1(1,i+1)
3687         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3688 c two derivatives over diffetent matrices
3689 c gtae3e2 is derivative over i+3
3690         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3691 c ae3gte2 is derivative over i+2
3692         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3693         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3694 c three possible derivative over theta E matices
3695 c i+1
3696         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3697 c i+2
3698         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3699 c i+3
3700         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3702
3703         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3704         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3705         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3706         if (shield_mode.eq.0) then
3707         fac_shield(i)=1.0
3708         fac_shield(j)=1.0
3709 C        else
3710 C        fac_shield(i)=0.6
3711 C        fac_shield(j)=0.4
3712         endif
3713         eello_turn4=eello_turn4-(s1+s2+s3)
3714      &  *fac_shield(i)*fac_shield(j)
3715         eello_t4=-(s1+s2+s3)
3716      &  *fac_shield(i)*fac_shield(j)
3717 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3718         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3719      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3720 C Now derivative over shield:
3721           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3722      &  (shield_mode.gt.0)) then
3723 C          print *,i,j
3724
3725           do ilist=1,ishield_list(i)
3726            iresshield=shield_list(ilist,i)
3727            do k=1,3
3728            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3729 C     &      *2.0
3730            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3731      &              rlocshield
3732      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3733             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3734      &      +rlocshield
3735            enddo
3736           enddo
3737           do ilist=1,ishield_list(j)
3738            iresshield=shield_list(ilist,j)
3739            do k=1,3
3740            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3741 C     &     *2.0
3742            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3743      &              rlocshield
3744      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3745            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3746      &             +rlocshield
3747
3748            enddo
3749           enddo
3750
3751           do k=1,3
3752             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3753      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3754             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3755      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3756             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3757      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3758             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3759      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3760            enddo
3761            endif
3762 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3763 cd     &    ' eello_turn4_num',8*eello_turn4_num
3764 #ifdef NEWCORR
3765         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3766      &                  -(gs13+gsE13+gsEE1)*wturn4
3767      &  *fac_shield(i)*fac_shield(j)
3768         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3769      &                    -(gs23+gs21+gsEE2)*wturn4
3770      &  *fac_shield(i)*fac_shield(j)
3771
3772         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3773      &                    -(gs32+gsE31+gsEE3)*wturn4
3774      &  *fac_shield(i)*fac_shield(j)
3775
3776 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3777 c     &   gs2
3778 #endif
3779         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3780      &      'eturn4',i,j,-(s1+s2+s3)
3781 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3782 c     &    ' eello_turn4_num',8*eello_turn4_num
3783 C Derivatives in gamma(i)
3784         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3785         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3786         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3787         s1=scalar2(b1(1,i+2),auxvec(1))
3788         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3789         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3791      &  *fac_shield(i)*fac_shield(j)
3792 C Derivatives in gamma(i+1)
3793         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3794         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3795         s2=scalar2(b1(1,i+1),auxvec(1))
3796         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3797         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3798         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3799         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3800      &  *fac_shield(i)*fac_shield(j)
3801 C Derivatives in gamma(i+2)
3802         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3803         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3804         s1=scalar2(b1(1,i+2),auxvec(1))
3805         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3806         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3807         s2=scalar2(b1(1,i+1),auxvec(1))
3808         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3809         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3810         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3811         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3812      &  *fac_shield(i)*fac_shield(j)
3813         if (calc_grad) then
3814 C Cartesian derivatives
3815 C Derivatives of this turn contributions in DC(i+2)
3816         if (j.lt.nres-1) then
3817           do l=1,3
3818             a_temp(1,1)=agg(l,1)
3819             a_temp(1,2)=agg(l,2)
3820             a_temp(2,1)=agg(l,3)
3821             a_temp(2,2)=agg(l,4)
3822             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3823             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3824             s1=scalar2(b1(1,i+2),auxvec(1))
3825             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3826             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3827             s2=scalar2(b1(1,i+1),auxvec(1))
3828             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3829             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3830             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3831             ggg(l)=-(s1+s2+s3)
3832             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3833      &  *fac_shield(i)*fac_shield(j)
3834           enddo
3835         endif
3836 C Remaining derivatives of this turn contribution
3837         do l=1,3
3838           a_temp(1,1)=aggi(l,1)
3839           a_temp(1,2)=aggi(l,2)
3840           a_temp(2,1)=aggi(l,3)
3841           a_temp(2,2)=aggi(l,4)
3842           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3843           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3844           s1=scalar2(b1(1,i+2),auxvec(1))
3845           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3846           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3847           s2=scalar2(b1(1,i+1),auxvec(1))
3848           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3849           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3850           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3851           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3852      &  *fac_shield(i)*fac_shield(j)
3853           a_temp(1,1)=aggi1(l,1)
3854           a_temp(1,2)=aggi1(l,2)
3855           a_temp(2,1)=aggi1(l,3)
3856           a_temp(2,2)=aggi1(l,4)
3857           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3858           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3859           s1=scalar2(b1(1,i+2),auxvec(1))
3860           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3861           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3862           s2=scalar2(b1(1,i+1),auxvec(1))
3863           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3864           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3865           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3867      &  *fac_shield(i)*fac_shield(j)
3868           a_temp(1,1)=aggj(l,1)
3869           a_temp(1,2)=aggj(l,2)
3870           a_temp(2,1)=aggj(l,3)
3871           a_temp(2,2)=aggj(l,4)
3872           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874           s1=scalar2(b1(1,i+2),auxvec(1))
3875           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877           s2=scalar2(b1(1,i+1),auxvec(1))
3878           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3882      &  *fac_shield(i)*fac_shield(j)
3883           a_temp(1,1)=aggj1(l,1)
3884           a_temp(1,2)=aggj1(l,2)
3885           a_temp(2,1)=aggj1(l,3)
3886           a_temp(2,2)=aggj1(l,4)
3887           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3888           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3889           s1=scalar2(b1(1,i+2),auxvec(1))
3890           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3891           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3892           s2=scalar2(b1(1,i+1),auxvec(1))
3893           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3894           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3895           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3896 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3897           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3898      &  *fac_shield(i)*fac_shield(j)
3899         enddo
3900
3901         endif ! calc_grad
3902
3903       return
3904       end
3905 C-----------------------------------------------------------------------------
3906       subroutine vecpr(u,v,w)
3907       implicit real*8(a-h,o-z)
3908       dimension u(3),v(3),w(3)
3909       w(1)=u(2)*v(3)-u(3)*v(2)
3910       w(2)=-u(1)*v(3)+u(3)*v(1)
3911       w(3)=u(1)*v(2)-u(2)*v(1)
3912       return
3913       end
3914 C-----------------------------------------------------------------------------
3915       subroutine unormderiv(u,ugrad,unorm,ungrad)
3916 C This subroutine computes the derivatives of a normalized vector u, given
3917 C the derivatives computed without normalization conditions, ugrad. Returns
3918 C ungrad.
3919       implicit none
3920       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3921       double precision vec(3)
3922       double precision scalar
3923       integer i,j
3924 c      write (2,*) 'ugrad',ugrad
3925 c      write (2,*) 'u',u
3926       do i=1,3
3927         vec(i)=scalar(ugrad(1,i),u(1))
3928       enddo
3929 c      write (2,*) 'vec',vec
3930       do i=1,3
3931         do j=1,3
3932           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3933         enddo
3934       enddo
3935 c      write (2,*) 'ungrad',ungrad
3936       return
3937       end
3938 C-----------------------------------------------------------------------------
3939       subroutine escp(evdw2,evdw2_14)
3940 C
3941 C This subroutine calculates the excluded-volume interaction energy between
3942 C peptide-group centers and side chains and its gradient in virtual-bond and
3943 C side-chain vectors.
3944 C
3945       implicit real*8 (a-h,o-z)
3946       include 'DIMENSIONS'
3947       include 'DIMENSIONS.ZSCOPT'
3948       include 'COMMON.CONTROL'
3949       include 'COMMON.GEO'
3950       include 'COMMON.VAR'
3951       include 'COMMON.LOCAL'
3952       include 'COMMON.CHAIN'
3953       include 'COMMON.DERIV'
3954       include 'COMMON.INTERACT'
3955       include 'COMMON.FFIELD'
3956       include 'COMMON.IOUNITS'
3957       dimension ggg(3)
3958       evdw2=0.0D0
3959       evdw2_14=0.0d0
3960 cd    print '(a)','Enter ESCP'
3961 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3962 c     &  ' scal14',scal14
3963       do i=iatscp_s,iatscp_e
3964         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3965         iteli=itel(i)
3966 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3967 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3968         if (iteli.eq.0) goto 1225
3969         xi=0.5D0*(c(1,i)+c(1,i+1))
3970         yi=0.5D0*(c(2,i)+c(2,i+1))
3971         zi=0.5D0*(c(3,i)+c(3,i+1))
3972 C Returning the ith atom to box
3973           xi=mod(xi,boxxsize)
3974           if (xi.lt.0) xi=xi+boxxsize
3975           yi=mod(yi,boxysize)
3976           if (yi.lt.0) yi=yi+boxysize
3977           zi=mod(zi,boxzsize)
3978           if (zi.lt.0) zi=zi+boxzsize
3979         do iint=1,nscp_gr(i)
3980
3981         do j=iscpstart(i,iint),iscpend(i,iint)
3982           itypj=iabs(itype(j))
3983           if (itypj.eq.ntyp1) cycle
3984 C Uncomment following three lines for SC-p interactions
3985 c         xj=c(1,nres+j)-xi
3986 c         yj=c(2,nres+j)-yi
3987 c         zj=c(3,nres+j)-zi
3988 C Uncomment following three lines for Ca-p interactions
3989           xj=c(1,j)
3990           yj=c(2,j)
3991           zj=c(3,j)
3992 C returning the jth atom to box
3993           xj=mod(xj,boxxsize)
3994           if (xj.lt.0) xj=xj+boxxsize
3995           yj=mod(yj,boxysize)
3996           if (yj.lt.0) yj=yj+boxysize
3997           zj=mod(zj,boxzsize)
3998           if (zj.lt.0) zj=zj+boxzsize
3999       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4000       xj_safe=xj
4001       yj_safe=yj
4002       zj_safe=zj
4003       subchap=0
4004 C Finding the closest jth atom
4005       do xshift=-1,1
4006       do yshift=-1,1
4007       do zshift=-1,1
4008           xj=xj_safe+xshift*boxxsize
4009           yj=yj_safe+yshift*boxysize
4010           zj=zj_safe+zshift*boxzsize
4011           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4012           if(dist_temp.lt.dist_init) then
4013             dist_init=dist_temp
4014             xj_temp=xj
4015             yj_temp=yj
4016             zj_temp=zj
4017             subchap=1
4018           endif
4019        enddo
4020        enddo
4021        enddo
4022        if (subchap.eq.1) then
4023           xj=xj_temp-xi
4024           yj=yj_temp-yi
4025           zj=zj_temp-zi
4026        else
4027           xj=xj_safe-xi
4028           yj=yj_safe-yi
4029           zj=zj_safe-zi
4030        endif
4031           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4032 C sss is scaling function for smoothing the cutoff gradient otherwise
4033 C the gradient would not be continuouse
4034           sss=sscale(1.0d0/(dsqrt(rrij)))
4035           if (sss.le.0.0d0) cycle
4036           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4037           fac=rrij**expon2
4038           e1=fac*fac*aad(itypj,iteli)
4039           e2=fac*bad(itypj,iteli)
4040           if (iabs(j-i) .le. 2) then
4041             e1=scal14*e1
4042             e2=scal14*e2
4043             evdw2_14=evdw2_14+(e1+e2)*sss
4044           endif
4045           evdwij=e1+e2
4046 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4047 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4048 c     &       bad(itypj,iteli)
4049           evdw2=evdw2+evdwij*sss
4050           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4051      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4052      &       bad(itypj,iteli)
4053
4054           if (calc_grad) then
4055 C
4056 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4057 C
4058           fac=-(evdwij+e1)*rrij*sss
4059           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4060           ggg(1)=xj*fac
4061           ggg(2)=yj*fac
4062           ggg(3)=zj*fac
4063           if (j.lt.i) then
4064 cd          write (iout,*) 'j<i'
4065 C Uncomment following three lines for SC-p interactions
4066 c           do k=1,3
4067 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4068 c           enddo
4069           else
4070 cd          write (iout,*) 'j>i'
4071             do k=1,3
4072               ggg(k)=-ggg(k)
4073 C Uncomment following line for SC-p interactions
4074 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4075             enddo
4076           endif
4077           do k=1,3
4078             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4079           enddo
4080           kstart=min0(i+1,j)
4081           kend=max0(i-1,j-1)
4082 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4083 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4084           do k=kstart,kend
4085             do l=1,3
4086               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4087             enddo
4088           enddo
4089           endif ! calc_grad
4090         enddo
4091         enddo ! iint
4092  1225   continue
4093       enddo ! i
4094       do i=1,nct
4095         do j=1,3
4096           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4097           gradx_scp(j,i)=expon*gradx_scp(j,i)
4098         enddo
4099       enddo
4100 C******************************************************************************
4101 C
4102 C                              N O T E !!!
4103 C
4104 C To save time the factor EXPON has been extracted from ALL components
4105 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4106 C use!
4107 C
4108 C******************************************************************************
4109       return
4110       end
4111 C--------------------------------------------------------------------------
4112       subroutine edis(ehpb)
4113 C
4114 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4115 C
4116       implicit real*8 (a-h,o-z)
4117       include 'DIMENSIONS'
4118       include 'DIMENSIONS.ZSCOPT'
4119       include 'COMMON.SBRIDGE'
4120       include 'COMMON.CHAIN'
4121       include 'COMMON.DERIV'
4122       include 'COMMON.VAR'
4123       include 'COMMON.INTERACT'
4124       include 'COMMON.CONTROL'
4125       include 'COMMON.IOUNITS'
4126       dimension ggg(3),ggg_peak(3,1000)
4127       ehpb=0.0D0
4128       do i=1,3
4129        ggg(i)=0.0d0
4130       enddo
4131 c 8/21/18 AL: added explicit restraints on reference coords
4132 c      write (iout,*) "restr_on_coord",restr_on_coord
4133       if (restr_on_coord) then
4134
4135       do i=nnt,nct
4136         ecoor=0.0d0
4137         if (itype(i).eq.ntyp1) cycle
4138         do j=1,3
4139           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4140           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4141         enddo
4142         if (itype(i).ne.10) then
4143           do j=1,3
4144             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4145             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4146           enddo
4147         endif
4148         if (energy_dec) write (iout,*)
4149      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4150         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4151       enddo
4152
4153       endif
4154
4155 C      write (iout,*) ,"link_end",link_end,constr_dist
4156 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4157 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4158 c     &  " constr_dist",constr_dist
4159       if (link_end.eq.0.and.link_end_peak.eq.0) return
4160       do i=link_start_peak,link_end_peak
4161         ehpb_peak=0.0d0
4162 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4163 c     &   ipeak(1,i),ipeak(2,i)
4164         do ip=ipeak(1,i),ipeak(2,i)
4165           ii=ihpb_peak(ip)
4166           jj=jhpb_peak(ip)
4167           dd=dist(ii,jj)
4168           iip=ip-ipeak(1,i)+1
4169 C iii and jjj point to the residues for which the distance is assigned.
4170 c          if (ii.gt.nres) then
4171 c            iii=ii-nres
4172 c            jjj=jj-nres
4173 c          else
4174 c            iii=ii
4175 c            jjj=jj
4176 c          endif
4177           if (ii.gt.nres) then
4178             iii=ii-nres
4179           else
4180             iii=ii
4181           endif
4182           if (jj.gt.nres) then
4183             jjj=jj-nres
4184           else
4185             jjj=jj
4186           endif
4187           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4188           aux=dexp(-scal_peak*aux)
4189           ehpb_peak=ehpb_peak+aux
4190           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4191      &      forcon_peak(ip))*aux/dd
4192           do j=1,3
4193             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4194           enddo
4195           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4196      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4197      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4198         enddo
4199 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4200         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4201         do ip=ipeak(1,i),ipeak(2,i)
4202           iip=ip-ipeak(1,i)+1
4203           do j=1,3
4204             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4205           enddo
4206           ii=ihpb_peak(ip)
4207           jj=jhpb_peak(ip)
4208 C iii and jjj point to the residues for which the distance is assigned.
4209           if (ii.gt.nres) then
4210             iii=ii-nres
4211             jjj=jj-nres
4212           else
4213             iii=ii
4214             jjj=jj
4215           endif
4216           if (iii.lt.ii) then
4217             do j=1,3
4218               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4219             enddo
4220           endif
4221           if (jjj.lt.jj) then
4222             do j=1,3
4223               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4224             enddo
4225           endif
4226           do k=1,3
4227             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4228             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4229           enddo
4230         enddo
4231       enddo
4232       do i=link_start,link_end
4233 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4234 C CA-CA distance used in regularization of structure.
4235         ii=ihpb(i)
4236         jj=jhpb(i)
4237 C iii and jjj point to the residues for which the distance is assigned.
4238         if (ii.gt.nres) then
4239           iii=ii-nres
4240         else
4241           iii=ii
4242         endif
4243         if (jj.gt.nres) then
4244           jjj=jj-nres
4245         else
4246           jjj=jj
4247         endif
4248 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4249 c     &    dhpb(i),dhpb1(i),forcon(i)
4250 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4251 C    distance and angle dependent SS bond potential.
4252 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4253 C     & iabs(itype(jjj)).eq.1) then
4254 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4255 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4256         if (.not.dyn_ss .and. i.le.nss) then
4257 C 15/02/13 CC dynamic SSbond - additional check
4258           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4259      &        iabs(itype(jjj)).eq.1) then
4260            call ssbond_ene(iii,jjj,eij)
4261            ehpb=ehpb+2*eij
4262          endif
4263 cd          write (iout,*) "eij",eij
4264 cd   &   ' waga=',waga,' fac=',fac
4265 !        else if (ii.gt.nres .and. jj.gt.nres) then
4266         else
4267 C Calculate the distance between the two points and its difference from the
4268 C target distance.
4269           dd=dist(ii,jj)
4270           if (irestr_type(i).eq.11) then
4271             ehpb=ehpb+fordepth(i)!**4.0d0
4272      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4273             fac=fordepth(i)!**4.0d0
4274      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4275             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4276      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4277      &        ehpb,irestr_type(i)
4278           else if (irestr_type(i).eq.10) then
4279 c AL 6//19/2018 cross-link restraints
4280             xdis = 0.5d0*(dd/forcon(i))**2
4281             expdis = dexp(-xdis)
4282 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4283             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4284 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4285 c     &          " wboltzd",wboltzd
4286             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4287 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4288             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4289      &           *expdis/(aux*forcon(i)**2)
4290             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4291      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4292      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4293           else if (irestr_type(i).eq.2) then
4294 c Quartic restraints
4295             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4296             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4297      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4298      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4299             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4300           else
4301 c Quadratic restraints
4302             rdis=dd-dhpb(i)
4303 C Get the force constant corresponding to this distance.
4304             waga=forcon(i)
4305 C Calculate the contribution to energy.
4306             ehpb=ehpb+0.5d0*waga*rdis*rdis
4307             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4308      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4309      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4310 C
4311 C Evaluate gradient.
4312 C
4313             fac=waga*rdis/dd
4314           endif
4315 c Calculate Cartesian gradient
4316           do j=1,3
4317             ggg(j)=fac*(c(j,jj)-c(j,ii))
4318           enddo
4319 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4320 C If this is a SC-SC distance, we need to calculate the contributions to the
4321 C Cartesian gradient in the SC vectors (ghpbx).
4322           if (iii.lt.ii) then
4323             do j=1,3
4324               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4325             enddo
4326           endif
4327           if (jjj.lt.jj) then
4328             do j=1,3
4329               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4330             enddo
4331           endif
4332           do k=1,3
4333             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4334             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4335           enddo
4336         endif
4337       enddo
4338       return
4339       end
4340 C--------------------------------------------------------------------------
4341       subroutine ssbond_ene(i,j,eij)
4342 C
4343 C Calculate the distance and angle dependent SS-bond potential energy
4344 C using a free-energy function derived based on RHF/6-31G** ab initio
4345 C calculations of diethyl disulfide.
4346 C
4347 C A. Liwo and U. Kozlowska, 11/24/03
4348 C
4349       implicit real*8 (a-h,o-z)
4350       include 'DIMENSIONS'
4351       include 'DIMENSIONS.ZSCOPT'
4352       include 'COMMON.SBRIDGE'
4353       include 'COMMON.CHAIN'
4354       include 'COMMON.DERIV'
4355       include 'COMMON.LOCAL'
4356       include 'COMMON.INTERACT'
4357       include 'COMMON.VAR'
4358       include 'COMMON.IOUNITS'
4359       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4360       itypi=iabs(itype(i))
4361       xi=c(1,nres+i)
4362       yi=c(2,nres+i)
4363       zi=c(3,nres+i)
4364       dxi=dc_norm(1,nres+i)
4365       dyi=dc_norm(2,nres+i)
4366       dzi=dc_norm(3,nres+i)
4367       dsci_inv=dsc_inv(itypi)
4368       itypj=iabs(itype(j))
4369       dscj_inv=dsc_inv(itypj)
4370       xj=c(1,nres+j)-xi
4371       yj=c(2,nres+j)-yi
4372       zj=c(3,nres+j)-zi
4373       dxj=dc_norm(1,nres+j)
4374       dyj=dc_norm(2,nres+j)
4375       dzj=dc_norm(3,nres+j)
4376       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4377       rij=dsqrt(rrij)
4378       erij(1)=xj*rij
4379       erij(2)=yj*rij
4380       erij(3)=zj*rij
4381       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4382       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4383       om12=dxi*dxj+dyi*dyj+dzi*dzj
4384       do k=1,3
4385         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4386         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4387       enddo
4388       rij=1.0d0/rij
4389       deltad=rij-d0cm
4390       deltat1=1.0d0-om1
4391       deltat2=1.0d0+om2
4392       deltat12=om2-om1+2.0d0
4393       cosphi=om12-om1*om2
4394       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4395      &  +akct*deltad*deltat12
4396      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4397 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4398 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4399 c     &  " deltat12",deltat12," eij",eij
4400       ed=2*akcm*deltad+akct*deltat12
4401       pom1=akct*deltad
4402       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4403       eom1=-2*akth*deltat1-pom1-om2*pom2
4404       eom2= 2*akth*deltat2+pom1-om1*pom2
4405       eom12=pom2
4406       do k=1,3
4407         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4408       enddo
4409       do k=1,3
4410         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4411      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4412         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4413      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4414       enddo
4415 C
4416 C Calculate the components of the gradient in DC and X
4417 C
4418       do k=i,j-1
4419         do l=1,3
4420           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4421         enddo
4422       enddo
4423       return
4424       end
4425 C--------------------------------------------------------------------------
4426 c MODELLER restraint function
4427       subroutine e_modeller(ehomology_constr)
4428       implicit real*8 (a-h,o-z)
4429       include 'DIMENSIONS'
4430       include 'DIMENSIONS.ZSCOPT'
4431       include 'DIMENSIONS.FREE'
4432       integer nnn, i, j, k, ki, irec, l
4433       integer katy, odleglosci, test7
4434       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4435       real*8 distance(max_template),distancek(max_template),
4436      &    min_odl,godl(max_template),dih_diff(max_template)
4437
4438 c
4439 c     FP - 30/10/2014 Temporary specifications for homology restraints
4440 c
4441       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4442      &                 sgtheta
4443       double precision, dimension (maxres) :: guscdiff,usc_diff
4444       double precision, dimension (max_template) ::
4445      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4446      &           theta_diff
4447
4448       include 'COMMON.SBRIDGE'
4449       include 'COMMON.CHAIN'
4450       include 'COMMON.GEO'
4451       include 'COMMON.DERIV'
4452       include 'COMMON.LOCAL'
4453       include 'COMMON.INTERACT'
4454       include 'COMMON.VAR'
4455       include 'COMMON.IOUNITS'
4456       include 'COMMON.CONTROL'
4457       include 'COMMON.HOMRESTR'
4458       include 'COMMON.HOMOLOGY'
4459       include 'COMMON.SETUP'
4460       include 'COMMON.NAMES'
4461
4462       do i=1,max_template
4463         distancek(i)=9999999.9
4464       enddo
4465
4466       odleg=0.0d0
4467
4468 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4469 c function)
4470 C AL 5/2/14 - Introduce list of restraints
4471 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4472 #ifdef DEBUG
4473       write(iout,*) "------- dist restrs start -------"
4474 #endif
4475       do ii = link_start_homo,link_end_homo
4476          i = ires_homo(ii)
4477          j = jres_homo(ii)
4478          dij=dist(i,j)
4479 c        write (iout,*) "dij(",i,j,") =",dij
4480          nexl=0
4481          do k=1,constr_homology
4482            if(.not.l_homo(k,ii)) then
4483               nexl=nexl+1
4484               cycle
4485            endif
4486            distance(k)=odl(k,ii)-dij
4487 c          write (iout,*) "distance(",k,") =",distance(k)
4488 c
4489 c          For Gaussian-type Urestr
4490 c
4491            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4492 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4493 c          write (iout,*) "distancek(",k,") =",distancek(k)
4494 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4495 c
4496 c          For Lorentzian-type Urestr
4497 c
4498            if (waga_dist.lt.0.0d0) then
4499               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4500               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4501      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4502            endif
4503          enddo
4504
4505 c         min_odl=minval(distancek)
4506          do kk=1,constr_homology
4507           if(l_homo(kk,ii)) then
4508             min_odl=distancek(kk)
4509             exit
4510           endif
4511          enddo
4512          do kk=1,constr_homology
4513           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4514      &              min_odl=distancek(kk)
4515          enddo
4516 c        write (iout,* )"min_odl",min_odl
4517 #ifdef DEBUG
4518          write (iout,*) "ij dij",i,j,dij
4519          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4520          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4521          write (iout,* )"min_odl",min_odl
4522 #endif
4523 #ifdef OLDRESTR
4524          odleg2=0.0d0
4525 #else
4526          if (waga_dist.ge.0.0d0) then
4527            odleg2=nexl
4528          else
4529            odleg2=0.0d0
4530          endif
4531 #endif
4532          do k=1,constr_homology
4533 c Nie wiem po co to liczycie jeszcze raz!
4534 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4535 c     &              (2*(sigma_odl(i,j,k))**2))
4536            if(.not.l_homo(k,ii)) cycle
4537            if (waga_dist.ge.0.0d0) then
4538 c
4539 c          For Gaussian-type Urestr
4540 c
4541             godl(k)=dexp(-distancek(k)+min_odl)
4542             odleg2=odleg2+godl(k)
4543 c
4544 c          For Lorentzian-type Urestr
4545 c
4546            else
4547             odleg2=odleg2+distancek(k)
4548            endif
4549
4550 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4551 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4552 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4553 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4554
4555          enddo
4556 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4557 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4558 #ifdef DEBUG
4559          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4560          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4561 #endif
4562            if (waga_dist.ge.0.0d0) then
4563 c
4564 c          For Gaussian-type Urestr
4565 c
4566               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4567 c
4568 c          For Lorentzian-type Urestr
4569 c
4570            else
4571               odleg=odleg+odleg2/constr_homology
4572            endif
4573 c
4574 #ifdef GRAD
4575 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4576 c Gradient
4577 c
4578 c          For Gaussian-type Urestr
4579 c
4580          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4581          sum_sgodl=0.0d0
4582          do k=1,constr_homology
4583 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4584 c     &           *waga_dist)+min_odl
4585 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4586 c
4587          if(.not.l_homo(k,ii)) cycle
4588          if (waga_dist.ge.0.0d0) then
4589 c          For Gaussian-type Urestr
4590 c
4591            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4592 c
4593 c          For Lorentzian-type Urestr
4594 c
4595          else
4596            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4597      &           sigma_odlir(k,ii)**2)**2)
4598          endif
4599            sum_sgodl=sum_sgodl+sgodl
4600
4601 c            sgodl2=sgodl2+sgodl
4602 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4603 c      write(iout,*) "constr_homology=",constr_homology
4604 c      write(iout,*) i, j, k, "TEST K"
4605          enddo
4606          if (waga_dist.ge.0.0d0) then
4607 c
4608 c          For Gaussian-type Urestr
4609 c
4610             grad_odl3=waga_homology(iset)*waga_dist
4611      &                *sum_sgodl/(sum_godl*dij)
4612 c
4613 c          For Lorentzian-type Urestr
4614 c
4615          else
4616 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4617 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4618             grad_odl3=-waga_homology(iset)*waga_dist*
4619      &                sum_sgodl/(constr_homology*dij)
4620          endif
4621 c
4622 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4623
4624
4625 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4626 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4627 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4628
4629 ccc      write(iout,*) godl, sgodl, grad_odl3
4630
4631 c          grad_odl=grad_odl+grad_odl3
4632
4633          do jik=1,3
4634             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4635 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4636 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4637 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4638             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4639             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4640 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4641 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4642 c         if (i.eq.25.and.j.eq.27) then
4643 c         write(iout,*) "jik",jik,"i",i,"j",j
4644 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4645 c         write(iout,*) "grad_odl3",grad_odl3
4646 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4647 c         write(iout,*) "ggodl",ggodl
4648 c         write(iout,*) "ghpbc(",jik,i,")",
4649 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4650 c     &                 ghpbc(jik,j)
4651 c         endif
4652          enddo
4653 #endif
4654 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4655 ccc     & dLOG(odleg2),"-odleg=", -odleg
4656
4657       enddo ! ii-loop for dist
4658 #ifdef DEBUG
4659       write(iout,*) "------- dist restrs end -------"
4660 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4661 c    &     waga_d.eq.1.0d0) call sum_gradient
4662 #endif
4663 c Pseudo-energy and gradient from dihedral-angle restraints from
4664 c homology templates
4665 c      write (iout,*) "End of distance loop"
4666 c      call flush(iout)
4667       kat=0.0d0
4668 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4669 #ifdef DEBUG
4670       write(iout,*) "------- dih restrs start -------"
4671       do i=idihconstr_start_homo,idihconstr_end_homo
4672         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4673       enddo
4674 #endif
4675       do i=idihconstr_start_homo,idihconstr_end_homo
4676         kat2=0.0d0
4677 c        betai=beta(i,i+1,i+2,i+3)
4678         betai = phi(i)
4679 c       write (iout,*) "betai =",betai
4680         do k=1,constr_homology
4681           dih_diff(k)=pinorm(dih(k,i)-betai)
4682 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4683 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4684 c     &                                   -(6.28318-dih_diff(i,k))
4685 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4686 c     &                                   6.28318+dih_diff(i,k)
4687 #ifdef OLD_DIHED
4688           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4689 #else
4690           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4691 #endif
4692 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4693           gdih(k)=dexp(kat3)
4694           kat2=kat2+gdih(k)
4695 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4696 c          write(*,*)""
4697         enddo
4698 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4699 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4700 #ifdef DEBUG
4701         write (iout,*) "i",i," betai",betai," kat2",kat2
4702         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4703 #endif
4704         if (kat2.le.1.0d-14) cycle
4705         kat=kat-dLOG(kat2/constr_homology)
4706 c       write (iout,*) "kat",kat ! sum of -ln-s
4707
4708 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4709 ccc     & dLOG(kat2), "-kat=", -kat
4710
4711 #ifdef GRAD
4712 c ----------------------------------------------------------------------
4713 c Gradient
4714 c ----------------------------------------------------------------------
4715
4716         sum_gdih=kat2
4717         sum_sgdih=0.0d0
4718         do k=1,constr_homology
4719 #ifdef OLD_DIHED
4720           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4721 #else
4722           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4723 #endif
4724 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4725           sum_sgdih=sum_sgdih+sgdih
4726         enddo
4727 c       grad_dih3=sum_sgdih/sum_gdih
4728         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4729
4730 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4731 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4732 ccc     & gloc(nphi+i-3,icg)
4733         gloc(i,icg)=gloc(i,icg)+grad_dih3
4734 c        if (i.eq.25) then
4735 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4736 c        endif
4737 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4738 ccc     & gloc(nphi+i-3,icg)
4739 #endif
4740       enddo ! i-loop for dih
4741 #ifdef DEBUG
4742       write(iout,*) "------- dih restrs end -------"
4743 #endif
4744
4745 c Pseudo-energy and gradient for theta angle restraints from
4746 c homology templates
4747 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4748 c adapted
4749
4750 c
4751 c     For constr_homology reference structures (FP)
4752 c
4753 c     Uconst_back_tot=0.0d0
4754       Eval=0.0d0
4755       Erot=0.0d0
4756 c     Econstr_back legacy
4757 #ifdef GRAD
4758       do i=1,nres
4759 c     do i=ithet_start,ithet_end
4760        dutheta(i)=0.0d0
4761 c     enddo
4762 c     do i=loc_start,loc_end
4763         do j=1,3
4764           duscdiff(j,i)=0.0d0
4765           duscdiffx(j,i)=0.0d0
4766         enddo
4767       enddo
4768 #endif
4769 c
4770 c     do iref=1,nref
4771 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4772 c     write (iout,*) "waga_theta",waga_theta
4773       if (waga_theta.gt.0.0d0) then
4774 #ifdef DEBUG
4775       write (iout,*) "usampl",usampl
4776       write(iout,*) "------- theta restrs start -------"
4777 c     do i=ithet_start,ithet_end
4778 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4779 c     enddo
4780 #endif
4781 c     write (iout,*) "maxres",maxres,"nres",nres
4782
4783       do i=ithet_start,ithet_end
4784 c
4785 c     do i=1,nfrag_back
4786 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4787 c
4788 c Deviation of theta angles wrt constr_homology ref structures
4789 c
4790         utheta_i=0.0d0 ! argument of Gaussian for single k
4791         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4792 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4793 c       over residues in a fragment
4794 c       write (iout,*) "theta(",i,")=",theta(i)
4795         do k=1,constr_homology
4796 c
4797 c         dtheta_i=theta(j)-thetaref(j,iref)
4798 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4799           theta_diff(k)=thetatpl(k,i)-theta(i)
4800 c
4801           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4802 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4803           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4804           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4805 c         Gradient for single Gaussian restraint in subr Econstr_back
4806 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4807 c
4808         enddo
4809 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4810 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4811
4812 c
4813 #ifdef GRAD
4814 c         Gradient for multiple Gaussian restraint
4815         sum_gtheta=gutheta_i
4816         sum_sgtheta=0.0d0
4817         do k=1,constr_homology
4818 c        New generalized expr for multiple Gaussian from Econstr_back
4819          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4820 c
4821 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4822           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4823         enddo
4824 c
4825 c       Final value of gradient using same var as in Econstr_back
4826         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4827      &               *waga_homology(iset)
4828 c       dutheta(i)=sum_sgtheta/sum_gtheta
4829 c
4830 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4831 #endif
4832         Eval=Eval-dLOG(gutheta_i/constr_homology)
4833 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4834 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4835 c       Uconst_back=Uconst_back+utheta(i)
4836       enddo ! (i-loop for theta)
4837 #ifdef DEBUG
4838       write(iout,*) "------- theta restrs end -------"
4839 #endif
4840       endif
4841 c
4842 c Deviation of local SC geometry
4843 c
4844 c Separation of two i-loops (instructed by AL - 11/3/2014)
4845 c
4846 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4847 c     write (iout,*) "waga_d",waga_d
4848
4849 #ifdef DEBUG
4850       write(iout,*) "------- SC restrs start -------"
4851       write (iout,*) "Initial duscdiff,duscdiffx"
4852       do i=loc_start,loc_end
4853         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4854      &                 (duscdiffx(jik,i),jik=1,3)
4855       enddo
4856 #endif
4857       do i=loc_start,loc_end
4858         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4859         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4860 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4861 c       write(iout,*) "xxtab, yytab, zztab"
4862 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4863         do k=1,constr_homology
4864 c
4865           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4866 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4867           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4868           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4869 c         write(iout,*) "dxx, dyy, dzz"
4870 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4871 c
4872           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4873 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4874 c         uscdiffk(k)=usc_diff(i)
4875           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4876           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4877 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4878 c     &      xxref(j),yyref(j),zzref(j)
4879         enddo
4880 c
4881 c       Gradient
4882 c
4883 c       Generalized expression for multiple Gaussian acc to that for a single
4884 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4885 c
4886 c       Original implementation
4887 c       sum_guscdiff=guscdiff(i)
4888 c
4889 c       sum_sguscdiff=0.0d0
4890 c       do k=1,constr_homology
4891 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4892 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4893 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4894 c       enddo
4895 c
4896 c       Implementation of new expressions for gradient (Jan. 2015)
4897 c
4898 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4899 #ifdef GRAD
4900         do k=1,constr_homology
4901 c
4902 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4903 c       before. Now the drivatives should be correct
4904 c
4905           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4906 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4907           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4908           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4909 c
4910 c         New implementation
4911 c
4912           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4913      &                 sigma_d(k,i) ! for the grad wrt r'
4914 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4915 c
4916 c
4917 c        New implementation
4918          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4919          do jik=1,3
4920             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4921      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4922      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4923             duscdiff(jik,i)=duscdiff(jik,i)+
4924      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4925      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4926             duscdiffx(jik,i)=duscdiffx(jik,i)+
4927      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4928      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4929 c
4930 #ifdef DEBUG
4931              write(iout,*) "jik",jik,"i",i
4932              write(iout,*) "dxx, dyy, dzz"
4933              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4934              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4935 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4936 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4937 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4938 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4939 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4940 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4941 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4942 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4943 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4944 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4945 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4946 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4947 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4948 c            endif
4949 #endif
4950          enddo
4951         enddo
4952 #endif
4953 c
4954 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4955 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4956 c
4957 c        write (iout,*) i," uscdiff",uscdiff(i)
4958 c
4959 c Put together deviations from local geometry
4960
4961 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4962 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4963         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4964 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4965 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4966 c       Uconst_back=Uconst_back+usc_diff(i)
4967 c
4968 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4969 c
4970 c     New implment: multiplied by sum_sguscdiff
4971 c
4972
4973       enddo ! (i-loop for dscdiff)
4974
4975 c      endif
4976
4977 #ifdef DEBUG
4978       write(iout,*) "------- SC restrs end -------"
4979         write (iout,*) "------ After SC loop in e_modeller ------"
4980         do i=loc_start,loc_end
4981          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4982          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4983         enddo
4984       if (waga_theta.eq.1.0d0) then
4985       write (iout,*) "in e_modeller after SC restr end: dutheta"
4986       do i=ithet_start,ithet_end
4987         write (iout,*) i,dutheta(i)
4988       enddo
4989       endif
4990       if (waga_d.eq.1.0d0) then
4991       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4992       do i=1,nres
4993         write (iout,*) i,(duscdiff(j,i),j=1,3)
4994         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4995       enddo
4996       endif
4997 #endif
4998
4999 c Total energy from homology restraints
5000 #ifdef DEBUG
5001       write (iout,*) "odleg",odleg," kat",kat
5002       write (iout,*) "odleg",odleg," kat",kat
5003       write (iout,*) "Eval",Eval," Erot",Erot
5004       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5005       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5006       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5007 #endif
5008 c
5009 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5010 c
5011 c     ehomology_constr=odleg+kat
5012 c
5013 c     For Lorentzian-type Urestr
5014 c
5015
5016       if (waga_dist.ge.0.0d0) then
5017 c
5018 c          For Gaussian-type Urestr
5019 c
5020 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5021 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5022         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5023      &              waga_theta*Eval+waga_d*Erot
5024 c     write (iout,*) "ehomology_constr=",ehomology_constr
5025       else
5026 c
5027 c          For Lorentzian-type Urestr
5028 c
5029 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5030 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5031         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5032      &              waga_theta*Eval+waga_d*Erot
5033 c     write (iout,*) "ehomology_constr=",ehomology_constr
5034       endif
5035 #ifdef DEBUG
5036       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5037      & "Eval",waga_theta,eval,
5038      &   "Erot",waga_d,Erot
5039       write (iout,*) "ehomology_constr",ehomology_constr
5040 #endif
5041       return
5042
5043   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5044   747 format(a12,i4,i4,i4,f8.3,f8.3)
5045   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5046   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5047   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5048      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5049       end
5050 c-----------------------------------------------------------------------
5051       subroutine ebond(estr)
5052 c
5053 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5054 c
5055       implicit real*8 (a-h,o-z)
5056       include 'DIMENSIONS'
5057       include 'DIMENSIONS.ZSCOPT'
5058       include 'COMMON.LOCAL'
5059       include 'COMMON.GEO'
5060       include 'COMMON.INTERACT'
5061       include 'COMMON.DERIV'
5062       include 'COMMON.VAR'
5063       include 'COMMON.CHAIN'
5064       include 'COMMON.IOUNITS'
5065       include 'COMMON.NAMES'
5066       include 'COMMON.FFIELD'
5067       include 'COMMON.CONTROL'
5068       double precision u(3),ud(3)
5069       estr=0.0d0
5070       estr1=0.0d0
5071 c      write (iout,*) "distchainmax",distchainmax
5072       do i=nnt+1,nct
5073         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5074 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5075 C          do j=1,3
5076 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5077 C     &      *dc(j,i-1)/vbld(i)
5078 C          enddo
5079 C          if (energy_dec) write(iout,*)
5080 C     &       "estr1",i,vbld(i),distchainmax,
5081 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5082 C        else
5083          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5084         diff = vbld(i)-vbldpDUM
5085 C         write(iout,*) i,diff
5086          else
5087           diff = vbld(i)-vbldp0
5088 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5089          endif
5090           estr=estr+diff*diff
5091           do j=1,3
5092             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5093           enddo
5094 C        endif
5095 C        write (iout,'(a7,i5,4f7.3)')
5096 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5097       enddo
5098       estr=0.5d0*AKP*estr+estr1
5099 c
5100 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5101 c
5102       do i=nnt,nct
5103         iti=iabs(itype(i))
5104         if (iti.ne.10 .and. iti.ne.ntyp1) then
5105           nbi=nbondterm(iti)
5106           if (nbi.eq.1) then
5107             diff=vbld(i+nres)-vbldsc0(1,iti)
5108 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5109 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5110             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5111             do j=1,3
5112               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5113             enddo
5114           else
5115             do j=1,nbi
5116               diff=vbld(i+nres)-vbldsc0(j,iti)
5117               ud(j)=aksc(j,iti)*diff
5118               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5119             enddo
5120             uprod=u(1)
5121             do j=2,nbi
5122               uprod=uprod*u(j)
5123             enddo
5124             usum=0.0d0
5125             usumsqder=0.0d0
5126             do j=1,nbi
5127               uprod1=1.0d0
5128               uprod2=1.0d0
5129               do k=1,nbi
5130                 if (k.ne.j) then
5131                   uprod1=uprod1*u(k)
5132                   uprod2=uprod2*u(k)*u(k)
5133                 endif
5134               enddo
5135               usum=usum+uprod1
5136               usumsqder=usumsqder+ud(j)*uprod2
5137             enddo
5138 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5139 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5140             estr=estr+uprod/usum
5141             do j=1,3
5142              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5143             enddo
5144           endif
5145         endif
5146       enddo
5147       return
5148       end
5149 #ifdef CRYST_THETA
5150 C--------------------------------------------------------------------------
5151       subroutine ebend(etheta,ethetacnstr)
5152 C
5153 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5154 C angles gamma and its derivatives in consecutive thetas and gammas.
5155 C
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'DIMENSIONS.ZSCOPT'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.GEO'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.VAR'
5164       include 'COMMON.CHAIN'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.NAMES'
5167       include 'COMMON.FFIELD'
5168       include 'COMMON.TORCNSTR'
5169       common /calcthet/ term1,term2,termm,diffak,ratak,
5170      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5171      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5172       double precision y(2),z(2)
5173       delta=0.02d0*pi
5174 c      time11=dexp(-2*time)
5175 c      time12=1.0d0
5176       etheta=0.0D0
5177 c      write (iout,*) "nres",nres
5178 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5179 c      write (iout,*) ithet_start,ithet_end
5180       do i=ithet_start,ithet_end
5181 C        if (itype(i-1).eq.ntyp1) cycle
5182         if (i.le.2) cycle
5183         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5184      &  .or.itype(i).eq.ntyp1) cycle
5185 C Zero the energy function and its derivative at 0 or pi.
5186         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5187         it=itype(i-1)
5188         ichir1=isign(1,itype(i-2))
5189         ichir2=isign(1,itype(i))
5190          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5191          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5192          if (itype(i-1).eq.10) then
5193           itype1=isign(10,itype(i-2))
5194           ichir11=isign(1,itype(i-2))
5195           ichir12=isign(1,itype(i-2))
5196           itype2=isign(10,itype(i))
5197           ichir21=isign(1,itype(i))
5198           ichir22=isign(1,itype(i))
5199          endif
5200          if (i.eq.3) then
5201           y(1)=0.0D0
5202           y(2)=0.0D0
5203           else
5204
5205         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5206 #ifdef OSF
5207           phii=phi(i)
5208 c          icrc=0
5209 c          call proc_proc(phii,icrc)
5210           if (icrc.eq.1) phii=150.0
5211 #else
5212           phii=phi(i)
5213 #endif
5214           y(1)=dcos(phii)
5215           y(2)=dsin(phii)
5216         else
5217           y(1)=0.0D0
5218           y(2)=0.0D0
5219         endif
5220         endif
5221         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5222 #ifdef OSF
5223           phii1=phi(i+1)
5224 c          icrc=0
5225 c          call proc_proc(phii1,icrc)
5226           if (icrc.eq.1) phii1=150.0
5227           phii1=pinorm(phii1)
5228           z(1)=cos(phii1)
5229 #else
5230           phii1=phi(i+1)
5231           z(1)=dcos(phii1)
5232 #endif
5233           z(2)=dsin(phii1)
5234         else
5235           z(1)=0.0D0
5236           z(2)=0.0D0
5237         endif
5238 C Calculate the "mean" value of theta from the part of the distribution
5239 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5240 C In following comments this theta will be referred to as t_c.
5241         thet_pred_mean=0.0d0
5242         do k=1,2
5243             athetk=athet(k,it,ichir1,ichir2)
5244             bthetk=bthet(k,it,ichir1,ichir2)
5245           if (it.eq.10) then
5246              athetk=athet(k,itype1,ichir11,ichir12)
5247              bthetk=bthet(k,itype2,ichir21,ichir22)
5248           endif
5249           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5250         enddo
5251 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5252         dthett=thet_pred_mean*ssd
5253         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5254 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5255 C Derivatives of the "mean" values in gamma1 and gamma2.
5256         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5257      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5258          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5259      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5260          if (it.eq.10) then
5261       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5262      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5263         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5264      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5265          endif
5266         if (theta(i).gt.pi-delta) then
5267           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5268      &         E_tc0)
5269           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5270           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5271           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5272      &        E_theta)
5273           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5274      &        E_tc)
5275         else if (theta(i).lt.delta) then
5276           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5277           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5278           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5279      &        E_theta)
5280           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5281           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5282      &        E_tc)
5283         else
5284           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5285      &        E_theta,E_tc)
5286         endif
5287         etheta=etheta+ethetai
5288 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5289 c     &      'ebend',i,ethetai,theta(i),itype(i)
5290 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5291 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5292         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5293         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5294         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5295 c 1215   continue
5296       enddo
5297       ethetacnstr=0.0d0
5298 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5299       do i=1,ntheta_constr
5300         itheta=itheta_constr(i)
5301         thetiii=theta(itheta)
5302         difi=pinorm(thetiii-theta_constr0(i))
5303         if (difi.gt.theta_drange(i)) then
5304           difi=difi-theta_drange(i)
5305           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5306           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5307      &    +for_thet_constr(i)*difi**3
5308         else if (difi.lt.-drange(i)) then
5309           difi=difi+drange(i)
5310           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5311           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5312      &    +for_thet_constr(i)*difi**3
5313         else
5314           difi=0.0
5315         endif
5316 C       if (energy_dec) then
5317 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5318 C     &    i,itheta,rad2deg*thetiii,
5319 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5320 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5321 C     &    gloc(itheta+nphi-2,icg)
5322 C        endif
5323       enddo
5324 C Ufff.... We've done all this!!!
5325       return
5326       end
5327 C---------------------------------------------------------------------------
5328       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5329      &     E_tc)
5330       implicit real*8 (a-h,o-z)
5331       include 'DIMENSIONS'
5332       include 'COMMON.LOCAL'
5333       include 'COMMON.IOUNITS'
5334       common /calcthet/ term1,term2,termm,diffak,ratak,
5335      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5336      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5337 C Calculate the contributions to both Gaussian lobes.
5338 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5339 C The "polynomial part" of the "standard deviation" of this part of
5340 C the distribution.
5341         sig=polthet(3,it)
5342         do j=2,0,-1
5343           sig=sig*thet_pred_mean+polthet(j,it)
5344         enddo
5345 C Derivative of the "interior part" of the "standard deviation of the"
5346 C gamma-dependent Gaussian lobe in t_c.
5347         sigtc=3*polthet(3,it)
5348         do j=2,1,-1
5349           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5350         enddo
5351         sigtc=sig*sigtc
5352 C Set the parameters of both Gaussian lobes of the distribution.
5353 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5354         fac=sig*sig+sigc0(it)
5355         sigcsq=fac+fac
5356         sigc=1.0D0/sigcsq
5357 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5358         sigsqtc=-4.0D0*sigcsq*sigtc
5359 c       print *,i,sig,sigtc,sigsqtc
5360 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5361         sigtc=-sigtc/(fac*fac)
5362 C Following variable is sigma(t_c)**(-2)
5363         sigcsq=sigcsq*sigcsq
5364         sig0i=sig0(it)
5365         sig0inv=1.0D0/sig0i**2
5366         delthec=thetai-thet_pred_mean
5367         delthe0=thetai-theta0i
5368         term1=-0.5D0*sigcsq*delthec*delthec
5369         term2=-0.5D0*sig0inv*delthe0*delthe0
5370 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5371 C NaNs in taking the logarithm. We extract the largest exponent which is added
5372 C to the energy (this being the log of the distribution) at the end of energy
5373 C term evaluation for this virtual-bond angle.
5374         if (term1.gt.term2) then
5375           termm=term1
5376           term2=dexp(term2-termm)
5377           term1=1.0d0
5378         else
5379           termm=term2
5380           term1=dexp(term1-termm)
5381           term2=1.0d0
5382         endif
5383 C The ratio between the gamma-independent and gamma-dependent lobes of
5384 C the distribution is a Gaussian function of thet_pred_mean too.
5385         diffak=gthet(2,it)-thet_pred_mean
5386         ratak=diffak/gthet(3,it)**2
5387         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5388 C Let's differentiate it in thet_pred_mean NOW.
5389         aktc=ak*ratak
5390 C Now put together the distribution terms to make complete distribution.
5391         termexp=term1+ak*term2
5392         termpre=sigc+ak*sig0i
5393 C Contribution of the bending energy from this theta is just the -log of
5394 C the sum of the contributions from the two lobes and the pre-exponential
5395 C factor. Simple enough, isn't it?
5396         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5397 C NOW the derivatives!!!
5398 C 6/6/97 Take into account the deformation.
5399         E_theta=(delthec*sigcsq*term1
5400      &       +ak*delthe0*sig0inv*term2)/termexp
5401         E_tc=((sigtc+aktc*sig0i)/termpre
5402      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5403      &       aktc*term2)/termexp)
5404       return
5405       end
5406 c-----------------------------------------------------------------------------
5407       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5408       implicit real*8 (a-h,o-z)
5409       include 'DIMENSIONS'
5410       include 'COMMON.LOCAL'
5411       include 'COMMON.IOUNITS'
5412       common /calcthet/ term1,term2,termm,diffak,ratak,
5413      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5414      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5415       delthec=thetai-thet_pred_mean
5416       delthe0=thetai-theta0i
5417 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5418       t3 = thetai-thet_pred_mean
5419       t6 = t3**2
5420       t9 = term1
5421       t12 = t3*sigcsq
5422       t14 = t12+t6*sigsqtc
5423       t16 = 1.0d0
5424       t21 = thetai-theta0i
5425       t23 = t21**2
5426       t26 = term2
5427       t27 = t21*t26
5428       t32 = termexp
5429       t40 = t32**2
5430       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5431      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5432      & *(-t12*t9-ak*sig0inv*t27)
5433       return
5434       end
5435 #else
5436 C--------------------------------------------------------------------------
5437       subroutine ebend(etheta)
5438 C
5439 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5440 C angles gamma and its derivatives in consecutive thetas and gammas.
5441 C ab initio-derived potentials from
5442 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5443 C
5444       implicit real*8 (a-h,o-z)
5445       include 'DIMENSIONS'
5446       include 'DIMENSIONS.ZSCOPT'
5447       include 'COMMON.LOCAL'
5448       include 'COMMON.GEO'
5449       include 'COMMON.INTERACT'
5450       include 'COMMON.DERIV'
5451       include 'COMMON.VAR'
5452       include 'COMMON.CHAIN'
5453       include 'COMMON.IOUNITS'
5454       include 'COMMON.NAMES'
5455       include 'COMMON.FFIELD'
5456       include 'COMMON.CONTROL'
5457       include 'COMMON.TORCNSTR'
5458       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5459      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5460      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5461      & sinph1ph2(maxdouble,maxdouble)
5462       logical lprn /.false./, lprn1 /.false./
5463       etheta=0.0D0
5464 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5465       do i=ithet_start,ithet_end
5466 C         if (i.eq.2) cycle
5467 C        if (itype(i-1).eq.ntyp1) cycle
5468         if (i.le.2) cycle
5469         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5470      &  .or.itype(i).eq.ntyp1) cycle
5471         if (iabs(itype(i+1)).eq.20) iblock=2
5472         if (iabs(itype(i+1)).ne.20) iblock=1
5473         dethetai=0.0d0
5474         dephii=0.0d0
5475         dephii1=0.0d0
5476         theti2=0.5d0*theta(i)
5477         ityp2=ithetyp((itype(i-1)))
5478         do k=1,nntheterm
5479           coskt(k)=dcos(k*theti2)
5480           sinkt(k)=dsin(k*theti2)
5481         enddo
5482         if (i.eq.3) then
5483           phii=0.0d0
5484           ityp1=nthetyp+1
5485           do k=1,nsingle
5486             cosph1(k)=0.0d0
5487             sinph1(k)=0.0d0
5488           enddo
5489         else
5490         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5491 #ifdef OSF
5492           phii=phi(i)
5493           if (phii.ne.phii) phii=150.0
5494 #else
5495           phii=phi(i)
5496 #endif
5497           ityp1=ithetyp((itype(i-2)))
5498           do k=1,nsingle
5499             cosph1(k)=dcos(k*phii)
5500             sinph1(k)=dsin(k*phii)
5501           enddo
5502         else
5503           phii=0.0d0
5504 c          ityp1=nthetyp+1
5505           do k=1,nsingle
5506             ityp1=ithetyp((itype(i-2)))
5507             cosph1(k)=0.0d0
5508             sinph1(k)=0.0d0
5509           enddo
5510         endif
5511         endif
5512         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5513 #ifdef OSF
5514           phii1=phi(i+1)
5515           if (phii1.ne.phii1) phii1=150.0
5516           phii1=pinorm(phii1)
5517 #else
5518           phii1=phi(i+1)
5519 #endif
5520           ityp3=ithetyp((itype(i)))
5521           do k=1,nsingle
5522             cosph2(k)=dcos(k*phii1)
5523             sinph2(k)=dsin(k*phii1)
5524           enddo
5525         else
5526           phii1=0.0d0
5527 c          ityp3=nthetyp+1
5528           ityp3=ithetyp((itype(i)))
5529           do k=1,nsingle
5530             cosph2(k)=0.0d0
5531             sinph2(k)=0.0d0
5532           enddo
5533         endif
5534 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5535 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5536 c        call flush(iout)
5537         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5538         do k=1,ndouble
5539           do l=1,k-1
5540             ccl=cosph1(l)*cosph2(k-l)
5541             ssl=sinph1(l)*sinph2(k-l)
5542             scl=sinph1(l)*cosph2(k-l)
5543             csl=cosph1(l)*sinph2(k-l)
5544             cosph1ph2(l,k)=ccl-ssl
5545             cosph1ph2(k,l)=ccl+ssl
5546             sinph1ph2(l,k)=scl+csl
5547             sinph1ph2(k,l)=scl-csl
5548           enddo
5549         enddo
5550         if (lprn) then
5551         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5552      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5553         write (iout,*) "coskt and sinkt"
5554         do k=1,nntheterm
5555           write (iout,*) k,coskt(k),sinkt(k)
5556         enddo
5557         endif
5558         do k=1,ntheterm
5559           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5560           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5561      &      *coskt(k)
5562           if (lprn)
5563      &    write (iout,*) "k",k,"
5564      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5565      &     " ethetai",ethetai
5566         enddo
5567         if (lprn) then
5568         write (iout,*) "cosph and sinph"
5569         do k=1,nsingle
5570           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5571         enddo
5572         write (iout,*) "cosph1ph2 and sinph2ph2"
5573         do k=2,ndouble
5574           do l=1,k-1
5575             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5576      &         sinph1ph2(l,k),sinph1ph2(k,l)
5577           enddo
5578         enddo
5579         write(iout,*) "ethetai",ethetai
5580         endif
5581         do m=1,ntheterm2
5582           do k=1,nsingle
5583             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5584      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5585      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5586      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5587             ethetai=ethetai+sinkt(m)*aux
5588             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5589             dephii=dephii+k*sinkt(m)*(
5590      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5591      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5592             dephii1=dephii1+k*sinkt(m)*(
5593      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5594      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5595             if (lprn)
5596      &      write (iout,*) "m",m," k",k," bbthet",
5597      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5598      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5599      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5600      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5601           enddo
5602         enddo
5603         if (lprn)
5604      &  write(iout,*) "ethetai",ethetai
5605         do m=1,ntheterm3
5606           do k=2,ndouble
5607             do l=1,k-1
5608               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5609      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5610      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5611      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5612               ethetai=ethetai+sinkt(m)*aux
5613               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5614               dephii=dephii+l*sinkt(m)*(
5615      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5616      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5617      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5618      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5619               dephii1=dephii1+(k-l)*sinkt(m)*(
5620      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5621      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5622      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5623      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5624               if (lprn) then
5625               write (iout,*) "m",m," k",k," l",l," ffthet",
5626      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5627      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5628      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5629      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5630      &            " ethetai",ethetai
5631               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5632      &            cosph1ph2(k,l)*sinkt(m),
5633      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5634               endif
5635             enddo
5636           enddo
5637         enddo
5638 10      continue
5639         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5640      &   i,theta(i)*rad2deg,phii*rad2deg,
5641      &   phii1*rad2deg,ethetai
5642         etheta=etheta+ethetai
5643         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5644         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5645 c        gloc(nphi+i-2,icg)=wang*dethetai
5646         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5647       enddo
5648       return
5649       end
5650 #endif
5651 #ifdef CRYST_SC
5652 c-----------------------------------------------------------------------------
5653       subroutine esc(escloc)
5654 C Calculate the local energy of a side chain and its derivatives in the
5655 C corresponding virtual-bond valence angles THETA and the spherical angles
5656 C ALPHA and OMEGA.
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'DIMENSIONS.ZSCOPT'
5660       include 'COMMON.GEO'
5661       include 'COMMON.LOCAL'
5662       include 'COMMON.VAR'
5663       include 'COMMON.INTERACT'
5664       include 'COMMON.DERIV'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.IOUNITS'
5667       include 'COMMON.NAMES'
5668       include 'COMMON.FFIELD'
5669       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5670      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5671       common /sccalc/ time11,time12,time112,theti,it,nlobit
5672       delta=0.02d0*pi
5673       escloc=0.0D0
5674 C      write (iout,*) 'ESC'
5675       do i=loc_start,loc_end
5676         it=itype(i)
5677         if (it.eq.ntyp1) cycle
5678         if (it.eq.10) goto 1
5679         nlobit=nlob(iabs(it))
5680 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5681 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5682         theti=theta(i+1)-pipol
5683         x(1)=dtan(theti)
5684         x(2)=alph(i)
5685         x(3)=omeg(i)
5686 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5687
5688         if (x(2).gt.pi-delta) then
5689           xtemp(1)=x(1)
5690           xtemp(2)=pi-delta
5691           xtemp(3)=x(3)
5692           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5693           xtemp(2)=pi
5694           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5695           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5696      &        escloci,dersc(2))
5697           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5698      &        ddersc0(1),dersc(1))
5699           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5700      &        ddersc0(3),dersc(3))
5701           xtemp(2)=pi-delta
5702           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5703           xtemp(2)=pi
5704           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5705           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5706      &            dersc0(2),esclocbi,dersc02)
5707           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5708      &            dersc12,dersc01)
5709           call splinthet(x(2),0.5d0*delta,ss,ssd)
5710           dersc0(1)=dersc01
5711           dersc0(2)=dersc02
5712           dersc0(3)=0.0d0
5713           do k=1,3
5714             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5715           enddo
5716           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5717           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5718      &             esclocbi,ss,ssd
5719           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5720 c         escloci=esclocbi
5721 c         write (iout,*) escloci
5722         else if (x(2).lt.delta) then
5723           xtemp(1)=x(1)
5724           xtemp(2)=delta
5725           xtemp(3)=x(3)
5726           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5727           xtemp(2)=0.0d0
5728           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5729           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5730      &        escloci,dersc(2))
5731           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5732      &        ddersc0(1),dersc(1))
5733           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5734      &        ddersc0(3),dersc(3))
5735           xtemp(2)=delta
5736           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5737           xtemp(2)=0.0d0
5738           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5739           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5740      &            dersc0(2),esclocbi,dersc02)
5741           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5742      &            dersc12,dersc01)
5743           dersc0(1)=dersc01
5744           dersc0(2)=dersc02
5745           dersc0(3)=0.0d0
5746           call splinthet(x(2),0.5d0*delta,ss,ssd)
5747           do k=1,3
5748             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5749           enddo
5750           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5751 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5752 c     &             esclocbi,ss,ssd
5753           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5754 C         write (iout,*) 'i=',i, escloci
5755         else
5756           call enesc(x,escloci,dersc,ddummy,.false.)
5757         endif
5758
5759         escloc=escloc+escloci
5760 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5761             write (iout,'(a6,i5,0pf7.3)')
5762      &     'escloc',i,escloci
5763
5764         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5765      &   wscloc*dersc(1)
5766         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5767         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5768     1   continue
5769       enddo
5770       return
5771       end
5772 C---------------------------------------------------------------------------
5773       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5774       implicit real*8 (a-h,o-z)
5775       include 'DIMENSIONS'
5776       include 'COMMON.GEO'
5777       include 'COMMON.LOCAL'
5778       include 'COMMON.IOUNITS'
5779       common /sccalc/ time11,time12,time112,theti,it,nlobit
5780       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5781       double precision contr(maxlob,-1:1)
5782       logical mixed
5783 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5784         escloc_i=0.0D0
5785         do j=1,3
5786           dersc(j)=0.0D0
5787           if (mixed) ddersc(j)=0.0d0
5788         enddo
5789         x3=x(3)
5790
5791 C Because of periodicity of the dependence of the SC energy in omega we have
5792 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5793 C To avoid underflows, first compute & store the exponents.
5794
5795         do iii=-1,1
5796
5797           x(3)=x3+iii*dwapi
5798
5799           do j=1,nlobit
5800             do k=1,3
5801               z(k)=x(k)-censc(k,j,it)
5802             enddo
5803             do k=1,3
5804               Axk=0.0D0
5805               do l=1,3
5806                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5807               enddo
5808               Ax(k,j,iii)=Axk
5809             enddo
5810             expfac=0.0D0
5811             do k=1,3
5812               expfac=expfac+Ax(k,j,iii)*z(k)
5813             enddo
5814             contr(j,iii)=expfac
5815           enddo ! j
5816
5817         enddo ! iii
5818
5819         x(3)=x3
5820 C As in the case of ebend, we want to avoid underflows in exponentiation and
5821 C subsequent NaNs and INFs in energy calculation.
5822 C Find the largest exponent
5823         emin=contr(1,-1)
5824         do iii=-1,1
5825           do j=1,nlobit
5826             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5827           enddo
5828         enddo
5829         emin=0.5D0*emin
5830 cd      print *,'it=',it,' emin=',emin
5831
5832 C Compute the contribution to SC energy and derivatives
5833         do iii=-1,1
5834
5835           do j=1,nlobit
5836             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5837 cd          print *,'j=',j,' expfac=',expfac
5838             escloc_i=escloc_i+expfac
5839             do k=1,3
5840               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5841             enddo
5842             if (mixed) then
5843               do k=1,3,2
5844                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5845      &            +gaussc(k,2,j,it))*expfac
5846               enddo
5847             endif
5848           enddo
5849
5850         enddo ! iii
5851
5852         dersc(1)=dersc(1)/cos(theti)**2
5853         ddersc(1)=ddersc(1)/cos(theti)**2
5854         ddersc(3)=ddersc(3)
5855
5856         escloci=-(dlog(escloc_i)-emin)
5857         do j=1,3
5858           dersc(j)=dersc(j)/escloc_i
5859         enddo
5860         if (mixed) then
5861           do j=1,3,2
5862             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5863           enddo
5864         endif
5865       return
5866       end
5867 C------------------------------------------------------------------------------
5868       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       include 'COMMON.GEO'
5872       include 'COMMON.LOCAL'
5873       include 'COMMON.IOUNITS'
5874       common /sccalc/ time11,time12,time112,theti,it,nlobit
5875       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5876       double precision contr(maxlob)
5877       logical mixed
5878
5879       escloc_i=0.0D0
5880
5881       do j=1,3
5882         dersc(j)=0.0D0
5883       enddo
5884
5885       do j=1,nlobit
5886         do k=1,2
5887           z(k)=x(k)-censc(k,j,it)
5888         enddo
5889         z(3)=dwapi
5890         do k=1,3
5891           Axk=0.0D0
5892           do l=1,3
5893             Axk=Axk+gaussc(l,k,j,it)*z(l)
5894           enddo
5895           Ax(k,j)=Axk
5896         enddo
5897         expfac=0.0D0
5898         do k=1,3
5899           expfac=expfac+Ax(k,j)*z(k)
5900         enddo
5901         contr(j)=expfac
5902       enddo ! j
5903
5904 C As in the case of ebend, we want to avoid underflows in exponentiation and
5905 C subsequent NaNs and INFs in energy calculation.
5906 C Find the largest exponent
5907       emin=contr(1)
5908       do j=1,nlobit
5909         if (emin.gt.contr(j)) emin=contr(j)
5910       enddo
5911       emin=0.5D0*emin
5912
5913 C Compute the contribution to SC energy and derivatives
5914
5915       dersc12=0.0d0
5916       do j=1,nlobit
5917         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5918         escloc_i=escloc_i+expfac
5919         do k=1,2
5920           dersc(k)=dersc(k)+Ax(k,j)*expfac
5921         enddo
5922         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5923      &            +gaussc(1,2,j,it))*expfac
5924         dersc(3)=0.0d0
5925       enddo
5926
5927       dersc(1)=dersc(1)/cos(theti)**2
5928       dersc12=dersc12/cos(theti)**2
5929       escloci=-(dlog(escloc_i)-emin)
5930       do j=1,2
5931         dersc(j)=dersc(j)/escloc_i
5932       enddo
5933       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5934       return
5935       end
5936 #else
5937 c----------------------------------------------------------------------------------
5938       subroutine esc(escloc)
5939 C Calculate the local energy of a side chain and its derivatives in the
5940 C corresponding virtual-bond valence angles THETA and the spherical angles
5941 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5942 C added by Urszula Kozlowska. 07/11/2007
5943 C
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'DIMENSIONS.ZSCOPT'
5947       include 'COMMON.GEO'
5948       include 'COMMON.LOCAL'
5949       include 'COMMON.VAR'
5950       include 'COMMON.SCROT'
5951       include 'COMMON.INTERACT'
5952       include 'COMMON.DERIV'
5953       include 'COMMON.CHAIN'
5954       include 'COMMON.IOUNITS'
5955       include 'COMMON.NAMES'
5956       include 'COMMON.FFIELD'
5957       include 'COMMON.CONTROL'
5958       include 'COMMON.VECTORS'
5959       double precision x_prime(3),y_prime(3),z_prime(3)
5960      &    , sumene,dsc_i,dp2_i,x(65),
5961      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5962      &    de_dxx,de_dyy,de_dzz,de_dt
5963       double precision s1_t,s1_6_t,s2_t,s2_6_t
5964       double precision
5965      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5966      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5967      & dt_dCi(3),dt_dCi1(3)
5968       common /sccalc/ time11,time12,time112,theti,it,nlobit
5969       delta=0.02d0*pi
5970       escloc=0.0D0
5971       do i=loc_start,loc_end
5972         if (itype(i).eq.ntyp1) cycle
5973         costtab(i+1) =dcos(theta(i+1))
5974         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5975         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5976         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5977         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5978         cosfac=dsqrt(cosfac2)
5979         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5980         sinfac=dsqrt(sinfac2)
5981         it=iabs(itype(i))
5982         if (it.eq.10) goto 1
5983 c
5984 C  Compute the axes of tghe local cartesian coordinates system; store in
5985 c   x_prime, y_prime and z_prime
5986 c
5987         do j=1,3
5988           x_prime(j) = 0.00
5989           y_prime(j) = 0.00
5990           z_prime(j) = 0.00
5991         enddo
5992 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5993 C     &   dc_norm(3,i+nres)
5994         do j = 1,3
5995           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5996           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5997         enddo
5998         do j = 1,3
5999           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6000         enddo
6001 c       write (2,*) "i",i
6002 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6003 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6004 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6005 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6006 c      & " xy",scalar(x_prime(1),y_prime(1)),
6007 c      & " xz",scalar(x_prime(1),z_prime(1)),
6008 c      & " yy",scalar(y_prime(1),y_prime(1)),
6009 c      & " yz",scalar(y_prime(1),z_prime(1)),
6010 c      & " zz",scalar(z_prime(1),z_prime(1))
6011 c
6012 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6013 C to local coordinate system. Store in xx, yy, zz.
6014 c
6015         xx=0.0d0
6016         yy=0.0d0
6017         zz=0.0d0
6018         do j = 1,3
6019           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6020           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6021           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6022         enddo
6023
6024         xxtab(i)=xx
6025         yytab(i)=yy
6026         zztab(i)=zz
6027 C
6028 C Compute the energy of the ith side cbain
6029 C
6030 c        write (2,*) "xx",xx," yy",yy," zz",zz
6031         it=iabs(itype(i))
6032         do j = 1,65
6033           x(j) = sc_parmin(j,it)
6034         enddo
6035 #ifdef CHECK_COORD
6036 Cc diagnostics - remove later
6037         xx1 = dcos(alph(2))
6038         yy1 = dsin(alph(2))*dcos(omeg(2))
6039         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6040         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6041      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6042      &    xx1,yy1,zz1
6043 C,"  --- ", xx_w,yy_w,zz_w
6044 c end diagnostics
6045 #endif
6046         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6047      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6048      &   + x(10)*yy*zz
6049         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6050      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6051      & + x(20)*yy*zz
6052         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6053      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6054      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6055      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6056      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6057      &  +x(40)*xx*yy*zz
6058         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6059      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6060      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6061      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6062      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6063      &  +x(60)*xx*yy*zz
6064         dsc_i   = 0.743d0+x(61)
6065         dp2_i   = 1.9d0+x(62)
6066         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6067      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6068         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6069      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6070         s1=(1+x(63))/(0.1d0 + dscp1)
6071         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6072         s2=(1+x(65))/(0.1d0 + dscp2)
6073         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6074         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6075      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6076 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6077 c     &   sumene4,
6078 c     &   dscp1,dscp2,sumene
6079 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6080         escloc = escloc + sumene
6081 c        write (2,*) "escloc",escloc
6082 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6083 c     &  zz,xx,yy
6084         if (.not. calc_grad) goto 1
6085 #ifdef DEBUG
6086 C
6087 C This section to check the numerical derivatives of the energy of ith side
6088 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6089 C #define DEBUG in the code to turn it on.
6090 C
6091         write (2,*) "sumene               =",sumene
6092         aincr=1.0d-7
6093         xxsave=xx
6094         xx=xx+aincr
6095         write (2,*) xx,yy,zz
6096         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6097         de_dxx_num=(sumenep-sumene)/aincr
6098         xx=xxsave
6099         write (2,*) "xx+ sumene from enesc=",sumenep
6100         yysave=yy
6101         yy=yy+aincr
6102         write (2,*) xx,yy,zz
6103         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6104         de_dyy_num=(sumenep-sumene)/aincr
6105         yy=yysave
6106         write (2,*) "yy+ sumene from enesc=",sumenep
6107         zzsave=zz
6108         zz=zz+aincr
6109         write (2,*) xx,yy,zz
6110         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6111         de_dzz_num=(sumenep-sumene)/aincr
6112         zz=zzsave
6113         write (2,*) "zz+ sumene from enesc=",sumenep
6114         costsave=cost2tab(i+1)
6115         sintsave=sint2tab(i+1)
6116         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6117         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6118         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6119         de_dt_num=(sumenep-sumene)/aincr
6120         write (2,*) " t+ sumene from enesc=",sumenep
6121         cost2tab(i+1)=costsave
6122         sint2tab(i+1)=sintsave
6123 C End of diagnostics section.
6124 #endif
6125 C
6126 C Compute the gradient of esc
6127 C
6128         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6129         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6130         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6131         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6132         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6133         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6134         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6135         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6136         pom1=(sumene3*sint2tab(i+1)+sumene1)
6137      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6138         pom2=(sumene4*cost2tab(i+1)+sumene2)
6139      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6140         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6141         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6142      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6143      &  +x(40)*yy*zz
6144         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6145         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6146      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6147      &  +x(60)*yy*zz
6148         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6149      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6150      &        +(pom1+pom2)*pom_dx
6151 #ifdef DEBUG
6152         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6153 #endif
6154 C
6155         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6156         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6157      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6158      &  +x(40)*xx*zz
6159         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6160         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6161      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6162      &  +x(59)*zz**2 +x(60)*xx*zz
6163         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6164      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6165      &        +(pom1-pom2)*pom_dy
6166 #ifdef DEBUG
6167         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6168 #endif
6169 C
6170         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6171      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6172      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6173      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6174      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6175      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6176      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6177      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6178 #ifdef DEBUG
6179         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6180 #endif
6181 C
6182         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6183      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6184      &  +pom1*pom_dt1+pom2*pom_dt2
6185 #ifdef DEBUG
6186         write(2,*), "de_dt = ", de_dt,de_dt_num
6187 #endif
6188 c
6189 C
6190        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6191        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6192        cosfac2xx=cosfac2*xx
6193        sinfac2yy=sinfac2*yy
6194        do k = 1,3
6195          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6196      &      vbld_inv(i+1)
6197          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6198      &      vbld_inv(i)
6199          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6200          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6201 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6202 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6203 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6204 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6205          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6206          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6207          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6208          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6209          dZZ_Ci1(k)=0.0d0
6210          dZZ_Ci(k)=0.0d0
6211          do j=1,3
6212            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6213      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6214            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6215      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6216          enddo
6217
6218          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6219          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6220          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6221 c
6222          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6223          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6224        enddo
6225
6226        do k=1,3
6227          dXX_Ctab(k,i)=dXX_Ci(k)
6228          dXX_C1tab(k,i)=dXX_Ci1(k)
6229          dYY_Ctab(k,i)=dYY_Ci(k)
6230          dYY_C1tab(k,i)=dYY_Ci1(k)
6231          dZZ_Ctab(k,i)=dZZ_Ci(k)
6232          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6233          dXX_XYZtab(k,i)=dXX_XYZ(k)
6234          dYY_XYZtab(k,i)=dYY_XYZ(k)
6235          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6236        enddo
6237
6238        do k = 1,3
6239 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6240 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6241 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6242 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6243 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6244 c     &    dt_dci(k)
6245 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6246 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6247          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6248      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6249          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6250      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6251          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6252      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6253        enddo
6254 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6255 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6256
6257 C to check gradient call subroutine check_grad
6258
6259     1 continue
6260       enddo
6261       return
6262       end
6263 #endif
6264 c------------------------------------------------------------------------------
6265       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6266 C
6267 C This procedure calculates two-body contact function g(rij) and its derivative:
6268 C
6269 C           eps0ij                                     !       x < -1
6270 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6271 C            0                                         !       x > 1
6272 C
6273 C where x=(rij-r0ij)/delta
6274 C
6275 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6276 C
6277       implicit none
6278       double precision rij,r0ij,eps0ij,fcont,fprimcont
6279       double precision x,x2,x4,delta
6280 c     delta=0.02D0*r0ij
6281 c      delta=0.2D0*r0ij
6282       x=(rij-r0ij)/delta
6283       if (x.lt.-1.0D0) then
6284         fcont=eps0ij
6285         fprimcont=0.0D0
6286       else if (x.le.1.0D0) then
6287         x2=x*x
6288         x4=x2*x2
6289         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6290         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6291       else
6292         fcont=0.0D0
6293         fprimcont=0.0D0
6294       endif
6295       return
6296       end
6297 c------------------------------------------------------------------------------
6298       subroutine splinthet(theti,delta,ss,ssder)
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'DIMENSIONS.ZSCOPT'
6302       include 'COMMON.VAR'
6303       include 'COMMON.GEO'
6304       thetup=pi-delta
6305       thetlow=delta
6306       if (theti.gt.pipol) then
6307         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6308       else
6309         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6310         ssder=-ssder
6311       endif
6312       return
6313       end
6314 c------------------------------------------------------------------------------
6315       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6316       implicit none
6317       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6318       double precision ksi,ksi2,ksi3,a1,a2,a3
6319       a1=fprim0*delta/(f1-f0)
6320       a2=3.0d0-2.0d0*a1
6321       a3=a1-2.0d0
6322       ksi=(x-x0)/delta
6323       ksi2=ksi*ksi
6324       ksi3=ksi2*ksi
6325       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6326       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6327       return
6328       end
6329 c------------------------------------------------------------------------------
6330       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6331       implicit none
6332       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6333       double precision ksi,ksi2,ksi3,a1,a2,a3
6334       ksi=(x-x0)/delta
6335       ksi2=ksi*ksi
6336       ksi3=ksi2*ksi
6337       a1=fprim0x*delta
6338       a2=3*(f1x-f0x)-2*fprim0x*delta
6339       a3=fprim0x*delta-2*(f1x-f0x)
6340       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6341       return
6342       end
6343 C-----------------------------------------------------------------------------
6344 #ifdef CRYST_TOR
6345 C-----------------------------------------------------------------------------
6346       subroutine etor(etors,fact)
6347       implicit real*8 (a-h,o-z)
6348       include 'DIMENSIONS'
6349       include 'DIMENSIONS.ZSCOPT'
6350       include 'COMMON.VAR'
6351       include 'COMMON.GEO'
6352       include 'COMMON.LOCAL'
6353       include 'COMMON.TORSION'
6354       include 'COMMON.INTERACT'
6355       include 'COMMON.DERIV'
6356       include 'COMMON.CHAIN'
6357       include 'COMMON.NAMES'
6358       include 'COMMON.IOUNITS'
6359       include 'COMMON.FFIELD'
6360       include 'COMMON.TORCNSTR'
6361       logical lprn
6362 C Set lprn=.true. for debugging
6363       lprn=.false.
6364 c      lprn=.true.
6365       etors=0.0D0
6366       do i=iphi_start,iphi_end
6367         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6368      &      .or. itype(i).eq.ntyp1) cycle
6369         itori=itortyp(itype(i-2))
6370         itori1=itortyp(itype(i-1))
6371         phii=phi(i)
6372         gloci=0.0D0
6373 C Proline-Proline pair is a special case...
6374         if (itori.eq.3 .and. itori1.eq.3) then
6375           if (phii.gt.-dwapi3) then
6376             cosphi=dcos(3*phii)
6377             fac=1.0D0/(1.0D0-cosphi)
6378             etorsi=v1(1,3,3)*fac
6379             etorsi=etorsi+etorsi
6380             etors=etors+etorsi-v1(1,3,3)
6381             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6382           endif
6383           do j=1,3
6384             v1ij=v1(j+1,itori,itori1)
6385             v2ij=v2(j+1,itori,itori1)
6386             cosphi=dcos(j*phii)
6387             sinphi=dsin(j*phii)
6388             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6389             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6390           enddo
6391         else
6392           do j=1,nterm_old
6393             v1ij=v1(j,itori,itori1)
6394             v2ij=v2(j,itori,itori1)
6395             cosphi=dcos(j*phii)
6396             sinphi=dsin(j*phii)
6397             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6398             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6399           enddo
6400         endif
6401         if (lprn)
6402      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6403      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6404      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6405         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6406 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6407       enddo
6408       return
6409       end
6410 c------------------------------------------------------------------------------
6411 #else
6412       subroutine etor(etors,fact)
6413       implicit real*8 (a-h,o-z)
6414       include 'DIMENSIONS'
6415       include 'DIMENSIONS.ZSCOPT'
6416       include 'COMMON.VAR'
6417       include 'COMMON.GEO'
6418       include 'COMMON.LOCAL'
6419       include 'COMMON.TORSION'
6420       include 'COMMON.INTERACT'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.CHAIN'
6423       include 'COMMON.NAMES'
6424       include 'COMMON.IOUNITS'
6425       include 'COMMON.FFIELD'
6426       include 'COMMON.TORCNSTR'
6427       logical lprn
6428 C Set lprn=.true. for debugging
6429       lprn=.false.
6430 c      lprn=.true.
6431       etors=0.0D0
6432       do i=iphi_start,iphi_end
6433         if (i.le.2) cycle
6434         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6435      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6436 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6437 C     &       .or. itype(i).eq.ntyp1) cycle
6438         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6439          if (iabs(itype(i)).eq.20) then
6440          iblock=2
6441          else
6442          iblock=1
6443          endif
6444         itori=itortyp(itype(i-2))
6445         itori1=itortyp(itype(i-1))
6446         phii=phi(i)
6447         gloci=0.0D0
6448 C Regular cosine and sine terms
6449         do j=1,nterm(itori,itori1,iblock)
6450           v1ij=v1(j,itori,itori1,iblock)
6451           v2ij=v2(j,itori,itori1,iblock)
6452           cosphi=dcos(j*phii)
6453           sinphi=dsin(j*phii)
6454           etors=etors+v1ij*cosphi+v2ij*sinphi
6455           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6456         enddo
6457 C Lorentz terms
6458 C                         v1
6459 C  E = SUM ----------------------------------- - v1
6460 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6461 C
6462         cosphi=dcos(0.5d0*phii)
6463         sinphi=dsin(0.5d0*phii)
6464         do j=1,nlor(itori,itori1,iblock)
6465           vl1ij=vlor1(j,itori,itori1)
6466           vl2ij=vlor2(j,itori,itori1)
6467           vl3ij=vlor3(j,itori,itori1)
6468           pom=vl2ij*cosphi+vl3ij*sinphi
6469           pom1=1.0d0/(pom*pom+1.0d0)
6470           etors=etors+vl1ij*pom1
6471 c          if (energy_dec) etors_ii=etors_ii+
6472 c     &                vl1ij*pom1
6473           pom=-pom*pom1*pom1
6474           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6475         enddo
6476 C Subtract the constant term
6477         etors=etors-v0(itori,itori1,iblock)
6478         if (lprn)
6479      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6480      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6481      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6482         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6483 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6484  1215   continue
6485       enddo
6486       return
6487       end
6488 c----------------------------------------------------------------------------
6489       subroutine etor_d(etors_d,fact2)
6490 C 6/23/01 Compute double torsional energy
6491       implicit real*8 (a-h,o-z)
6492       include 'DIMENSIONS'
6493       include 'DIMENSIONS.ZSCOPT'
6494       include 'COMMON.VAR'
6495       include 'COMMON.GEO'
6496       include 'COMMON.LOCAL'
6497       include 'COMMON.TORSION'
6498       include 'COMMON.INTERACT'
6499       include 'COMMON.DERIV'
6500       include 'COMMON.CHAIN'
6501       include 'COMMON.NAMES'
6502       include 'COMMON.IOUNITS'
6503       include 'COMMON.FFIELD'
6504       include 'COMMON.TORCNSTR'
6505       logical lprn
6506 C Set lprn=.true. for debugging
6507       lprn=.false.
6508 c     lprn=.true.
6509       etors_d=0.0D0
6510       do i=iphi_start,iphi_end-1
6511         if (i.le.3) cycle
6512 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6513 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6514          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6515      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6516      &  (itype(i+1).eq.ntyp1)) cycle
6517         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6518      &     goto 1215
6519         itori=itortyp(itype(i-2))
6520         itori1=itortyp(itype(i-1))
6521         itori2=itortyp(itype(i))
6522         phii=phi(i)
6523         phii1=phi(i+1)
6524         gloci1=0.0D0
6525         gloci2=0.0D0
6526         iblock=1
6527         if (iabs(itype(i+1)).eq.20) iblock=2
6528 C Regular cosine and sine terms
6529         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6530           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6531           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6532           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6533           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6534           cosphi1=dcos(j*phii)
6535           sinphi1=dsin(j*phii)
6536           cosphi2=dcos(j*phii1)
6537           sinphi2=dsin(j*phii1)
6538           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6539      &     v2cij*cosphi2+v2sij*sinphi2
6540           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6541           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6542         enddo
6543         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6544           do l=1,k-1
6545             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6546             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6547             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6548             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6549             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6550             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6551             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6552             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6553             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6554      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6555             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6556      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6557             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6558      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6559           enddo
6560         enddo
6561         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6562         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6563  1215   continue
6564       enddo
6565       return
6566       end
6567 #endif
6568 c---------------------------------------------------------------------------
6569 C The rigorous attempt to derive energy function
6570       subroutine etor_kcc(etors,fact)
6571       implicit real*8 (a-h,o-z)
6572       include 'DIMENSIONS'
6573       include 'DIMENSIONS.ZSCOPT'
6574       include 'COMMON.VAR'
6575       include 'COMMON.GEO'
6576       include 'COMMON.LOCAL'
6577       include 'COMMON.TORSION'
6578       include 'COMMON.INTERACT'
6579       include 'COMMON.DERIV'
6580       include 'COMMON.CHAIN'
6581       include 'COMMON.NAMES'
6582       include 'COMMON.IOUNITS'
6583       include 'COMMON.FFIELD'
6584       include 'COMMON.TORCNSTR'
6585       include 'COMMON.CONTROL'
6586       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6587       logical lprn
6588 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6589 C Set lprn=.true. for debugging
6590       lprn=energy_dec
6591 c     lprn=.true.
6592 C      print *,"wchodze kcc"
6593       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6594       etors=0.0D0
6595       do i=iphi_start,iphi_end
6596 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6597 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6598 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6599 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6600         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6601      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6602         itori=itortyp(itype(i-2))
6603         itori1=itortyp(itype(i-1))
6604         phii=phi(i)
6605         glocig=0.0D0
6606         glocit1=0.0d0
6607         glocit2=0.0d0
6608 C to avoid multiple devision by 2
6609 c        theti22=0.5d0*theta(i)
6610 C theta 12 is the theta_1 /2
6611 C theta 22 is theta_2 /2
6612 c        theti12=0.5d0*theta(i-1)
6613 C and appropriate sinus function
6614         sinthet1=dsin(theta(i-1))
6615         sinthet2=dsin(theta(i))
6616         costhet1=dcos(theta(i-1))
6617         costhet2=dcos(theta(i))
6618 C to speed up lets store its mutliplication
6619         sint1t2=sinthet2*sinthet1
6620         sint1t2n=1.0d0
6621 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6622 C +d_n*sin(n*gamma)) *
6623 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6624 C we have two sum 1) Non-Chebyshev which is with n and gamma
6625         nval=nterm_kcc_Tb(itori,itori1)
6626         c1(0)=0.0d0
6627         c2(0)=0.0d0
6628         c1(1)=1.0d0
6629         c2(1)=1.0d0
6630         do j=2,nval
6631           c1(j)=c1(j-1)*costhet1
6632           c2(j)=c2(j-1)*costhet2
6633         enddo
6634         etori=0.0d0
6635         do j=1,nterm_kcc(itori,itori1)
6636           cosphi=dcos(j*phii)
6637           sinphi=dsin(j*phii)
6638           sint1t2n1=sint1t2n
6639           sint1t2n=sint1t2n*sint1t2
6640           sumvalc=0.0d0
6641           gradvalct1=0.0d0
6642           gradvalct2=0.0d0
6643           do k=1,nval
6644             do l=1,nval
6645               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6646               gradvalct1=gradvalct1+
6647      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6648               gradvalct2=gradvalct2+
6649      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6650             enddo
6651           enddo
6652           gradvalct1=-gradvalct1*sinthet1
6653           gradvalct2=-gradvalct2*sinthet2
6654           sumvals=0.0d0
6655           gradvalst1=0.0d0
6656           gradvalst2=0.0d0
6657           do k=1,nval
6658             do l=1,nval
6659               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6660               gradvalst1=gradvalst1+
6661      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6662               gradvalst2=gradvalst2+
6663      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6664             enddo
6665           enddo
6666           gradvalst1=-gradvalst1*sinthet1
6667           gradvalst2=-gradvalst2*sinthet2
6668           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6669 C glocig is the gradient local i site in gamma
6670           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6671 C now gradient over theta_1
6672           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6673      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6674           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6675      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6676         enddo ! j
6677         etors=etors+etori
6678 C derivative over gamma
6679         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6680 C derivative over theta1
6681         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6682 C now derivative over theta2
6683         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6684         if (lprn) then
6685           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6686      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6687           write (iout,*) "c1",(c1(k),k=0,nval),
6688      &    " c2",(c2(k),k=0,nval)
6689           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6690         endif
6691       enddo
6692       return
6693       end
6694 c---------------------------------------------------------------------------------------------
6695       subroutine etor_constr(edihcnstr)
6696       implicit real*8 (a-h,o-z)
6697       include 'DIMENSIONS'
6698       include 'DIMENSIONS.ZSCOPT'
6699       include 'COMMON.VAR'
6700       include 'COMMON.GEO'
6701       include 'COMMON.LOCAL'
6702       include 'COMMON.TORSION'
6703       include 'COMMON.INTERACT'
6704       include 'COMMON.DERIV'
6705       include 'COMMON.CHAIN'
6706       include 'COMMON.NAMES'
6707       include 'COMMON.IOUNITS'
6708       include 'COMMON.FFIELD'
6709       include 'COMMON.TORCNSTR'
6710       include 'COMMON.CONTROL'
6711 ! 6/20/98 - dihedral angle constraints
6712       edihcnstr=0.0d0
6713 c      do i=1,ndih_constr
6714 c      write (iout,*) "idihconstr_start",idihconstr_start,
6715 c     &  " idihconstr_end",idihconstr_end
6716
6717       if (raw_psipred) then
6718         do i=idihconstr_start,idihconstr_end
6719           itori=idih_constr(i)
6720           phii=phi(itori)
6721           gaudih_i=vpsipred(1,i)
6722           gauder_i=0.0d0
6723           do j=1,2
6724             s = sdihed(j,i)
6725             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6726             dexpcos_i=dexp(-cos_i*cos_i)
6727             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6728             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6729      &            *cos_i*dexpcos_i/s**2
6730           enddo
6731           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6732           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6733           if (energy_dec)
6734      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6735      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6736      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6737      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6738      &     -wdihc*dlog(gaudih_i)
6739         enddo
6740       else
6741
6742       do i=idihconstr_start,idihconstr_end
6743         itori=idih_constr(i)
6744         phii=phi(itori)
6745         difi=pinorm(phii-phi0(i))
6746         if (difi.gt.drange(i)) then
6747           difi=difi-drange(i)
6748           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6749           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6750         else if (difi.lt.-drange(i)) then
6751           difi=difi+drange(i)
6752           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6753           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6754         else
6755           difi=0.0
6756         endif
6757       enddo
6758
6759       endif
6760
6761 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6762       return
6763       end
6764 c----------------------------------------------------------------------------
6765 C The rigorous attempt to derive energy function
6766       subroutine ebend_kcc(etheta)
6767
6768       implicit real*8 (a-h,o-z)
6769       include 'DIMENSIONS'
6770       include 'DIMENSIONS.ZSCOPT'
6771       include 'COMMON.VAR'
6772       include 'COMMON.GEO'
6773       include 'COMMON.LOCAL'
6774       include 'COMMON.TORSION'
6775       include 'COMMON.INTERACT'
6776       include 'COMMON.DERIV'
6777       include 'COMMON.CHAIN'
6778       include 'COMMON.NAMES'
6779       include 'COMMON.IOUNITS'
6780       include 'COMMON.FFIELD'
6781       include 'COMMON.TORCNSTR'
6782       include 'COMMON.CONTROL'
6783       logical lprn
6784       double precision thybt1(maxang_kcc)
6785 C Set lprn=.true. for debugging
6786       lprn=energy_dec
6787 c     lprn=.true.
6788 C      print *,"wchodze kcc"
6789       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6790       etheta=0.0D0
6791       do i=ithet_start,ithet_end
6792 c        print *,i,itype(i-1),itype(i),itype(i-2)
6793         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6794      &  .or.itype(i).eq.ntyp1) cycle
6795         iti=iabs(itortyp(itype(i-1)))
6796         sinthet=dsin(theta(i))
6797         costhet=dcos(theta(i))
6798         do j=1,nbend_kcc_Tb(iti)
6799           thybt1(j)=v1bend_chyb(j,iti)
6800         enddo
6801         sumth1thyb=v1bend_chyb(0,iti)+
6802      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6803         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6804      &    sumth1thyb
6805         ihelp=nbend_kcc_Tb(iti)-1
6806         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6807         etheta=etheta+sumth1thyb
6808 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6809         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6810       enddo
6811       return
6812       end
6813 c-------------------------------------------------------------------------------------
6814       subroutine etheta_constr(ethetacnstr)
6815
6816       implicit real*8 (a-h,o-z)
6817       include 'DIMENSIONS'
6818       include 'DIMENSIONS.ZSCOPT'
6819       include 'COMMON.VAR'
6820       include 'COMMON.GEO'
6821       include 'COMMON.LOCAL'
6822       include 'COMMON.TORSION'
6823       include 'COMMON.INTERACT'
6824       include 'COMMON.DERIV'
6825       include 'COMMON.CHAIN'
6826       include 'COMMON.NAMES'
6827       include 'COMMON.IOUNITS'
6828       include 'COMMON.FFIELD'
6829       include 'COMMON.TORCNSTR'
6830       include 'COMMON.CONTROL'
6831       ethetacnstr=0.0d0
6832 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6833       do i=ithetaconstr_start,ithetaconstr_end
6834         itheta=itheta_constr(i)
6835         thetiii=theta(itheta)
6836         difi=pinorm(thetiii-theta_constr0(i))
6837         if (difi.gt.theta_drange(i)) then
6838           difi=difi-theta_drange(i)
6839           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6840           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6841      &    +for_thet_constr(i)*difi**3
6842         else if (difi.lt.-drange(i)) then
6843           difi=difi+drange(i)
6844           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6845           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6846      &    +for_thet_constr(i)*difi**3
6847         else
6848           difi=0.0
6849         endif
6850        if (energy_dec) then
6851         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6852      &    i,itheta,rad2deg*thetiii,
6853      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6854      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6855      &    gloc(itheta+nphi-2,icg)
6856         endif
6857       enddo
6858       return
6859       end
6860 c------------------------------------------------------------------------------
6861 c------------------------------------------------------------------------------
6862       subroutine eback_sc_corr(esccor)
6863 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6864 c        conformational states; temporarily implemented as differences
6865 c        between UNRES torsional potentials (dependent on three types of
6866 c        residues) and the torsional potentials dependent on all 20 types
6867 c        of residues computed from AM1 energy surfaces of terminally-blocked
6868 c        amino-acid residues.
6869       implicit real*8 (a-h,o-z)
6870       include 'DIMENSIONS'
6871       include 'DIMENSIONS.ZSCOPT'
6872       include 'COMMON.VAR'
6873       include 'COMMON.GEO'
6874       include 'COMMON.LOCAL'
6875       include 'COMMON.TORSION'
6876       include 'COMMON.SCCOR'
6877       include 'COMMON.INTERACT'
6878       include 'COMMON.DERIV'
6879       include 'COMMON.CHAIN'
6880       include 'COMMON.NAMES'
6881       include 'COMMON.IOUNITS'
6882       include 'COMMON.FFIELD'
6883       include 'COMMON.CONTROL'
6884       logical lprn
6885 C Set lprn=.true. for debugging
6886       lprn=.false.
6887 c      lprn=.true.
6888 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6889       esccor=0.0D0
6890       do i=itau_start,itau_end
6891         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6892         esccor_ii=0.0D0
6893         isccori=isccortyp(itype(i-2))
6894         isccori1=isccortyp(itype(i-1))
6895         phii=phi(i)
6896         do intertyp=1,3 !intertyp
6897 cc Added 09 May 2012 (Adasko)
6898 cc  Intertyp means interaction type of backbone mainchain correlation:
6899 c   1 = SC...Ca...Ca...Ca
6900 c   2 = Ca...Ca...Ca...SC
6901 c   3 = SC...Ca...Ca...SCi
6902         gloci=0.0D0
6903         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6904      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6905      &      (itype(i-1).eq.ntyp1)))
6906      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6907      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6908      &     .or.(itype(i).eq.ntyp1)))
6909      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6910      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6911      &      (itype(i-3).eq.ntyp1)))) cycle
6912         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6913         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6914      & cycle
6915        do j=1,nterm_sccor(isccori,isccori1)
6916           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6917           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6918           cosphi=dcos(j*tauangle(intertyp,i))
6919           sinphi=dsin(j*tauangle(intertyp,i))
6920            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6921            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6922          enddo
6923 C      write (iout,*)"EBACK_SC_COR",esccor,i
6924 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6925 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6926 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6927         if (lprn)
6928      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6929      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6930      &  (v1sccor(j,1,itori,itori1),j=1,6)
6931      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6932 c        gsccor_loc(i-3)=gloci
6933        enddo !intertyp
6934       enddo
6935       return
6936       end
6937 c------------------------------------------------------------------------------
6938       subroutine multibody(ecorr)
6939 C This subroutine calculates multi-body contributions to energy following
6940 C the idea of Skolnick et al. If side chains I and J make a contact and
6941 C at the same time side chains I+1 and J+1 make a contact, an extra
6942 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6943       implicit real*8 (a-h,o-z)
6944       include 'DIMENSIONS'
6945       include 'COMMON.IOUNITS'
6946       include 'COMMON.DERIV'
6947       include 'COMMON.INTERACT'
6948       include 'COMMON.CONTACTS'
6949       double precision gx(3),gx1(3)
6950       logical lprn
6951
6952 C Set lprn=.true. for debugging
6953       lprn=.false.
6954
6955       if (lprn) then
6956         write (iout,'(a)') 'Contact function values:'
6957         do i=nnt,nct-2
6958           write (iout,'(i2,20(1x,i2,f10.5))')
6959      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6960         enddo
6961       endif
6962       ecorr=0.0D0
6963       do i=nnt,nct
6964         do j=1,3
6965           gradcorr(j,i)=0.0D0
6966           gradxorr(j,i)=0.0D0
6967         enddo
6968       enddo
6969       do i=nnt,nct-2
6970
6971         DO ISHIFT = 3,4
6972
6973         i1=i+ishift
6974         num_conti=num_cont(i)
6975         num_conti1=num_cont(i1)
6976         do jj=1,num_conti
6977           j=jcont(jj,i)
6978           do kk=1,num_conti1
6979             j1=jcont(kk,i1)
6980             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6981 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6982 cd   &                   ' ishift=',ishift
6983 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6984 C The system gains extra energy.
6985               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6986             endif   ! j1==j+-ishift
6987           enddo     ! kk
6988         enddo       ! jj
6989
6990         ENDDO ! ISHIFT
6991
6992       enddo         ! i
6993       return
6994       end
6995 c------------------------------------------------------------------------------
6996       double precision function esccorr(i,j,k,l,jj,kk)
6997       implicit real*8 (a-h,o-z)
6998       include 'DIMENSIONS'
6999       include 'COMMON.IOUNITS'
7000       include 'COMMON.DERIV'
7001       include 'COMMON.INTERACT'
7002       include 'COMMON.CONTACTS'
7003       double precision gx(3),gx1(3)
7004       logical lprn
7005       lprn=.false.
7006       eij=facont(jj,i)
7007       ekl=facont(kk,k)
7008 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7009 C Calculate the multi-body contribution to energy.
7010 C Calculate multi-body contributions to the gradient.
7011 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7012 cd   & k,l,(gacont(m,kk,k),m=1,3)
7013       do m=1,3
7014         gx(m) =ekl*gacont(m,jj,i)
7015         gx1(m)=eij*gacont(m,kk,k)
7016         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7017         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7018         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7019         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7020       enddo
7021       do m=i,j-1
7022         do ll=1,3
7023           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7024         enddo
7025       enddo
7026       do m=k,l-1
7027         do ll=1,3
7028           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7029         enddo
7030       enddo
7031       esccorr=-eij*ekl
7032       return
7033       end
7034 c------------------------------------------------------------------------------
7035       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7036 C This subroutine calculates multi-body contributions to hydrogen-bonding
7037       implicit real*8 (a-h,o-z)
7038       include 'DIMENSIONS'
7039       include 'DIMENSIONS.ZSCOPT'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.FFIELD'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       double precision gx(3),gx1(3)
7046       logical lprn,ldone
7047
7048 C Set lprn=.true. for debugging
7049       lprn=.false.
7050       if (lprn) then
7051         write (iout,'(a)') 'Contact function values:'
7052         do i=nnt,nct-2
7053           write (iout,'(2i3,50(1x,i2,f5.2))')
7054      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7055      &    j=1,num_cont_hb(i))
7056         enddo
7057       endif
7058       ecorr=0.0D0
7059 C Remove the loop below after debugging !!!
7060       do i=nnt,nct
7061         do j=1,3
7062           gradcorr(j,i)=0.0D0
7063           gradxorr(j,i)=0.0D0
7064         enddo
7065       enddo
7066 C Calculate the local-electrostatic correlation terms
7067       do i=iatel_s,iatel_e+1
7068         i1=i+1
7069         num_conti=num_cont_hb(i)
7070         num_conti1=num_cont_hb(i+1)
7071         do jj=1,num_conti
7072           j=jcont_hb(jj,i)
7073           do kk=1,num_conti1
7074             j1=jcont_hb(kk,i1)
7075 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7076 c     &         ' jj=',jj,' kk=',kk
7077             if (j1.eq.j+1 .or. j1.eq.j-1) then
7078 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7079 C The system gains extra energy.
7080               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7081               n_corr=n_corr+1
7082             else if (j1.eq.j) then
7083 C Contacts I-J and I-(J+1) occur simultaneously.
7084 C The system loses extra energy.
7085 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7086             endif
7087           enddo ! kk
7088           do kk=1,num_conti
7089             j1=jcont_hb(kk,i)
7090 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7091 c    &         ' jj=',jj,' kk=',kk
7092             if (j1.eq.j+1) then
7093 C Contacts I-J and (I+1)-J occur simultaneously.
7094 C The system loses extra energy.
7095 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7096             endif ! j1==j+1
7097           enddo ! kk
7098         enddo ! jj
7099       enddo ! i
7100       return
7101       end
7102 c------------------------------------------------------------------------------
7103       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7104      &  n_corr1)
7105 C This subroutine calculates multi-body contributions to hydrogen-bonding
7106       implicit real*8 (a-h,o-z)
7107       include 'DIMENSIONS'
7108       include 'DIMENSIONS.ZSCOPT'
7109       include 'COMMON.IOUNITS'
7110 #ifdef MPI
7111       include "mpif.h"
7112 #endif
7113       include 'COMMON.FFIELD'
7114       include 'COMMON.DERIV'
7115       include 'COMMON.LOCAL'
7116       include 'COMMON.INTERACT'
7117       include 'COMMON.CONTACTS'
7118       include 'COMMON.CHAIN'
7119       include 'COMMON.CONTROL'
7120       include 'COMMON.SHIELD'
7121       double precision gx(3),gx1(3)
7122       integer num_cont_hb_old(maxres)
7123       logical lprn,ldone
7124       double precision eello4,eello5,eelo6,eello_turn6
7125       external eello4,eello5,eello6,eello_turn6
7126 C Set lprn=.true. for debugging
7127       lprn=.false.
7128       eturn6=0.0d0
7129       if (lprn) then
7130         write (iout,'(a)') 'Contact function values:'
7131         do i=nnt,nct-2
7132           write (iout,'(2i3,50(1x,i2,5f6.3))')
7133      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7134      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7135         enddo
7136       endif
7137       ecorr=0.0D0
7138       ecorr5=0.0d0
7139       ecorr6=0.0d0
7140 C Remove the loop below after debugging !!!
7141       do i=nnt,nct
7142         do j=1,3
7143           gradcorr(j,i)=0.0D0
7144           gradxorr(j,i)=0.0D0
7145         enddo
7146       enddo
7147 C Calculate the dipole-dipole interaction energies
7148       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7149       do i=iatel_s,iatel_e+1
7150         num_conti=num_cont_hb(i)
7151         do jj=1,num_conti
7152           j=jcont_hb(jj,i)
7153 #ifdef MOMENT
7154           call dipole(i,j,jj)
7155 #endif
7156         enddo
7157       enddo
7158       endif
7159 C Calculate the local-electrostatic correlation terms
7160 c                write (iout,*) "gradcorr5 in eello5 before loop"
7161 c                do iii=1,nres
7162 c                  write (iout,'(i5,3f10.5)')
7163 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7164 c                enddo
7165       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7166 c        write (iout,*) "corr loop i",i
7167         i1=i+1
7168         num_conti=num_cont_hb(i)
7169         num_conti1=num_cont_hb(i+1)
7170         do jj=1,num_conti
7171           j=jcont_hb(jj,i)
7172           jp=iabs(j)
7173           do kk=1,num_conti1
7174             j1=jcont_hb(kk,i1)
7175             jp1=iabs(j1)
7176 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7177 c     &         ' jj=',jj,' kk=',kk
7178 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7179             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7180      &          .or. j.lt.0 .and. j1.gt.0) .and.
7181      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7182 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7183 C The system gains extra energy.
7184               n_corr=n_corr+1
7185               sqd1=dsqrt(d_cont(jj,i))
7186               sqd2=dsqrt(d_cont(kk,i1))
7187               sred_geom = sqd1*sqd2
7188               IF (sred_geom.lt.cutoff_corr) THEN
7189                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7190      &            ekont,fprimcont)
7191 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7192 cd     &         ' jj=',jj,' kk=',kk
7193                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7194                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7195                 do l=1,3
7196                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7197                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7198                 enddo
7199                 n_corr1=n_corr1+1
7200 cd               write (iout,*) 'sred_geom=',sred_geom,
7201 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7202 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7203 cd               write (iout,*) "g_contij",g_contij
7204 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7205 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7206                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7207                 if (wcorr4.gt.0.0d0)
7208      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7209 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7210                   if (energy_dec.and.wcorr4.gt.0.0d0)
7211      1                 write (iout,'(a6,4i5,0pf7.3)')
7212      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7213 c                write (iout,*) "gradcorr5 before eello5"
7214 c                do iii=1,nres
7215 c                  write (iout,'(i5,3f10.5)')
7216 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7217 c                enddo
7218                 if (wcorr5.gt.0.0d0)
7219      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7220 c                write (iout,*) "gradcorr5 after eello5"
7221 c                do iii=1,nres
7222 c                  write (iout,'(i5,3f10.5)')
7223 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7224 c                enddo
7225                   if (energy_dec.and.wcorr5.gt.0.0d0)
7226      1                 write (iout,'(a6,4i5,0pf7.3)')
7227      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7228 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7229 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7230                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7231      &               .or. wturn6.eq.0.0d0))then
7232 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7233                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7234                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7235      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7236 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7237 cd     &            'ecorr6=',ecorr6
7238 cd                write (iout,'(4e15.5)') sred_geom,
7239 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7240 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7241 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7242                 else if (wturn6.gt.0.0d0
7243      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7244 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7245                   eturn6=eturn6+eello_turn6(i,jj,kk)
7246                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7247      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7248 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7249                 endif
7250               ENDIF
7251 1111          continue
7252             endif
7253           enddo ! kk
7254         enddo ! jj
7255       enddo ! i
7256       do i=1,nres
7257         num_cont_hb(i)=num_cont_hb_old(i)
7258       enddo
7259 c                write (iout,*) "gradcorr5 in eello5"
7260 c                do iii=1,nres
7261 c                  write (iout,'(i5,3f10.5)')
7262 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7263 c                enddo
7264       return
7265       end
7266 c------------------------------------------------------------------------------
7267       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7268       implicit real*8 (a-h,o-z)
7269       include 'DIMENSIONS'
7270       include 'DIMENSIONS.ZSCOPT'
7271       include 'COMMON.IOUNITS'
7272       include 'COMMON.DERIV'
7273       include 'COMMON.INTERACT'
7274       include 'COMMON.CONTACTS'
7275       include 'COMMON.SHIELD'
7276       include 'COMMON.CONTROL'
7277       double precision gx(3),gx1(3)
7278       logical lprn
7279       lprn=.false.
7280 C      print *,"wchodze",fac_shield(i),shield_mode
7281       eij=facont_hb(jj,i)
7282       ekl=facont_hb(kk,k)
7283       ees0pij=ees0p(jj,i)
7284       ees0pkl=ees0p(kk,k)
7285       ees0mij=ees0m(jj,i)
7286       ees0mkl=ees0m(kk,k)
7287       ekont=eij*ekl
7288       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7289 C*
7290 C     & fac_shield(i)**2*fac_shield(j)**2
7291 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7292 C Following 4 lines for diagnostics.
7293 cd    ees0pkl=0.0D0
7294 cd    ees0pij=1.0D0
7295 cd    ees0mkl=0.0D0
7296 cd    ees0mij=1.0D0
7297 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7298 c     & 'Contacts ',i,j,
7299 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7300 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7301 c     & 'gradcorr_long'
7302 C Calculate the multi-body contribution to energy.
7303 C      ecorr=ecorr+ekont*ees
7304 C Calculate multi-body contributions to the gradient.
7305       coeffpees0pij=coeffp*ees0pij
7306       coeffmees0mij=coeffm*ees0mij
7307       coeffpees0pkl=coeffp*ees0pkl
7308       coeffmees0mkl=coeffm*ees0mkl
7309       do ll=1,3
7310 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7311         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7312      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7313      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7314         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7315      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7316      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7317 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7318         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7319      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7320      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7321         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7322      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7323      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7324         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7325      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7326      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7327         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7328         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7329         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7330      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7331      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7332         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7333         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7334 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7335       enddo
7336 c      write (iout,*)
7337 cgrad      do m=i+1,j-1
7338 cgrad        do ll=1,3
7339 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7340 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7341 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7342 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7343 cgrad        enddo
7344 cgrad      enddo
7345 cgrad      do m=k+1,l-1
7346 cgrad        do ll=1,3
7347 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7348 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7349 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7350 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7351 cgrad        enddo
7352 cgrad      enddo
7353 c      write (iout,*) "ehbcorr",ekont*ees
7354 C      print *,ekont,ees,i,k
7355       ehbcorr=ekont*ees
7356 C now gradient over shielding
7357 C      return
7358       if (shield_mode.gt.0) then
7359        j=ees0plist(jj,i)
7360        l=ees0plist(kk,k)
7361 C        print *,i,j,fac_shield(i),fac_shield(j),
7362 C     &fac_shield(k),fac_shield(l)
7363         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7364      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7365           do ilist=1,ishield_list(i)
7366            iresshield=shield_list(ilist,i)
7367            do m=1,3
7368            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7369 C     &      *2.0
7370            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7371      &              rlocshield
7372      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7373             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7374      &+rlocshield
7375            enddo
7376           enddo
7377           do ilist=1,ishield_list(j)
7378            iresshield=shield_list(ilist,j)
7379            do m=1,3
7380            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7381 C     &     *2.0
7382            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7383      &              rlocshield
7384      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7385            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7386      &     +rlocshield
7387            enddo
7388           enddo
7389
7390           do ilist=1,ishield_list(k)
7391            iresshield=shield_list(ilist,k)
7392            do m=1,3
7393            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7394 C     &     *2.0
7395            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7396      &              rlocshield
7397      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7398            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7399      &     +rlocshield
7400            enddo
7401           enddo
7402           do ilist=1,ishield_list(l)
7403            iresshield=shield_list(ilist,l)
7404            do m=1,3
7405            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7406 C     &     *2.0
7407            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7408      &              rlocshield
7409      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7410            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7411      &     +rlocshield
7412            enddo
7413           enddo
7414 C          print *,gshieldx(m,iresshield)
7415           do m=1,3
7416             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7417      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7418             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7419      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7420             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7421      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7422             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7423      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7424
7425             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7426      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7427             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7428      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7429             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7430      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7431             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7432      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7433
7434            enddo
7435       endif
7436       endif
7437       return
7438       end
7439 #ifdef MOMENT
7440 C---------------------------------------------------------------------------
7441       subroutine dipole(i,j,jj)
7442       implicit real*8 (a-h,o-z)
7443       include 'DIMENSIONS'
7444       include 'DIMENSIONS.ZSCOPT'
7445       include 'COMMON.IOUNITS'
7446       include 'COMMON.CHAIN'
7447       include 'COMMON.FFIELD'
7448       include 'COMMON.DERIV'
7449       include 'COMMON.INTERACT'
7450       include 'COMMON.CONTACTS'
7451       include 'COMMON.TORSION'
7452       include 'COMMON.VAR'
7453       include 'COMMON.GEO'
7454       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7455      &  auxmat(2,2)
7456       iti1 = itortyp(itype(i+1))
7457       if (j.lt.nres-1) then
7458         itj1 = itype2loc(itype(j+1))
7459       else
7460         itj1=nloctyp
7461       endif
7462       do iii=1,2
7463         dipi(iii,1)=Ub2(iii,i)
7464         dipderi(iii)=Ub2der(iii,i)
7465         dipi(iii,2)=b1(iii,i+1)
7466         dipj(iii,1)=Ub2(iii,j)
7467         dipderj(iii)=Ub2der(iii,j)
7468         dipj(iii,2)=b1(iii,j+1)
7469       enddo
7470       kkk=0
7471       do iii=1,2
7472         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7473         do jjj=1,2
7474           kkk=kkk+1
7475           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7476         enddo
7477       enddo
7478       do kkk=1,5
7479         do lll=1,3
7480           mmm=0
7481           do iii=1,2
7482             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7483      &        auxvec(1))
7484             do jjj=1,2
7485               mmm=mmm+1
7486               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7487             enddo
7488           enddo
7489         enddo
7490       enddo
7491       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7492       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7493       do iii=1,2
7494         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7495       enddo
7496       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7497       do iii=1,2
7498         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7499       enddo
7500       return
7501       end
7502 #endif
7503 C---------------------------------------------------------------------------
7504       subroutine calc_eello(i,j,k,l,jj,kk)
7505 C
7506 C This subroutine computes matrices and vectors needed to calculate
7507 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7508 C
7509       implicit real*8 (a-h,o-z)
7510       include 'DIMENSIONS'
7511       include 'DIMENSIONS.ZSCOPT'
7512       include 'COMMON.IOUNITS'
7513       include 'COMMON.CHAIN'
7514       include 'COMMON.DERIV'
7515       include 'COMMON.INTERACT'
7516       include 'COMMON.CONTACTS'
7517       include 'COMMON.TORSION'
7518       include 'COMMON.VAR'
7519       include 'COMMON.GEO'
7520       include 'COMMON.FFIELD'
7521       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7522      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7523       logical lprn
7524       common /kutas/ lprn
7525 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7526 cd     & ' jj=',jj,' kk=',kk
7527 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7528 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7529 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7530       do iii=1,2
7531         do jjj=1,2
7532           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7533           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7534         enddo
7535       enddo
7536       call transpose2(aa1(1,1),aa1t(1,1))
7537       call transpose2(aa2(1,1),aa2t(1,1))
7538       do kkk=1,5
7539         do lll=1,3
7540           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7541      &      aa1tder(1,1,lll,kkk))
7542           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7543      &      aa2tder(1,1,lll,kkk))
7544         enddo
7545       enddo
7546       if (l.eq.j+1) then
7547 C parallel orientation of the two CA-CA-CA frames.
7548         if (i.gt.1) then
7549           iti=itype2loc(itype(i))
7550         else
7551           iti=nloctyp
7552         endif
7553         itk1=itype2loc(itype(k+1))
7554         itj=itype2loc(itype(j))
7555         if (l.lt.nres-1) then
7556           itl1=itype2loc(itype(l+1))
7557         else
7558           itl1=nloctyp
7559         endif
7560 C A1 kernel(j+1) A2T
7561 cd        do iii=1,2
7562 cd          write (iout,'(3f10.5,5x,3f10.5)')
7563 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7564 cd        enddo
7565         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7566      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7567      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7568 C Following matrices are needed only for 6-th order cumulants
7569         IF (wcorr6.gt.0.0d0) THEN
7570         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7571      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7572      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7573         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7574      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7575      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7576      &   ADtEAderx(1,1,1,1,1,1))
7577         lprn=.false.
7578         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7579      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7580      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7581      &   ADtEA1derx(1,1,1,1,1,1))
7582         ENDIF
7583 C End 6-th order cumulants
7584 cd        lprn=.false.
7585 cd        if (lprn) then
7586 cd        write (2,*) 'In calc_eello6'
7587 cd        do iii=1,2
7588 cd          write (2,*) 'iii=',iii
7589 cd          do kkk=1,5
7590 cd            write (2,*) 'kkk=',kkk
7591 cd            do jjj=1,2
7592 cd              write (2,'(3(2f10.5),5x)')
7593 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7594 cd            enddo
7595 cd          enddo
7596 cd        enddo
7597 cd        endif
7598         call transpose2(EUgder(1,1,k),auxmat(1,1))
7599         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7600         call transpose2(EUg(1,1,k),auxmat(1,1))
7601         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7602         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7603         do iii=1,2
7604           do kkk=1,5
7605             do lll=1,3
7606               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7607      &          EAEAderx(1,1,lll,kkk,iii,1))
7608             enddo
7609           enddo
7610         enddo
7611 C A1T kernel(i+1) A2
7612         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7613      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7614      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7615 C Following matrices are needed only for 6-th order cumulants
7616         IF (wcorr6.gt.0.0d0) THEN
7617         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7618      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7619      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7620         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7621      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7622      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7623      &   ADtEAderx(1,1,1,1,1,2))
7624         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7625      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7626      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7627      &   ADtEA1derx(1,1,1,1,1,2))
7628         ENDIF
7629 C End 6-th order cumulants
7630         call transpose2(EUgder(1,1,l),auxmat(1,1))
7631         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7632         call transpose2(EUg(1,1,l),auxmat(1,1))
7633         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7634         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7635         do iii=1,2
7636           do kkk=1,5
7637             do lll=1,3
7638               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7639      &          EAEAderx(1,1,lll,kkk,iii,2))
7640             enddo
7641           enddo
7642         enddo
7643 C AEAb1 and AEAb2
7644 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7645 C They are needed only when the fifth- or the sixth-order cumulants are
7646 C indluded.
7647         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7648         call transpose2(AEA(1,1,1),auxmat(1,1))
7649         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7650         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7651         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7652         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7653         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7654         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7655         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7656         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7657         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7658         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7659         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7660         call transpose2(AEA(1,1,2),auxmat(1,1))
7661         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7662         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7663         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7664         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7665         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7666         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7667         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7668         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7669         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7670         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7671         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7672 C Calculate the Cartesian derivatives of the vectors.
7673         do iii=1,2
7674           do kkk=1,5
7675             do lll=1,3
7676               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7677               call matvec2(auxmat(1,1),b1(1,i),
7678      &          AEAb1derx(1,lll,kkk,iii,1,1))
7679               call matvec2(auxmat(1,1),Ub2(1,i),
7680      &          AEAb2derx(1,lll,kkk,iii,1,1))
7681               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7682      &          AEAb1derx(1,lll,kkk,iii,2,1))
7683               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7684      &          AEAb2derx(1,lll,kkk,iii,2,1))
7685               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7686               call matvec2(auxmat(1,1),b1(1,j),
7687      &          AEAb1derx(1,lll,kkk,iii,1,2))
7688               call matvec2(auxmat(1,1),Ub2(1,j),
7689      &          AEAb2derx(1,lll,kkk,iii,1,2))
7690               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7691      &          AEAb1derx(1,lll,kkk,iii,2,2))
7692               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7693      &          AEAb2derx(1,lll,kkk,iii,2,2))
7694             enddo
7695           enddo
7696         enddo
7697         ENDIF
7698 C End vectors
7699       else
7700 C Antiparallel orientation of the two CA-CA-CA frames.
7701         if (i.gt.1) then
7702           iti=itype2loc(itype(i))
7703         else
7704           iti=nloctyp
7705         endif
7706         itk1=itype2loc(itype(k+1))
7707         itl=itype2loc(itype(l))
7708         itj=itype2loc(itype(j))
7709         if (j.lt.nres-1) then
7710           itj1=itype2loc(itype(j+1))
7711         else
7712           itj1=nloctyp
7713         endif
7714 C A2 kernel(j-1)T A1T
7715         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7716      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7717      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7718 C Following matrices are needed only for 6-th order cumulants
7719         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7720      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7721         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7722      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7723      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7724         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7725      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7726      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7727      &   ADtEAderx(1,1,1,1,1,1))
7728         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7729      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7730      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7731      &   ADtEA1derx(1,1,1,1,1,1))
7732         ENDIF
7733 C End 6-th order cumulants
7734         call transpose2(EUgder(1,1,k),auxmat(1,1))
7735         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7736         call transpose2(EUg(1,1,k),auxmat(1,1))
7737         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7738         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7739         do iii=1,2
7740           do kkk=1,5
7741             do lll=1,3
7742               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7743      &          EAEAderx(1,1,lll,kkk,iii,1))
7744             enddo
7745           enddo
7746         enddo
7747 C A2T kernel(i+1)T A1
7748         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7749      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7750      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7751 C Following matrices are needed only for 6-th order cumulants
7752         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7753      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7754         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7755      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7756      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7757         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7758      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7759      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7760      &   ADtEAderx(1,1,1,1,1,2))
7761         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7762      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7763      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7764      &   ADtEA1derx(1,1,1,1,1,2))
7765         ENDIF
7766 C End 6-th order cumulants
7767         call transpose2(EUgder(1,1,j),auxmat(1,1))
7768         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7769         call transpose2(EUg(1,1,j),auxmat(1,1))
7770         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7771         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7772         do iii=1,2
7773           do kkk=1,5
7774             do lll=1,3
7775               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7776      &          EAEAderx(1,1,lll,kkk,iii,2))
7777             enddo
7778           enddo
7779         enddo
7780 C AEAb1 and AEAb2
7781 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7782 C They are needed only when the fifth- or the sixth-order cumulants are
7783 C indluded.
7784         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7785      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7786         call transpose2(AEA(1,1,1),auxmat(1,1))
7787         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7788         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7789         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7790         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7791         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7792         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7793         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7794         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7795         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7796         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7797         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7798         call transpose2(AEA(1,1,2),auxmat(1,1))
7799         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7800         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7801         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7802         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7803         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7804         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7805         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7806         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7807         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7808         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7809         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7810 C Calculate the Cartesian derivatives of the vectors.
7811         do iii=1,2
7812           do kkk=1,5
7813             do lll=1,3
7814               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7815               call matvec2(auxmat(1,1),b1(1,i),
7816      &          AEAb1derx(1,lll,kkk,iii,1,1))
7817               call matvec2(auxmat(1,1),Ub2(1,i),
7818      &          AEAb2derx(1,lll,kkk,iii,1,1))
7819               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7820      &          AEAb1derx(1,lll,kkk,iii,2,1))
7821               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7822      &          AEAb2derx(1,lll,kkk,iii,2,1))
7823               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7824               call matvec2(auxmat(1,1),b1(1,l),
7825      &          AEAb1derx(1,lll,kkk,iii,1,2))
7826               call matvec2(auxmat(1,1),Ub2(1,l),
7827      &          AEAb2derx(1,lll,kkk,iii,1,2))
7828               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7829      &          AEAb1derx(1,lll,kkk,iii,2,2))
7830               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7831      &          AEAb2derx(1,lll,kkk,iii,2,2))
7832             enddo
7833           enddo
7834         enddo
7835         ENDIF
7836 C End vectors
7837       endif
7838       return
7839       end
7840 C---------------------------------------------------------------------------
7841       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7842      &  KK,KKderg,AKA,AKAderg,AKAderx)
7843       implicit none
7844       integer nderg
7845       logical transp
7846       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7847      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7848      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7849       integer iii,kkk,lll
7850       integer jjj,mmm
7851       logical lprn
7852       common /kutas/ lprn
7853       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7854       do iii=1,nderg
7855         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7856      &    AKAderg(1,1,iii))
7857       enddo
7858 cd      if (lprn) write (2,*) 'In kernel'
7859       do kkk=1,5
7860 cd        if (lprn) write (2,*) 'kkk=',kkk
7861         do lll=1,3
7862           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7863      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7864 cd          if (lprn) then
7865 cd            write (2,*) 'lll=',lll
7866 cd            write (2,*) 'iii=1'
7867 cd            do jjj=1,2
7868 cd              write (2,'(3(2f10.5),5x)')
7869 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7870 cd            enddo
7871 cd          endif
7872           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7873      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7874 cd          if (lprn) then
7875 cd            write (2,*) 'lll=',lll
7876 cd            write (2,*) 'iii=2'
7877 cd            do jjj=1,2
7878 cd              write (2,'(3(2f10.5),5x)')
7879 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7880 cd            enddo
7881 cd          endif
7882         enddo
7883       enddo
7884       return
7885       end
7886 C---------------------------------------------------------------------------
7887       double precision function eello4(i,j,k,l,jj,kk)
7888       implicit real*8 (a-h,o-z)
7889       include 'DIMENSIONS'
7890       include 'DIMENSIONS.ZSCOPT'
7891       include 'COMMON.IOUNITS'
7892       include 'COMMON.CHAIN'
7893       include 'COMMON.DERIV'
7894       include 'COMMON.INTERACT'
7895       include 'COMMON.CONTACTS'
7896       include 'COMMON.TORSION'
7897       include 'COMMON.VAR'
7898       include 'COMMON.GEO'
7899       double precision pizda(2,2),ggg1(3),ggg2(3)
7900 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7901 cd        eello4=0.0d0
7902 cd        return
7903 cd      endif
7904 cd      print *,'eello4:',i,j,k,l,jj,kk
7905 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7906 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7907 cold      eij=facont_hb(jj,i)
7908 cold      ekl=facont_hb(kk,k)
7909 cold      ekont=eij*ekl
7910       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7911       if (calc_grad) then
7912 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7913       gcorr_loc(k-1)=gcorr_loc(k-1)
7914      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7915       if (l.eq.j+1) then
7916         gcorr_loc(l-1)=gcorr_loc(l-1)
7917      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7918       else
7919         gcorr_loc(j-1)=gcorr_loc(j-1)
7920      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7921       endif
7922       do iii=1,2
7923         do kkk=1,5
7924           do lll=1,3
7925             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7926      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7927 cd            derx(lll,kkk,iii)=0.0d0
7928           enddo
7929         enddo
7930       enddo
7931 cd      gcorr_loc(l-1)=0.0d0
7932 cd      gcorr_loc(j-1)=0.0d0
7933 cd      gcorr_loc(k-1)=0.0d0
7934 cd      eel4=1.0d0
7935 cd      write (iout,*)'Contacts have occurred for peptide groups',
7936 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7937 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7938       if (j.lt.nres-1) then
7939         j1=j+1
7940         j2=j-1
7941       else
7942         j1=j-1
7943         j2=j-2
7944       endif
7945       if (l.lt.nres-1) then
7946         l1=l+1
7947         l2=l-1
7948       else
7949         l1=l-1
7950         l2=l-2
7951       endif
7952       do ll=1,3
7953 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7954 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7955         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7956         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7957 cgrad        ghalf=0.5d0*ggg1(ll)
7958         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7959         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7960         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7961         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7962         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7963         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7964 cgrad        ghalf=0.5d0*ggg2(ll)
7965         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7966         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7967         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7968         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7969         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7970         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7971       enddo
7972 cgrad      do m=i+1,j-1
7973 cgrad        do ll=1,3
7974 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7975 cgrad        enddo
7976 cgrad      enddo
7977 cgrad      do m=k+1,l-1
7978 cgrad        do ll=1,3
7979 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7980 cgrad        enddo
7981 cgrad      enddo
7982 cgrad      do m=i+2,j2
7983 cgrad        do ll=1,3
7984 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7985 cgrad        enddo
7986 cgrad      enddo
7987 cgrad      do m=k+2,l2
7988 cgrad        do ll=1,3
7989 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7990 cgrad        enddo
7991 cgrad      enddo
7992 cd      do iii=1,nres-3
7993 cd        write (2,*) iii,gcorr_loc(iii)
7994 cd      enddo
7995       endif ! calc_grad
7996       eello4=ekont*eel4
7997 cd      write (2,*) 'ekont',ekont
7998 cd      write (iout,*) 'eello4',ekont*eel4
7999       return
8000       end
8001 C---------------------------------------------------------------------------
8002       double precision function eello5(i,j,k,l,jj,kk)
8003       implicit real*8 (a-h,o-z)
8004       include 'DIMENSIONS'
8005       include 'DIMENSIONS.ZSCOPT'
8006       include 'COMMON.IOUNITS'
8007       include 'COMMON.CHAIN'
8008       include 'COMMON.DERIV'
8009       include 'COMMON.INTERACT'
8010       include 'COMMON.CONTACTS'
8011       include 'COMMON.TORSION'
8012       include 'COMMON.VAR'
8013       include 'COMMON.GEO'
8014       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8015       double precision ggg1(3),ggg2(3)
8016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8017 C                                                                              C
8018 C                            Parallel chains                                   C
8019 C                                                                              C
8020 C          o             o                   o             o                   C
8021 C         /l\           / \             \   / \           / \   /              C
8022 C        /   \         /   \             \ /   \         /   \ /               C
8023 C       j| o |l1       | o |              o| o |         | o |o                C
8024 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8025 C      \i/   \         /   \ /             /   \         /   \                 C
8026 C       o    k1             o                                                  C
8027 C         (I)          (II)                (III)          (IV)                 C
8028 C                                                                              C
8029 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8030 C                                                                              C
8031 C                            Antiparallel chains                               C
8032 C                                                                              C
8033 C          o             o                   o             o                   C
8034 C         /j\           / \             \   / \           / \   /              C
8035 C        /   \         /   \             \ /   \         /   \ /               C
8036 C      j1| o |l        | o |              o| o |         | o |o                C
8037 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8038 C      \i/   \         /   \ /             /   \         /   \                 C
8039 C       o     k1            o                                                  C
8040 C         (I)          (II)                (III)          (IV)                 C
8041 C                                                                              C
8042 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8043 C                                                                              C
8044 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8045 C                                                                              C
8046 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8047 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8048 cd        eello5=0.0d0
8049 cd        return
8050 cd      endif
8051 cd      write (iout,*)
8052 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8053 cd     &   ' and',k,l
8054       itk=itype2loc(itype(k))
8055       itl=itype2loc(itype(l))
8056       itj=itype2loc(itype(j))
8057       eello5_1=0.0d0
8058       eello5_2=0.0d0
8059       eello5_3=0.0d0
8060       eello5_4=0.0d0
8061 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8062 cd     &   eel5_3_num,eel5_4_num)
8063       do iii=1,2
8064         do kkk=1,5
8065           do lll=1,3
8066             derx(lll,kkk,iii)=0.0d0
8067           enddo
8068         enddo
8069       enddo
8070 cd      eij=facont_hb(jj,i)
8071 cd      ekl=facont_hb(kk,k)
8072 cd      ekont=eij*ekl
8073 cd      write (iout,*)'Contacts have occurred for peptide groups',
8074 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8075 cd      goto 1111
8076 C Contribution from the graph I.
8077 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8078 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8079       call transpose2(EUg(1,1,k),auxmat(1,1))
8080       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8081       vv(1)=pizda(1,1)-pizda(2,2)
8082       vv(2)=pizda(1,2)+pizda(2,1)
8083       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8084      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8085       if (calc_grad) then
8086 C Explicit gradient in virtual-dihedral angles.
8087       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8088      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8089      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8090       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8091       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8092       vv(1)=pizda(1,1)-pizda(2,2)
8093       vv(2)=pizda(1,2)+pizda(2,1)
8094       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8095      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8096      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8097       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8098       vv(1)=pizda(1,1)-pizda(2,2)
8099       vv(2)=pizda(1,2)+pizda(2,1)
8100       if (l.eq.j+1) then
8101         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8102      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8103      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8104       else
8105         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8106      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8107      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8108       endif
8109 C Cartesian gradient
8110       do iii=1,2
8111         do kkk=1,5
8112           do lll=1,3
8113             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8114      &        pizda(1,1))
8115             vv(1)=pizda(1,1)-pizda(2,2)
8116             vv(2)=pizda(1,2)+pizda(2,1)
8117             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8118      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8119      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8120           enddo
8121         enddo
8122       enddo
8123       endif ! calc_grad
8124 c      goto 1112
8125 c1111  continue
8126 C Contribution from graph II
8127       call transpose2(EE(1,1,k),auxmat(1,1))
8128       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8129       vv(1)=pizda(1,1)+pizda(2,2)
8130       vv(2)=pizda(2,1)-pizda(1,2)
8131       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8132      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8133       if (calc_grad) then
8134 C Explicit gradient in virtual-dihedral angles.
8135       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8136      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8137       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8138       vv(1)=pizda(1,1)+pizda(2,2)
8139       vv(2)=pizda(2,1)-pizda(1,2)
8140       if (l.eq.j+1) then
8141         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8142      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8143      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8144       else
8145         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8146      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8147      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8148       endif
8149 C Cartesian gradient
8150       do iii=1,2
8151         do kkk=1,5
8152           do lll=1,3
8153             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8154      &        pizda(1,1))
8155             vv(1)=pizda(1,1)+pizda(2,2)
8156             vv(2)=pizda(2,1)-pizda(1,2)
8157             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8158      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8159      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8160           enddo
8161         enddo
8162       enddo
8163       endif ! calc_grad
8164 cd      goto 1112
8165 cd1111  continue
8166       if (l.eq.j+1) then
8167 cd        goto 1110
8168 C Parallel orientation
8169 C Contribution from graph III
8170         call transpose2(EUg(1,1,l),auxmat(1,1))
8171         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8172         vv(1)=pizda(1,1)-pizda(2,2)
8173         vv(2)=pizda(1,2)+pizda(2,1)
8174         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8175      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8176         if (calc_grad) then
8177 C Explicit gradient in virtual-dihedral angles.
8178         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8179      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8180      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8181         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8182         vv(1)=pizda(1,1)-pizda(2,2)
8183         vv(2)=pizda(1,2)+pizda(2,1)
8184         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8185      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8186      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8187         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8188         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8189         vv(1)=pizda(1,1)-pizda(2,2)
8190         vv(2)=pizda(1,2)+pizda(2,1)
8191         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8192      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8193      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8194 C Cartesian gradient
8195         do iii=1,2
8196           do kkk=1,5
8197             do lll=1,3
8198               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8199      &          pizda(1,1))
8200               vv(1)=pizda(1,1)-pizda(2,2)
8201               vv(2)=pizda(1,2)+pizda(2,1)
8202               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8203      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8204      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8205             enddo
8206           enddo
8207         enddo
8208 cd        goto 1112
8209 C Contribution from graph IV
8210 cd1110    continue
8211         call transpose2(EE(1,1,l),auxmat(1,1))
8212         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8213         vv(1)=pizda(1,1)+pizda(2,2)
8214         vv(2)=pizda(2,1)-pizda(1,2)
8215         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8216      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8217 C Explicit gradient in virtual-dihedral angles.
8218         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8219      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8220         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8221         vv(1)=pizda(1,1)+pizda(2,2)
8222         vv(2)=pizda(2,1)-pizda(1,2)
8223         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8224      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8225      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8226 C Cartesian gradient
8227         do iii=1,2
8228           do kkk=1,5
8229             do lll=1,3
8230               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8231      &          pizda(1,1))
8232               vv(1)=pizda(1,1)+pizda(2,2)
8233               vv(2)=pizda(2,1)-pizda(1,2)
8234               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8235      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8236      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8237             enddo
8238           enddo
8239         enddo
8240         endif ! calc_grad
8241       else
8242 C Antiparallel orientation
8243 C Contribution from graph III
8244 c        goto 1110
8245         call transpose2(EUg(1,1,j),auxmat(1,1))
8246         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8247         vv(1)=pizda(1,1)-pizda(2,2)
8248         vv(2)=pizda(1,2)+pizda(2,1)
8249         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8250      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8251         if (calc_grad) then
8252 C Explicit gradient in virtual-dihedral angles.
8253         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8254      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8255      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8256         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8257         vv(1)=pizda(1,1)-pizda(2,2)
8258         vv(2)=pizda(1,2)+pizda(2,1)
8259         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8260      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8261      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8262         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8263         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8264         vv(1)=pizda(1,1)-pizda(2,2)
8265         vv(2)=pizda(1,2)+pizda(2,1)
8266         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8267      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8268      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8269 C Cartesian gradient
8270         do iii=1,2
8271           do kkk=1,5
8272             do lll=1,3
8273               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8274      &          pizda(1,1))
8275               vv(1)=pizda(1,1)-pizda(2,2)
8276               vv(2)=pizda(1,2)+pizda(2,1)
8277               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8278      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8279      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8280             enddo
8281           enddo
8282         enddo
8283         endif ! calc_grad
8284 cd        goto 1112
8285 C Contribution from graph IV
8286 1110    continue
8287         call transpose2(EE(1,1,j),auxmat(1,1))
8288         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8289         vv(1)=pizda(1,1)+pizda(2,2)
8290         vv(2)=pizda(2,1)-pizda(1,2)
8291         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8292      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8293         if (calc_grad) then
8294 C Explicit gradient in virtual-dihedral angles.
8295         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8296      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8297         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8298         vv(1)=pizda(1,1)+pizda(2,2)
8299         vv(2)=pizda(2,1)-pizda(1,2)
8300         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8301      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8302      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8303 C Cartesian gradient
8304         do iii=1,2
8305           do kkk=1,5
8306             do lll=1,3
8307               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8308      &          pizda(1,1))
8309               vv(1)=pizda(1,1)+pizda(2,2)
8310               vv(2)=pizda(2,1)-pizda(1,2)
8311               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8312      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8313      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8314             enddo
8315           enddo
8316         enddo
8317         endif ! calc_grad
8318       endif
8319 1112  continue
8320       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8321 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8322 cd        write (2,*) 'ijkl',i,j,k,l
8323 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8324 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8325 cd      endif
8326 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8327 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8328 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8329 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8330       if (calc_grad) then
8331       if (j.lt.nres-1) then
8332         j1=j+1
8333         j2=j-1
8334       else
8335         j1=j-1
8336         j2=j-2
8337       endif
8338       if (l.lt.nres-1) then
8339         l1=l+1
8340         l2=l-1
8341       else
8342         l1=l-1
8343         l2=l-2
8344       endif
8345 cd      eij=1.0d0
8346 cd      ekl=1.0d0
8347 cd      ekont=1.0d0
8348 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8349 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8350 C        summed up outside the subrouine as for the other subroutines
8351 C        handling long-range interactions. The old code is commented out
8352 C        with "cgrad" to keep track of changes.
8353       do ll=1,3
8354 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8355 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8356         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8357         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8358 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8359 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8360 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8361 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8362 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8363 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8364 c     &   gradcorr5ij,
8365 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8366 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8367 cgrad        ghalf=0.5d0*ggg1(ll)
8368 cd        ghalf=0.0d0
8369         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8370         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8371         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8372         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8373         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8374         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8375 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8376 cgrad        ghalf=0.5d0*ggg2(ll)
8377 cd        ghalf=0.0d0
8378         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8379         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8380         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8381         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8382         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8383         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8384       enddo
8385       endif ! calc_grad
8386 cd      goto 1112
8387 cgrad      do m=i+1,j-1
8388 cgrad        do ll=1,3
8389 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8390 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8391 cgrad        enddo
8392 cgrad      enddo
8393 cgrad      do m=k+1,l-1
8394 cgrad        do ll=1,3
8395 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8396 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8397 cgrad        enddo
8398 cgrad      enddo
8399 c1112  continue
8400 cgrad      do m=i+2,j2
8401 cgrad        do ll=1,3
8402 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8403 cgrad        enddo
8404 cgrad      enddo
8405 cgrad      do m=k+2,l2
8406 cgrad        do ll=1,3
8407 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8408 cgrad        enddo
8409 cgrad      enddo
8410 cd      do iii=1,nres-3
8411 cd        write (2,*) iii,g_corr5_loc(iii)
8412 cd      enddo
8413       eello5=ekont*eel5
8414 cd      write (2,*) 'ekont',ekont
8415 cd      write (iout,*) 'eello5',ekont*eel5
8416       return
8417       end
8418 c--------------------------------------------------------------------------
8419       double precision function eello6(i,j,k,l,jj,kk)
8420       implicit real*8 (a-h,o-z)
8421       include 'DIMENSIONS'
8422       include 'DIMENSIONS.ZSCOPT'
8423       include 'COMMON.IOUNITS'
8424       include 'COMMON.CHAIN'
8425       include 'COMMON.DERIV'
8426       include 'COMMON.INTERACT'
8427       include 'COMMON.CONTACTS'
8428       include 'COMMON.TORSION'
8429       include 'COMMON.VAR'
8430       include 'COMMON.GEO'
8431       include 'COMMON.FFIELD'
8432       double precision ggg1(3),ggg2(3)
8433 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8434 cd        eello6=0.0d0
8435 cd        return
8436 cd      endif
8437 cd      write (iout,*)
8438 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8439 cd     &   ' and',k,l
8440       eello6_1=0.0d0
8441       eello6_2=0.0d0
8442       eello6_3=0.0d0
8443       eello6_4=0.0d0
8444       eello6_5=0.0d0
8445       eello6_6=0.0d0
8446 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8447 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8448       do iii=1,2
8449         do kkk=1,5
8450           do lll=1,3
8451             derx(lll,kkk,iii)=0.0d0
8452           enddo
8453         enddo
8454       enddo
8455 cd      eij=facont_hb(jj,i)
8456 cd      ekl=facont_hb(kk,k)
8457 cd      ekont=eij*ekl
8458 cd      eij=1.0d0
8459 cd      ekl=1.0d0
8460 cd      ekont=1.0d0
8461       if (l.eq.j+1) then
8462         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8463         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8464         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8465         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8466         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8467         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8468       else
8469         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8470         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8471         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8472         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8473         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8474           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8475         else
8476           eello6_5=0.0d0
8477         endif
8478         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8479       endif
8480 C If turn contributions are considered, they will be handled separately.
8481       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8482 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8483 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8484 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8485 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8486 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8487 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8488 cd      goto 1112
8489       if (calc_grad) then
8490       if (j.lt.nres-1) then
8491         j1=j+1
8492         j2=j-1
8493       else
8494         j1=j-1
8495         j2=j-2
8496       endif
8497       if (l.lt.nres-1) then
8498         l1=l+1
8499         l2=l-1
8500       else
8501         l1=l-1
8502         l2=l-2
8503       endif
8504       do ll=1,3
8505 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8506 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8507 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8508 cgrad        ghalf=0.5d0*ggg1(ll)
8509 cd        ghalf=0.0d0
8510         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8511         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8512         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8513         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8514         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8515         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8516         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8517         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8518 cgrad        ghalf=0.5d0*ggg2(ll)
8519 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8520 cd        ghalf=0.0d0
8521         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8522         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8523         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8524         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8525         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8526         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8527       enddo
8528       endif ! calc_grad
8529 cd      goto 1112
8530 cgrad      do m=i+1,j-1
8531 cgrad        do ll=1,3
8532 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8533 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8534 cgrad        enddo
8535 cgrad      enddo
8536 cgrad      do m=k+1,l-1
8537 cgrad        do ll=1,3
8538 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8539 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8540 cgrad        enddo
8541 cgrad      enddo
8542 cgrad1112  continue
8543 cgrad      do m=i+2,j2
8544 cgrad        do ll=1,3
8545 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8546 cgrad        enddo
8547 cgrad      enddo
8548 cgrad      do m=k+2,l2
8549 cgrad        do ll=1,3
8550 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8551 cgrad        enddo
8552 cgrad      enddo
8553 cd      do iii=1,nres-3
8554 cd        write (2,*) iii,g_corr6_loc(iii)
8555 cd      enddo
8556       eello6=ekont*eel6
8557 cd      write (2,*) 'ekont',ekont
8558 cd      write (iout,*) 'eello6',ekont*eel6
8559       return
8560       end
8561 c--------------------------------------------------------------------------
8562       double precision function eello6_graph1(i,j,k,l,imat,swap)
8563       implicit real*8 (a-h,o-z)
8564       include 'DIMENSIONS'
8565       include 'DIMENSIONS.ZSCOPT'
8566       include 'COMMON.IOUNITS'
8567       include 'COMMON.CHAIN'
8568       include 'COMMON.DERIV'
8569       include 'COMMON.INTERACT'
8570       include 'COMMON.CONTACTS'
8571       include 'COMMON.TORSION'
8572       include 'COMMON.VAR'
8573       include 'COMMON.GEO'
8574       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8575       logical swap
8576       logical lprn
8577       common /kutas/ lprn
8578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8579 C                                                                              C
8580 C      Parallel       Antiparallel                                             C
8581 C                                                                              C
8582 C          o             o                                                     C
8583 C         /l\           /j\                                                    C
8584 C        /   \         /   \                                                   C
8585 C       /| o |         | o |\                                                  C
8586 C     \ j|/k\|  /   \  |/k\|l /                                                C
8587 C      \ /   \ /     \ /   \ /                                                 C
8588 C       o     o       o     o                                                  C
8589 C       i             i                                                        C
8590 C                                                                              C
8591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8592       itk=itype2loc(itype(k))
8593       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8594       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8595       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8596       call transpose2(EUgC(1,1,k),auxmat(1,1))
8597       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8598       vv1(1)=pizda1(1,1)-pizda1(2,2)
8599       vv1(2)=pizda1(1,2)+pizda1(2,1)
8600       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8601       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8602       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8603       s5=scalar2(vv(1),Dtobr2(1,i))
8604 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8605       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8606       if (calc_grad) then
8607       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8608      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8609      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8610      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8611      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8612      & +scalar2(vv(1),Dtobr2der(1,i)))
8613       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8614       vv1(1)=pizda1(1,1)-pizda1(2,2)
8615       vv1(2)=pizda1(1,2)+pizda1(2,1)
8616       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8617       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8618       if (l.eq.j+1) then
8619         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8620      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8621      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8622      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8623      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8624       else
8625         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8626      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8627      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8628      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8629      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8630       endif
8631       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8632       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8633       vv1(1)=pizda1(1,1)-pizda1(2,2)
8634       vv1(2)=pizda1(1,2)+pizda1(2,1)
8635       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8636      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8637      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8638      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8639       do iii=1,2
8640         if (swap) then
8641           ind=3-iii
8642         else
8643           ind=iii
8644         endif
8645         do kkk=1,5
8646           do lll=1,3
8647             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8648             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8649             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8650             call transpose2(EUgC(1,1,k),auxmat(1,1))
8651             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8652      &        pizda1(1,1))
8653             vv1(1)=pizda1(1,1)-pizda1(2,2)
8654             vv1(2)=pizda1(1,2)+pizda1(2,1)
8655             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8656             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8657      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8658             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8659      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8660             s5=scalar2(vv(1),Dtobr2(1,i))
8661             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8662           enddo
8663         enddo
8664       enddo
8665       endif ! calc_grad
8666       return
8667       end
8668 c----------------------------------------------------------------------------
8669       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8670       implicit real*8 (a-h,o-z)
8671       include 'DIMENSIONS'
8672       include 'DIMENSIONS.ZSCOPT'
8673       include 'COMMON.IOUNITS'
8674       include 'COMMON.CHAIN'
8675       include 'COMMON.DERIV'
8676       include 'COMMON.INTERACT'
8677       include 'COMMON.CONTACTS'
8678       include 'COMMON.TORSION'
8679       include 'COMMON.VAR'
8680       include 'COMMON.GEO'
8681       logical swap
8682       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8683      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8684       logical lprn
8685       common /kutas/ lprn
8686 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8687 C                                                                              C
8688 C      Parallel       Antiparallel                                             C
8689 C                                                                              C
8690 C          o             o                                                     C
8691 C     \   /l\           /j\   /                                                C
8692 C      \ /   \         /   \ /                                                 C
8693 C       o| o |         | o |o                                                  C
8694 C     \ j|/k\|      \  |/k\|l                                                  C
8695 C      \ /   \       \ /   \                                                   C
8696 C       o             o                                                        C
8697 C       i             i                                                        C
8698 C                                                                              C
8699 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8700 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8701 C AL 7/4/01 s1 would occur in the sixth-order moment,
8702 C           but not in a cluster cumulant
8703 #ifdef MOMENT
8704       s1=dip(1,jj,i)*dip(1,kk,k)
8705 #endif
8706       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8707       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8708       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8709       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8710       call transpose2(EUg(1,1,k),auxmat(1,1))
8711       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8712       vv(1)=pizda(1,1)-pizda(2,2)
8713       vv(2)=pizda(1,2)+pizda(2,1)
8714       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8715 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8716 #ifdef MOMENT
8717       eello6_graph2=-(s1+s2+s3+s4)
8718 #else
8719       eello6_graph2=-(s2+s3+s4)
8720 #endif
8721 c      eello6_graph2=-s3
8722 C Derivatives in gamma(i-1)
8723       if (calc_grad) then
8724       if (i.gt.1) then
8725 #ifdef MOMENT
8726         s1=dipderg(1,jj,i)*dip(1,kk,k)
8727 #endif
8728         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8729         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8730         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8731         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8732 #ifdef MOMENT
8733         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8734 #else
8735         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8736 #endif
8737 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8738       endif
8739 C Derivatives in gamma(k-1)
8740 #ifdef MOMENT
8741       s1=dip(1,jj,i)*dipderg(1,kk,k)
8742 #endif
8743       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8744       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8745       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8746       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8747       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8748       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8749       vv(1)=pizda(1,1)-pizda(2,2)
8750       vv(2)=pizda(1,2)+pizda(2,1)
8751       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8752 #ifdef MOMENT
8753       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8754 #else
8755       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8756 #endif
8757 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8758 C Derivatives in gamma(j-1) or gamma(l-1)
8759       if (j.gt.1) then
8760 #ifdef MOMENT
8761         s1=dipderg(3,jj,i)*dip(1,kk,k)
8762 #endif
8763         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8764         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8765         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8766         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8767         vv(1)=pizda(1,1)-pizda(2,2)
8768         vv(2)=pizda(1,2)+pizda(2,1)
8769         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8770 #ifdef MOMENT
8771         if (swap) then
8772           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8773         else
8774           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8775         endif
8776 #endif
8777         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8778 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8779       endif
8780 C Derivatives in gamma(l-1) or gamma(j-1)
8781       if (l.gt.1) then
8782 #ifdef MOMENT
8783         s1=dip(1,jj,i)*dipderg(3,kk,k)
8784 #endif
8785         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8786         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8787         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8788         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8789         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8790         vv(1)=pizda(1,1)-pizda(2,2)
8791         vv(2)=pizda(1,2)+pizda(2,1)
8792         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8793 #ifdef MOMENT
8794         if (swap) then
8795           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8796         else
8797           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8798         endif
8799 #endif
8800         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8801 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8802       endif
8803 C Cartesian derivatives.
8804       if (lprn) then
8805         write (2,*) 'In eello6_graph2'
8806         do iii=1,2
8807           write (2,*) 'iii=',iii
8808           do kkk=1,5
8809             write (2,*) 'kkk=',kkk
8810             do jjj=1,2
8811               write (2,'(3(2f10.5),5x)')
8812      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8813             enddo
8814           enddo
8815         enddo
8816       endif
8817       do iii=1,2
8818         do kkk=1,5
8819           do lll=1,3
8820 #ifdef MOMENT
8821             if (iii.eq.1) then
8822               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8823             else
8824               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8825             endif
8826 #endif
8827             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8828      &        auxvec(1))
8829             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8830             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8831      &        auxvec(1))
8832             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8833             call transpose2(EUg(1,1,k),auxmat(1,1))
8834             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8835      &        pizda(1,1))
8836             vv(1)=pizda(1,1)-pizda(2,2)
8837             vv(2)=pizda(1,2)+pizda(2,1)
8838             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8839 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8840 #ifdef MOMENT
8841             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8842 #else
8843             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8844 #endif
8845             if (swap) then
8846               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8847             else
8848               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8849             endif
8850           enddo
8851         enddo
8852       enddo
8853       endif ! calc_grad
8854       return
8855       end
8856 c----------------------------------------------------------------------------
8857       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8858       implicit real*8 (a-h,o-z)
8859       include 'DIMENSIONS'
8860       include 'DIMENSIONS.ZSCOPT'
8861       include 'COMMON.IOUNITS'
8862       include 'COMMON.CHAIN'
8863       include 'COMMON.DERIV'
8864       include 'COMMON.INTERACT'
8865       include 'COMMON.CONTACTS'
8866       include 'COMMON.TORSION'
8867       include 'COMMON.VAR'
8868       include 'COMMON.GEO'
8869       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8870       logical swap
8871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8872 C                                                                              C
8873 C      Parallel       Antiparallel                                             C
8874 C                                                                              C
8875 C          o             o                                                     C
8876 C         /l\   /   \   /j\                                                    C
8877 C        /   \ /     \ /   \                                                   C
8878 C       /| o |o       o| o |\                                                  C
8879 C       j|/k\|  /      |/k\|l /                                                C
8880 C        /   \ /       /   \ /                                                 C
8881 C       /     o       /     o                                                  C
8882 C       i             i                                                        C
8883 C                                                                              C
8884 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8885 C
8886 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8887 C           energy moment and not to the cluster cumulant.
8888       iti=itortyp(itype(i))
8889       if (j.lt.nres-1) then
8890         itj1=itype2loc(itype(j+1))
8891       else
8892         itj1=nloctyp
8893       endif
8894       itk=itype2loc(itype(k))
8895       itk1=itype2loc(itype(k+1))
8896       if (l.lt.nres-1) then
8897         itl1=itype2loc(itype(l+1))
8898       else
8899         itl1=nloctyp
8900       endif
8901 #ifdef MOMENT
8902       s1=dip(4,jj,i)*dip(4,kk,k)
8903 #endif
8904       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8905       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8906       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8907       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8908       call transpose2(EE(1,1,k),auxmat(1,1))
8909       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8910       vv(1)=pizda(1,1)+pizda(2,2)
8911       vv(2)=pizda(2,1)-pizda(1,2)
8912       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8913 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8914 cd     & "sum",-(s2+s3+s4)
8915 #ifdef MOMENT
8916       eello6_graph3=-(s1+s2+s3+s4)
8917 #else
8918       eello6_graph3=-(s2+s3+s4)
8919 #endif
8920 c      eello6_graph3=-s4
8921 C Derivatives in gamma(k-1)
8922       if (calc_grad) then
8923       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8924       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8925       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8926       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8927 C Derivatives in gamma(l-1)
8928       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8929       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8930       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8931       vv(1)=pizda(1,1)+pizda(2,2)
8932       vv(2)=pizda(2,1)-pizda(1,2)
8933       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8934       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8935 C Cartesian derivatives.
8936       do iii=1,2
8937         do kkk=1,5
8938           do lll=1,3
8939 #ifdef MOMENT
8940             if (iii.eq.1) then
8941               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8942             else
8943               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8944             endif
8945 #endif
8946             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8947      &        auxvec(1))
8948             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8949             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8950      &        auxvec(1))
8951             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8952             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8953      &        pizda(1,1))
8954             vv(1)=pizda(1,1)+pizda(2,2)
8955             vv(2)=pizda(2,1)-pizda(1,2)
8956             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8957 #ifdef MOMENT
8958             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8959 #else
8960             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8961 #endif
8962             if (swap) then
8963               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8964             else
8965               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8966             endif
8967 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8968           enddo
8969         enddo
8970       enddo
8971       endif ! calc_grad
8972       return
8973       end
8974 c----------------------------------------------------------------------------
8975       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8976       implicit real*8 (a-h,o-z)
8977       include 'DIMENSIONS'
8978       include 'DIMENSIONS.ZSCOPT'
8979       include 'COMMON.IOUNITS'
8980       include 'COMMON.CHAIN'
8981       include 'COMMON.DERIV'
8982       include 'COMMON.INTERACT'
8983       include 'COMMON.CONTACTS'
8984       include 'COMMON.TORSION'
8985       include 'COMMON.VAR'
8986       include 'COMMON.GEO'
8987       include 'COMMON.FFIELD'
8988       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8989      & auxvec1(2),auxmat1(2,2)
8990       logical swap
8991 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8992 C                                                                              C
8993 C      Parallel       Antiparallel                                             C
8994 C                                                                              C
8995 C          o             o                                                     C
8996 C         /l\   /   \   /j\                                                    C
8997 C        /   \ /     \ /   \                                                   C
8998 C       /| o |o       o| o |\                                                  C
8999 C     \ j|/k\|      \  |/k\|l                                                  C
9000 C      \ /   \       \ /   \                                                   C
9001 C       o     \       o     \                                                  C
9002 C       i             i                                                        C
9003 C                                                                              C
9004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9005 C
9006 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9007 C           energy moment and not to the cluster cumulant.
9008 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9009       iti=itype2loc(itype(i))
9010       itj=itype2loc(itype(j))
9011       if (j.lt.nres-1) then
9012         itj1=itype2loc(itype(j+1))
9013       else
9014         itj1=nloctyp
9015       endif
9016       itk=itype2loc(itype(k))
9017       if (k.lt.nres-1) then
9018         itk1=itype2loc(itype(k+1))
9019       else
9020         itk1=nloctyp
9021       endif
9022       itl=itype2loc(itype(l))
9023       if (l.lt.nres-1) then
9024         itl1=itype2loc(itype(l+1))
9025       else
9026         itl1=nloctyp
9027       endif
9028 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9029 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9030 cd     & ' itl',itl,' itl1',itl1
9031 #ifdef MOMENT
9032       if (imat.eq.1) then
9033         s1=dip(3,jj,i)*dip(3,kk,k)
9034       else
9035         s1=dip(2,jj,j)*dip(2,kk,l)
9036       endif
9037 #endif
9038       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9039       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9040       if (j.eq.l+1) then
9041         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9042         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9043       else
9044         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9045         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9046       endif
9047       call transpose2(EUg(1,1,k),auxmat(1,1))
9048       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9049       vv(1)=pizda(1,1)-pizda(2,2)
9050       vv(2)=pizda(2,1)+pizda(1,2)
9051       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9052 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9053 #ifdef MOMENT
9054       eello6_graph4=-(s1+s2+s3+s4)
9055 #else
9056       eello6_graph4=-(s2+s3+s4)
9057 #endif
9058 C Derivatives in gamma(i-1)
9059       if (calc_grad) then
9060       if (i.gt.1) then
9061 #ifdef MOMENT
9062         if (imat.eq.1) then
9063           s1=dipderg(2,jj,i)*dip(3,kk,k)
9064         else
9065           s1=dipderg(4,jj,j)*dip(2,kk,l)
9066         endif
9067 #endif
9068         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9069         if (j.eq.l+1) then
9070           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9071           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9072         else
9073           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9074           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9075         endif
9076         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9077         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9078 cd          write (2,*) 'turn6 derivatives'
9079 #ifdef MOMENT
9080           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9081 #else
9082           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9083 #endif
9084         else
9085 #ifdef MOMENT
9086           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9087 #else
9088           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9089 #endif
9090         endif
9091       endif
9092 C Derivatives in gamma(k-1)
9093 #ifdef MOMENT
9094       if (imat.eq.1) then
9095         s1=dip(3,jj,i)*dipderg(2,kk,k)
9096       else
9097         s1=dip(2,jj,j)*dipderg(4,kk,l)
9098       endif
9099 #endif
9100       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9101       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9102       if (j.eq.l+1) then
9103         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9104         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9105       else
9106         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9107         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9108       endif
9109       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9110       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9111       vv(1)=pizda(1,1)-pizda(2,2)
9112       vv(2)=pizda(2,1)+pizda(1,2)
9113       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9114       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9115 #ifdef MOMENT
9116         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9117 #else
9118         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9119 #endif
9120       else
9121 #ifdef MOMENT
9122         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9123 #else
9124         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9125 #endif
9126       endif
9127 C Derivatives in gamma(j-1) or gamma(l-1)
9128       if (l.eq.j+1 .and. l.gt.1) then
9129         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9130         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9131         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9132         vv(1)=pizda(1,1)-pizda(2,2)
9133         vv(2)=pizda(2,1)+pizda(1,2)
9134         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9135         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9136       else if (j.gt.1) then
9137         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9138         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9139         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9140         vv(1)=pizda(1,1)-pizda(2,2)
9141         vv(2)=pizda(2,1)+pizda(1,2)
9142         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9143         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9144           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9145         else
9146           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9147         endif
9148       endif
9149 C Cartesian derivatives.
9150       do iii=1,2
9151         do kkk=1,5
9152           do lll=1,3
9153 #ifdef MOMENT
9154             if (iii.eq.1) then
9155               if (imat.eq.1) then
9156                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9157               else
9158                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9159               endif
9160             else
9161               if (imat.eq.1) then
9162                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9163               else
9164                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9165               endif
9166             endif
9167 #endif
9168             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9169      &        auxvec(1))
9170             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9171             if (j.eq.l+1) then
9172               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9173      &          b1(1,j+1),auxvec(1))
9174               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9175             else
9176               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9177      &          b1(1,l+1),auxvec(1))
9178               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9179             endif
9180             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9181      &        pizda(1,1))
9182             vv(1)=pizda(1,1)-pizda(2,2)
9183             vv(2)=pizda(2,1)+pizda(1,2)
9184             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9185             if (swap) then
9186               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9187 #ifdef MOMENT
9188                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9189      &             -(s1+s2+s4)
9190 #else
9191                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9192      &             -(s2+s4)
9193 #endif
9194                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9195               else
9196 #ifdef MOMENT
9197                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9198 #else
9199                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9200 #endif
9201                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9202               endif
9203             else
9204 #ifdef MOMENT
9205               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9206 #else
9207               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9208 #endif
9209               if (l.eq.j+1) then
9210                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9211               else
9212                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9213               endif
9214             endif
9215           enddo
9216         enddo
9217       enddo
9218       endif ! calc_grad
9219       return
9220       end
9221 c----------------------------------------------------------------------------
9222       double precision function eello_turn6(i,jj,kk)
9223       implicit real*8 (a-h,o-z)
9224       include 'DIMENSIONS'
9225       include 'DIMENSIONS.ZSCOPT'
9226       include 'COMMON.IOUNITS'
9227       include 'COMMON.CHAIN'
9228       include 'COMMON.DERIV'
9229       include 'COMMON.INTERACT'
9230       include 'COMMON.CONTACTS'
9231       include 'COMMON.TORSION'
9232       include 'COMMON.VAR'
9233       include 'COMMON.GEO'
9234       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9235      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9236      &  ggg1(3),ggg2(3)
9237       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9238      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9239 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9240 C           the respective energy moment and not to the cluster cumulant.
9241       s1=0.0d0
9242       s8=0.0d0
9243       s13=0.0d0
9244 c
9245       eello_turn6=0.0d0
9246       j=i+4
9247       k=i+1
9248       l=i+3
9249       iti=itype2loc(itype(i))
9250       itk=itype2loc(itype(k))
9251       itk1=itype2loc(itype(k+1))
9252       itl=itype2loc(itype(l))
9253       itj=itype2loc(itype(j))
9254 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9255 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9256 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9257 cd        eello6=0.0d0
9258 cd        return
9259 cd      endif
9260 cd      write (iout,*)
9261 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9262 cd     &   ' and',k,l
9263 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9264       do iii=1,2
9265         do kkk=1,5
9266           do lll=1,3
9267             derx_turn(lll,kkk,iii)=0.0d0
9268           enddo
9269         enddo
9270       enddo
9271 cd      eij=1.0d0
9272 cd      ekl=1.0d0
9273 cd      ekont=1.0d0
9274       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9275 cd      eello6_5=0.0d0
9276 cd      write (2,*) 'eello6_5',eello6_5
9277 #ifdef MOMENT
9278       call transpose2(AEA(1,1,1),auxmat(1,1))
9279       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9280       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9281       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9282 #endif
9283       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9284       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9285       s2 = scalar2(b1(1,k),vtemp1(1))
9286 #ifdef MOMENT
9287       call transpose2(AEA(1,1,2),atemp(1,1))
9288       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9289       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9290       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9291 #endif
9292       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9293       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9294       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9295 #ifdef MOMENT
9296       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9297       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9298       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9299       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9300       ss13 = scalar2(b1(1,k),vtemp4(1))
9301       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9302 #endif
9303 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9304 c      s1=0.0d0
9305 c      s2=0.0d0
9306 c      s8=0.0d0
9307 c      s12=0.0d0
9308 c      s13=0.0d0
9309       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9310 C Derivatives in gamma(i+2)
9311       if (calc_grad) then
9312       s1d =0.0d0
9313       s8d =0.0d0
9314 #ifdef MOMENT
9315       call transpose2(AEA(1,1,1),auxmatd(1,1))
9316       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9317       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9318       call transpose2(AEAderg(1,1,2),atempd(1,1))
9319       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9320       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9321 #endif
9322       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9323       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9324       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9325 c      s1d=0.0d0
9326 c      s2d=0.0d0
9327 c      s8d=0.0d0
9328 c      s12d=0.0d0
9329 c      s13d=0.0d0
9330       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9331 C Derivatives in gamma(i+3)
9332 #ifdef MOMENT
9333       call transpose2(AEA(1,1,1),auxmatd(1,1))
9334       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9335       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9336       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9337 #endif
9338       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9339       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9340       s2d = scalar2(b1(1,k),vtemp1d(1))
9341 #ifdef MOMENT
9342       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9343       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9344 #endif
9345       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9346 #ifdef MOMENT
9347       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9348       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9349       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9350 #endif
9351 c      s1d=0.0d0
9352 c      s2d=0.0d0
9353 c      s8d=0.0d0
9354 c      s12d=0.0d0
9355 c      s13d=0.0d0
9356 #ifdef MOMENT
9357       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9358      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9359 #else
9360       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9361      &               -0.5d0*ekont*(s2d+s12d)
9362 #endif
9363 C Derivatives in gamma(i+4)
9364       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9365       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9366       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9367 #ifdef MOMENT
9368       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9369       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9370       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9371 #endif
9372 c      s1d=0.0d0
9373 c      s2d=0.0d0
9374 c      s8d=0.0d0
9375 C      s12d=0.0d0
9376 c      s13d=0.0d0
9377 #ifdef MOMENT
9378       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9379 #else
9380       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9381 #endif
9382 C Derivatives in gamma(i+5)
9383 #ifdef MOMENT
9384       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9385       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9386       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9387 #endif
9388       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9389       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9390       s2d = scalar2(b1(1,k),vtemp1d(1))
9391 #ifdef MOMENT
9392       call transpose2(AEA(1,1,2),atempd(1,1))
9393       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9394       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9395 #endif
9396       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9397       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9398 #ifdef MOMENT
9399       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9400       ss13d = scalar2(b1(1,k),vtemp4d(1))
9401       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9402 #endif
9403 c      s1d=0.0d0
9404 c      s2d=0.0d0
9405 c      s8d=0.0d0
9406 c      s12d=0.0d0
9407 c      s13d=0.0d0
9408 #ifdef MOMENT
9409       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9410      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9411 #else
9412       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9413      &               -0.5d0*ekont*(s2d+s12d)
9414 #endif
9415 C Cartesian derivatives
9416       do iii=1,2
9417         do kkk=1,5
9418           do lll=1,3
9419 #ifdef MOMENT
9420             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9421             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9422             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9423 #endif
9424             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9425             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9426      &          vtemp1d(1))
9427             s2d = scalar2(b1(1,k),vtemp1d(1))
9428 #ifdef MOMENT
9429             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9430             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9431             s8d = -(atempd(1,1)+atempd(2,2))*
9432      &           scalar2(cc(1,1,l),vtemp2(1))
9433 #endif
9434             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9435      &           auxmatd(1,1))
9436             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9437             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9438 c      s1d=0.0d0
9439 c      s2d=0.0d0
9440 c      s8d=0.0d0
9441 c      s12d=0.0d0
9442 c      s13d=0.0d0
9443 #ifdef MOMENT
9444             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9445      &        - 0.5d0*(s1d+s2d)
9446 #else
9447             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9448      &        - 0.5d0*s2d
9449 #endif
9450 #ifdef MOMENT
9451             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9452      &        - 0.5d0*(s8d+s12d)
9453 #else
9454             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9455      &        - 0.5d0*s12d
9456 #endif
9457           enddo
9458         enddo
9459       enddo
9460 #ifdef MOMENT
9461       do kkk=1,5
9462         do lll=1,3
9463           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9464      &      achuj_tempd(1,1))
9465           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9466           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9467           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9468           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9469           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9470      &      vtemp4d(1))
9471           ss13d = scalar2(b1(1,k),vtemp4d(1))
9472           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9473           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9474         enddo
9475       enddo
9476 #endif
9477 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9478 cd     &  16*eel_turn6_num
9479 cd      goto 1112
9480       if (j.lt.nres-1) then
9481         j1=j+1
9482         j2=j-1
9483       else
9484         j1=j-1
9485         j2=j-2
9486       endif
9487       if (l.lt.nres-1) then
9488         l1=l+1
9489         l2=l-1
9490       else
9491         l1=l-1
9492         l2=l-2
9493       endif
9494       do ll=1,3
9495 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9496 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9497 cgrad        ghalf=0.5d0*ggg1(ll)
9498 cd        ghalf=0.0d0
9499         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9500         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9501         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9502      &    +ekont*derx_turn(ll,2,1)
9503         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9504         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9505      &    +ekont*derx_turn(ll,4,1)
9506         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9507         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9508         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9509 cgrad        ghalf=0.5d0*ggg2(ll)
9510 cd        ghalf=0.0d0
9511         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9512      &    +ekont*derx_turn(ll,2,2)
9513         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9514         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9515      &    +ekont*derx_turn(ll,4,2)
9516         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9517         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9518         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9519       enddo
9520 cd      goto 1112
9521 cgrad      do m=i+1,j-1
9522 cgrad        do ll=1,3
9523 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9524 cgrad        enddo
9525 cgrad      enddo
9526 cgrad      do m=k+1,l-1
9527 cgrad        do ll=1,3
9528 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9529 cgrad        enddo
9530 cgrad      enddo
9531 cgrad1112  continue
9532 cgrad      do m=i+2,j2
9533 cgrad        do ll=1,3
9534 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9535 cgrad        enddo
9536 cgrad      enddo
9537 cgrad      do m=k+2,l2
9538 cgrad        do ll=1,3
9539 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9540 cgrad        enddo
9541 cgrad      enddo
9542 cd      do iii=1,nres-3
9543 cd        write (2,*) iii,g_corr6_loc(iii)
9544 cd      enddo
9545       endif ! calc_grad
9546       eello_turn6=ekont*eel_turn6
9547 cd      write (2,*) 'ekont',ekont
9548 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9549       return
9550       end
9551
9552 crc-------------------------------------------------
9553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9554       subroutine Eliptransfer(eliptran)
9555       implicit real*8 (a-h,o-z)
9556       include 'DIMENSIONS'
9557       include 'DIMENSIONS.ZSCOPT'
9558       include 'COMMON.GEO'
9559       include 'COMMON.VAR'
9560       include 'COMMON.LOCAL'
9561       include 'COMMON.CHAIN'
9562       include 'COMMON.DERIV'
9563       include 'COMMON.INTERACT'
9564       include 'COMMON.IOUNITS'
9565       include 'COMMON.CALC'
9566       include 'COMMON.CONTROL'
9567       include 'COMMON.SPLITELE'
9568       include 'COMMON.SBRIDGE'
9569 C this is done by Adasko
9570 C      print *,"wchodze"
9571 C structure of box:
9572 C      water
9573 C--bordliptop-- buffore starts
9574 C--bufliptop--- here true lipid starts
9575 C      lipid
9576 C--buflipbot--- lipid ends buffore starts
9577 C--bordlipbot--buffore ends
9578       eliptran=0.0
9579       do i=1,nres
9580 C       do i=1,1
9581         if (itype(i).eq.ntyp1) cycle
9582
9583         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9584         if (positi.le.0) positi=positi+boxzsize
9585 C        print *,i
9586 C first for peptide groups
9587 c for each residue check if it is in lipid or lipid water border area
9588        if ((positi.gt.bordlipbot)
9589      &.and.(positi.lt.bordliptop)) then
9590 C the energy transfer exist
9591         if (positi.lt.buflipbot) then
9592 C what fraction I am in
9593          fracinbuf=1.0d0-
9594      &        ((positi-bordlipbot)/lipbufthick)
9595 C lipbufthick is thickenes of lipid buffore
9596          sslip=sscalelip(fracinbuf)
9597          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9598          eliptran=eliptran+sslip*pepliptran
9599          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9600          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9601 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9602         elseif (positi.gt.bufliptop) then
9603          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9604          sslip=sscalelip(fracinbuf)
9605          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9606          eliptran=eliptran+sslip*pepliptran
9607          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9608          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9609 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9610 C          print *, "doing sscalefor top part"
9611 C         print *,i,sslip,fracinbuf,ssgradlip
9612         else
9613          eliptran=eliptran+pepliptran
9614 C         print *,"I am in true lipid"
9615         endif
9616 C       else
9617 C       eliptran=elpitran+0.0 ! I am in water
9618        endif
9619        enddo
9620 C       print *, "nic nie bylo w lipidzie?"
9621 C now multiply all by the peptide group transfer factor
9622 C       eliptran=eliptran*pepliptran
9623 C now the same for side chains
9624 CV       do i=1,1
9625        do i=1,nres
9626         if (itype(i).eq.ntyp1) cycle
9627         positi=(mod(c(3,i+nres),boxzsize))
9628         if (positi.le.0) positi=positi+boxzsize
9629 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9630 c for each residue check if it is in lipid or lipid water border area
9631 C       respos=mod(c(3,i+nres),boxzsize)
9632 C       print *,positi,bordlipbot,buflipbot
9633        if ((positi.gt.bordlipbot)
9634      & .and.(positi.lt.bordliptop)) then
9635 C the energy transfer exist
9636         if (positi.lt.buflipbot) then
9637          fracinbuf=1.0d0-
9638      &     ((positi-bordlipbot)/lipbufthick)
9639 C lipbufthick is thickenes of lipid buffore
9640          sslip=sscalelip(fracinbuf)
9641          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9642          eliptran=eliptran+sslip*liptranene(itype(i))
9643          gliptranx(3,i)=gliptranx(3,i)
9644      &+ssgradlip*liptranene(itype(i))
9645          gliptranc(3,i-1)= gliptranc(3,i-1)
9646      &+ssgradlip*liptranene(itype(i))
9647 C         print *,"doing sccale for lower part"
9648         elseif (positi.gt.bufliptop) then
9649          fracinbuf=1.0d0-
9650      &((bordliptop-positi)/lipbufthick)
9651          sslip=sscalelip(fracinbuf)
9652          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9653          eliptran=eliptran+sslip*liptranene(itype(i))
9654          gliptranx(3,i)=gliptranx(3,i)
9655      &+ssgradlip*liptranene(itype(i))
9656          gliptranc(3,i-1)= gliptranc(3,i-1)
9657      &+ssgradlip*liptranene(itype(i))
9658 C          print *, "doing sscalefor top part",sslip,fracinbuf
9659         else
9660          eliptran=eliptran+liptranene(itype(i))
9661 C         print *,"I am in true lipid"
9662         endif
9663         endif ! if in lipid or buffor
9664 C       else
9665 C       eliptran=elpitran+0.0 ! I am in water
9666        enddo
9667        return
9668        end
9669
9670
9671 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9672
9673       SUBROUTINE MATVEC2(A1,V1,V2)
9674       implicit real*8 (a-h,o-z)
9675       include 'DIMENSIONS'
9676       DIMENSION A1(2,2),V1(2),V2(2)
9677 c      DO 1 I=1,2
9678 c        VI=0.0
9679 c        DO 3 K=1,2
9680 c    3     VI=VI+A1(I,K)*V1(K)
9681 c        Vaux(I)=VI
9682 c    1 CONTINUE
9683
9684       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9685       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9686
9687       v2(1)=vaux1
9688       v2(2)=vaux2
9689       END
9690 C---------------------------------------
9691       SUBROUTINE MATMAT2(A1,A2,A3)
9692       implicit real*8 (a-h,o-z)
9693       include 'DIMENSIONS'
9694       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9695 c      DIMENSION AI3(2,2)
9696 c        DO  J=1,2
9697 c          A3IJ=0.0
9698 c          DO K=1,2
9699 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9700 c          enddo
9701 c          A3(I,J)=A3IJ
9702 c       enddo
9703 c      enddo
9704
9705       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9706       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9707       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9708       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9709
9710       A3(1,1)=AI3_11
9711       A3(2,1)=AI3_21
9712       A3(1,2)=AI3_12
9713       A3(2,2)=AI3_22
9714       END
9715
9716 c-------------------------------------------------------------------------
9717       double precision function scalar2(u,v)
9718       implicit none
9719       double precision u(2),v(2)
9720       double precision sc
9721       integer i
9722       scalar2=u(1)*v(1)+u(2)*v(2)
9723       return
9724       end
9725
9726 C-----------------------------------------------------------------------------
9727
9728       subroutine transpose2(a,at)
9729       implicit none
9730       double precision a(2,2),at(2,2)
9731       at(1,1)=a(1,1)
9732       at(1,2)=a(2,1)
9733       at(2,1)=a(1,2)
9734       at(2,2)=a(2,2)
9735       return
9736       end
9737 c--------------------------------------------------------------------------
9738       subroutine transpose(n,a,at)
9739       implicit none
9740       integer n,i,j
9741       double precision a(n,n),at(n,n)
9742       do i=1,n
9743         do j=1,n
9744           at(j,i)=a(i,j)
9745         enddo
9746       enddo
9747       return
9748       end
9749 C---------------------------------------------------------------------------
9750       subroutine prodmat3(a1,a2,kk,transp,prod)
9751       implicit none
9752       integer i,j
9753       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9754       logical transp
9755 crc      double precision auxmat(2,2),prod_(2,2)
9756
9757       if (transp) then
9758 crc        call transpose2(kk(1,1),auxmat(1,1))
9759 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9760 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9761
9762            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9763      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9764            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9765      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9766            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9767      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9768            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9769      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9770
9771       else
9772 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9773 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9774
9775            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9776      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9777            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9778      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9779            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9780      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9781            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9782      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9783
9784       endif
9785 c      call transpose2(a2(1,1),a2t(1,1))
9786
9787 crc      print *,transp
9788 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9789 crc      print *,((prod(i,j),i=1,2),j=1,2)
9790
9791       return
9792       end
9793 C-----------------------------------------------------------------------------
9794       double precision function scalar(u,v)
9795       implicit none
9796       double precision u(3),v(3)
9797       double precision sc
9798       integer i
9799       sc=0.0d0
9800       do i=1,3
9801         sc=sc+u(i)*v(i)
9802       enddo
9803       scalar=sc
9804       return
9805       end
9806 C-----------------------------------------------------------------------
9807       double precision function sscale(r)
9808       double precision r,gamm
9809       include "COMMON.SPLITELE"
9810       if(r.lt.r_cut-rlamb) then
9811         sscale=1.0d0
9812       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9813         gamm=(r-(r_cut-rlamb))/rlamb
9814         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9815       else
9816         sscale=0d0
9817       endif
9818       return
9819       end
9820 C-----------------------------------------------------------------------
9821 C-----------------------------------------------------------------------
9822       double precision function sscagrad(r)
9823       double precision r,gamm
9824       include "COMMON.SPLITELE"
9825       if(r.lt.r_cut-rlamb) then
9826         sscagrad=0.0d0
9827       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9828         gamm=(r-(r_cut-rlamb))/rlamb
9829         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9830       else
9831         sscagrad=0.0d0
9832       endif
9833       return
9834       end
9835 C-----------------------------------------------------------------------
9836 C-----------------------------------------------------------------------
9837       double precision function sscalelip(r)
9838       double precision r,gamm
9839       include "COMMON.SPLITELE"
9840 C      if(r.lt.r_cut-rlamb) then
9841 C        sscale=1.0d0
9842 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9843 C        gamm=(r-(r_cut-rlamb))/rlamb
9844         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9845 C      else
9846 C        sscale=0d0
9847 C      endif
9848       return
9849       end
9850 C-----------------------------------------------------------------------
9851       double precision function sscagradlip(r)
9852       double precision r,gamm
9853       include "COMMON.SPLITELE"
9854 C     if(r.lt.r_cut-rlamb) then
9855 C        sscagrad=0.0d0
9856 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9857 C        gamm=(r-(r_cut-rlamb))/rlamb
9858         sscagradlip=r*(6*r-6.0d0)
9859 C      else
9860 C        sscagrad=0.0d0
9861 C      endif
9862       return
9863       end
9864
9865 C-----------------------------------------------------------------------
9866        subroutine set_shield_fac
9867       implicit real*8 (a-h,o-z)
9868       include 'DIMENSIONS'
9869       include 'DIMENSIONS.ZSCOPT'
9870       include 'COMMON.CHAIN'
9871       include 'COMMON.DERIV'
9872       include 'COMMON.IOUNITS'
9873       include 'COMMON.SHIELD'
9874       include 'COMMON.INTERACT'
9875 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9876       double precision div77_81/0.974996043d0/,
9877      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9878
9879 C the vector between center of side_chain and peptide group
9880        double precision pep_side(3),long,side_calf(3),
9881      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9882      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9883 C the line belowe needs to be changed for FGPROC>1
9884       do i=1,nres-1
9885       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9886       ishield_list(i)=0
9887 Cif there two consequtive dummy atoms there is no peptide group between them
9888 C the line below has to be changed for FGPROC>1
9889       VolumeTotal=0.0
9890       do k=1,nres
9891        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9892        dist_pep_side=0.0
9893        dist_side_calf=0.0
9894        do j=1,3
9895 C first lets set vector conecting the ithe side-chain with kth side-chain
9896       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9897 C      pep_side(j)=2.0d0
9898 C and vector conecting the side-chain with its proper calfa
9899       side_calf(j)=c(j,k+nres)-c(j,k)
9900 C      side_calf(j)=2.0d0
9901       pept_group(j)=c(j,i)-c(j,i+1)
9902 C lets have their lenght
9903       dist_pep_side=pep_side(j)**2+dist_pep_side
9904       dist_side_calf=dist_side_calf+side_calf(j)**2
9905       dist_pept_group=dist_pept_group+pept_group(j)**2
9906       enddo
9907        dist_pep_side=dsqrt(dist_pep_side)
9908        dist_pept_group=dsqrt(dist_pept_group)
9909        dist_side_calf=dsqrt(dist_side_calf)
9910       do j=1,3
9911         pep_side_norm(j)=pep_side(j)/dist_pep_side
9912         side_calf_norm(j)=dist_side_calf
9913       enddo
9914 C now sscale fraction
9915        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9916 C       print *,buff_shield,"buff"
9917 C now sscale
9918         if (sh_frac_dist.le.0.0) cycle
9919 C If we reach here it means that this side chain reaches the shielding sphere
9920 C Lets add him to the list for gradient
9921         ishield_list(i)=ishield_list(i)+1
9922 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9923 C this list is essential otherwise problem would be O3
9924         shield_list(ishield_list(i),i)=k
9925 C Lets have the sscale value
9926         if (sh_frac_dist.gt.1.0) then
9927          scale_fac_dist=1.0d0
9928          do j=1,3
9929          sh_frac_dist_grad(j)=0.0d0
9930          enddo
9931         else
9932          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9933      &                   *(2.0*sh_frac_dist-3.0d0)
9934          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9935      &                  /dist_pep_side/buff_shield*0.5
9936 C remember for the final gradient multiply sh_frac_dist_grad(j)
9937 C for side_chain by factor -2 !
9938          do j=1,3
9939          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9940 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9941 C     &                    sh_frac_dist_grad(j)
9942          enddo
9943         endif
9944 C        if ((i.eq.3).and.(k.eq.2)) then
9945 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9946 C     & ,"TU"
9947 C        endif
9948
9949 C this is what is now we have the distance scaling now volume...
9950       short=short_r_sidechain(itype(k))
9951       long=long_r_sidechain(itype(k))
9952       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9953 C now costhet_grad
9954 C       costhet=0.0d0
9955        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9956 C       costhet_fac=0.0d0
9957        do j=1,3
9958          costhet_grad(j)=costhet_fac*pep_side(j)
9959        enddo
9960 C remember for the final gradient multiply costhet_grad(j)
9961 C for side_chain by factor -2 !
9962 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9963 C pep_side0pept_group is vector multiplication
9964       pep_side0pept_group=0.0
9965       do j=1,3
9966       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9967       enddo
9968       cosalfa=(pep_side0pept_group/
9969      & (dist_pep_side*dist_side_calf))
9970       fac_alfa_sin=1.0-cosalfa**2
9971       fac_alfa_sin=dsqrt(fac_alfa_sin)
9972       rkprim=fac_alfa_sin*(long-short)+short
9973 C now costhet_grad
9974        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9975        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9976
9977        do j=1,3
9978          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9979      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9980      &*(long-short)/fac_alfa_sin*cosalfa/
9981      &((dist_pep_side*dist_side_calf))*
9982      &((side_calf(j))-cosalfa*
9983      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9984
9985         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9986      &*(long-short)/fac_alfa_sin*cosalfa
9987      &/((dist_pep_side*dist_side_calf))*
9988      &(pep_side(j)-
9989      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9990        enddo
9991
9992       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9993      &                    /VSolvSphere_div
9994      &                    *wshield
9995 C now the gradient...
9996 C grad_shield is gradient of Calfa for peptide groups
9997 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9998 C     &               costhet,cosphi
9999 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10000 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10001       do j=1,3
10002       grad_shield(j,i)=grad_shield(j,i)
10003 C gradient po skalowaniu
10004      &                +(sh_frac_dist_grad(j)
10005 C  gradient po costhet
10006      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10007      &-scale_fac_dist*(cosphi_grad_long(j))
10008      &/(1.0-cosphi) )*div77_81
10009      &*VofOverlap
10010 C grad_shield_side is Cbeta sidechain gradient
10011       grad_shield_side(j,ishield_list(i),i)=
10012      &        (sh_frac_dist_grad(j)*(-2.0d0)
10013      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10014      &       +scale_fac_dist*(cosphi_grad_long(j))
10015      &        *2.0d0/(1.0-cosphi))
10016      &        *div77_81*VofOverlap
10017
10018        grad_shield_loc(j,ishield_list(i),i)=
10019      &   scale_fac_dist*cosphi_grad_loc(j)
10020      &        *2.0d0/(1.0-cosphi)
10021      &        *div77_81*VofOverlap
10022       enddo
10023       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10024       enddo
10025       fac_shield(i)=VolumeTotal*div77_81+div4_81
10026 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10027       enddo
10028       return
10029       end
10030 C--------------------------------------------------------------------------
10031 C first for shielding is setting of function of side-chains
10032        subroutine set_shield_fac2
10033       implicit real*8 (a-h,o-z)
10034       include 'DIMENSIONS'
10035       include 'DIMENSIONS.ZSCOPT'
10036       include 'COMMON.CHAIN'
10037       include 'COMMON.DERIV'
10038       include 'COMMON.IOUNITS'
10039       include 'COMMON.SHIELD'
10040       include 'COMMON.INTERACT'
10041 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10042       double precision div77_81/0.974996043d0/,
10043      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10044
10045 C the vector between center of side_chain and peptide group
10046        double precision pep_side(3),long,side_calf(3),
10047      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10048      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10049 C the line belowe needs to be changed for FGPROC>1
10050       do i=1,nres-1
10051       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10052       ishield_list(i)=0
10053 Cif there two consequtive dummy atoms there is no peptide group between them
10054 C the line below has to be changed for FGPROC>1
10055       VolumeTotal=0.0
10056       do k=1,nres
10057        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10058        dist_pep_side=0.0
10059        dist_side_calf=0.0
10060        do j=1,3
10061 C first lets set vector conecting the ithe side-chain with kth side-chain
10062       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10063 C      pep_side(j)=2.0d0
10064 C and vector conecting the side-chain with its proper calfa
10065       side_calf(j)=c(j,k+nres)-c(j,k)
10066 C      side_calf(j)=2.0d0
10067       pept_group(j)=c(j,i)-c(j,i+1)
10068 C lets have their lenght
10069       dist_pep_side=pep_side(j)**2+dist_pep_side
10070       dist_side_calf=dist_side_calf+side_calf(j)**2
10071       dist_pept_group=dist_pept_group+pept_group(j)**2
10072       enddo
10073        dist_pep_side=dsqrt(dist_pep_side)
10074        dist_pept_group=dsqrt(dist_pept_group)
10075        dist_side_calf=dsqrt(dist_side_calf)
10076       do j=1,3
10077         pep_side_norm(j)=pep_side(j)/dist_pep_side
10078         side_calf_norm(j)=dist_side_calf
10079       enddo
10080 C now sscale fraction
10081        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10082 C       print *,buff_shield,"buff"
10083 C now sscale
10084         if (sh_frac_dist.le.0.0) cycle
10085 C If we reach here it means that this side chain reaches the shielding sphere
10086 C Lets add him to the list for gradient
10087         ishield_list(i)=ishield_list(i)+1
10088 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10089 C this list is essential otherwise problem would be O3
10090         shield_list(ishield_list(i),i)=k
10091 C Lets have the sscale value
10092         if (sh_frac_dist.gt.1.0) then
10093          scale_fac_dist=1.0d0
10094          do j=1,3
10095          sh_frac_dist_grad(j)=0.0d0
10096          enddo
10097         else
10098          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10099      &                   *(2.0d0*sh_frac_dist-3.0d0)
10100          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10101      &                  /dist_pep_side/buff_shield*0.5d0
10102 C remember for the final gradient multiply sh_frac_dist_grad(j)
10103 C for side_chain by factor -2 !
10104          do j=1,3
10105          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10106 C         sh_frac_dist_grad(j)=0.0d0
10107 C         scale_fac_dist=1.0d0
10108 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10109 C     &                    sh_frac_dist_grad(j)
10110          enddo
10111         endif
10112 C this is what is now we have the distance scaling now volume...
10113       short=short_r_sidechain(itype(k))
10114       long=long_r_sidechain(itype(k))
10115       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10116       sinthet=short/dist_pep_side*costhet
10117 C now costhet_grad
10118 C       costhet=0.6d0
10119 C       sinthet=0.8
10120        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10121 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10122 C     &             -short/dist_pep_side**2/costhet)
10123 C       costhet_fac=0.0d0
10124        do j=1,3
10125          costhet_grad(j)=costhet_fac*pep_side(j)
10126        enddo
10127 C remember for the final gradient multiply costhet_grad(j)
10128 C for side_chain by factor -2 !
10129 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10130 C pep_side0pept_group is vector multiplication
10131       pep_side0pept_group=0.0d0
10132       do j=1,3
10133       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10134       enddo
10135       cosalfa=(pep_side0pept_group/
10136      & (dist_pep_side*dist_side_calf))
10137       fac_alfa_sin=1.0d0-cosalfa**2
10138       fac_alfa_sin=dsqrt(fac_alfa_sin)
10139       rkprim=fac_alfa_sin*(long-short)+short
10140 C      rkprim=short
10141
10142 C now costhet_grad
10143        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10144 C       cosphi=0.6
10145        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10146        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10147      &      dist_pep_side**2)
10148 C       sinphi=0.8
10149        do j=1,3
10150          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10151      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10152      &*(long-short)/fac_alfa_sin*cosalfa/
10153      &((dist_pep_side*dist_side_calf))*
10154      &((side_calf(j))-cosalfa*
10155      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10156 C       cosphi_grad_long(j)=0.0d0
10157         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10158      &*(long-short)/fac_alfa_sin*cosalfa
10159      &/((dist_pep_side*dist_side_calf))*
10160      &(pep_side(j)-
10161      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10162 C       cosphi_grad_loc(j)=0.0d0
10163        enddo
10164 C      print *,sinphi,sinthet
10165       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10166      &                    /VSolvSphere_div
10167 C     &                    *wshield
10168 C now the gradient...
10169       do j=1,3
10170       grad_shield(j,i)=grad_shield(j,i)
10171 C gradient po skalowaniu
10172      &                +(sh_frac_dist_grad(j)*VofOverlap
10173 C  gradient po costhet
10174      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10175      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10176      &       sinphi/sinthet*costhet*costhet_grad(j)
10177      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10178      & )*wshield
10179 C grad_shield_side is Cbeta sidechain gradient
10180       grad_shield_side(j,ishield_list(i),i)=
10181      &        (sh_frac_dist_grad(j)*(-2.0d0)
10182      &        *VofOverlap
10183      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10184      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10185      &       sinphi/sinthet*costhet*costhet_grad(j)
10186      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10187      &       )*wshield
10188
10189        grad_shield_loc(j,ishield_list(i),i)=
10190      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10191      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10192      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10193      &        ))
10194      &        *wshield
10195       enddo
10196       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10197       enddo
10198       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10199 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10200 c     &  " wshield",wshield
10201 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10202       enddo
10203       return
10204       end
10205 C--------------------------------------------------------------------------
10206       double precision function tschebyshev(m,n,x,y)
10207       implicit none
10208       include "DIMENSIONS"
10209       integer i,m,n
10210       double precision x(n),y,yy(0:maxvar),aux
10211 c Tschebyshev polynomial. Note that the first term is omitted
10212 c m=0: the constant term is included
10213 c m=1: the constant term is not included
10214       yy(0)=1.0d0
10215       yy(1)=y
10216       do i=2,n
10217         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10218       enddo
10219       aux=0.0d0
10220       do i=m,n
10221         aux=aux+x(i)*yy(i)
10222       enddo
10223       tschebyshev=aux
10224       return
10225       end
10226 C--------------------------------------------------------------------------
10227       double precision function gradtschebyshev(m,n,x,y)
10228       implicit none
10229       include "DIMENSIONS"
10230       integer i,m,n
10231       double precision x(n+1),y,yy(0:maxvar),aux
10232 c Tschebyshev polynomial. Note that the first term is omitted
10233 c m=0: the constant term is included
10234 c m=1: the constant term is not included
10235       yy(0)=1.0d0
10236       yy(1)=2.0d0*y
10237       do i=2,n
10238         yy(i)=2*y*yy(i-1)-yy(i-2)
10239       enddo
10240       aux=0.0d0
10241       do i=m,n
10242         aux=aux+x(i+1)*yy(i)*(i+1)
10243 C        print *, x(i+1),yy(i),i
10244       enddo
10245       gradtschebyshev=aux
10246       return
10247       end
10248 c----------------------------------------------------------------------------
10249       double precision function sscale2(r,r_cut,r0,rlamb)
10250       implicit none
10251       double precision r,gamm,r_cut,r0,rlamb,rr
10252       rr = dabs(r-r0)
10253 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10254 c      write (2,*) "rr",rr
10255       if(rr.lt.r_cut-rlamb) then
10256         sscale2=1.0d0
10257       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10258         gamm=(rr-(r_cut-rlamb))/rlamb
10259         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10260       else
10261         sscale2=0d0
10262       endif
10263       return
10264       end
10265 C-----------------------------------------------------------------------
10266       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10267       implicit none
10268       double precision r,gamm,r_cut,r0,rlamb,rr
10269       rr = dabs(r-r0)
10270       if(rr.lt.r_cut-rlamb) then
10271         sscalgrad2=0.0d0
10272       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10273         gamm=(rr-(r_cut-rlamb))/rlamb
10274         if (r.ge.r0) then
10275           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10276         else
10277           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10278         endif
10279       else
10280         sscalgrad2=0.0d0
10281       endif
10282       return
10283       end
10284 c----------------------------------------------------------------------------
10285       subroutine e_saxs(Esaxs_constr)
10286       implicit none
10287       include 'DIMENSIONS'
10288       include 'DIMENSIONS.ZSCOPT'
10289       include 'DIMENSIONS.FREE'
10290 #ifdef MPI
10291       include "mpif.h"
10292       include "COMMON.SETUP"
10293       integer IERR
10294 #endif
10295       include 'COMMON.SBRIDGE'
10296       include 'COMMON.CHAIN'
10297       include 'COMMON.GEO'
10298       include 'COMMON.LOCAL'
10299       include 'COMMON.INTERACT'
10300       include 'COMMON.VAR'
10301       include 'COMMON.IOUNITS'
10302       include 'COMMON.DERIV'
10303       include 'COMMON.CONTROL'
10304       include 'COMMON.NAMES'
10305       include 'COMMON.FFIELD'
10306       include 'COMMON.LANGEVIN'
10307       include 'COMMON.SAXS'
10308 c
10309       double precision Esaxs_constr
10310       integer i,iint,j,k,l
10311       double precision PgradC(maxSAXS,3,maxres),
10312      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10313 #ifdef MPI
10314       double precision PgradC_(maxSAXS,3,maxres),
10315      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10316 #endif
10317       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10318      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10319      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10320      & auxX,auxX1,CACAgrad,Cnorm
10321       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10322       double precision dist
10323       external dist
10324 c  SAXS restraint penalty function
10325 #ifdef DEBUG
10326       write(iout,*) "------- SAXS penalty function start -------"
10327       write (iout,*) "nsaxs",nsaxs
10328       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10329       write (iout,*) "Psaxs"
10330       do i=1,nsaxs
10331         write (iout,'(i5,e15.5)') i, Psaxs(i)
10332       enddo
10333 #endif
10334       Esaxs_constr = 0.0d0
10335       do k=1,nsaxs
10336         Pcalc(k)=0.0d0
10337         do j=1,nres
10338           do l=1,3
10339             PgradC(k,l,j)=0.0d0
10340             PgradX(k,l,j)=0.0d0
10341           enddo
10342         enddo
10343       enddo
10344       do i=iatsc_s,iatsc_e
10345        if (itype(i).eq.ntyp1) cycle
10346        do iint=1,nint_gr(i)
10347          do j=istart(i,iint),iend(i,iint)
10348            if (itype(j).eq.ntyp1) cycle
10349 #ifdef ALLSAXS
10350            dijCACA=dist(i,j)
10351            dijCASC=dist(i,j+nres)
10352            dijSCCA=dist(i+nres,j)
10353            dijSCSC=dist(i+nres,j+nres)
10354            sigma2CACA=2.0d0/(pstok**2)
10355            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10356            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10357            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10358            do k=1,nsaxs
10359              dk = distsaxs(k)
10360              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10361              if (itype(j).ne.10) then
10362              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10363              else
10364              endif
10365              expCASC = 0.0d0
10366              if (itype(i).ne.10) then
10367              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10368              else
10369              expSCCA = 0.0d0
10370              endif
10371              if (itype(i).ne.10 .and. itype(j).ne.10) then
10372              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10373              else
10374              expSCSC = 0.0d0
10375              endif
10376              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10377 #ifdef DEBUG
10378              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10379 #endif
10380              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10381              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10382              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10383              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10384              do l=1,3
10385 c CA CA
10386                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10387                PgradC(k,l,i) = PgradC(k,l,i)-aux
10388                PgradC(k,l,j) = PgradC(k,l,j)+aux
10389 c CA SC
10390                if (itype(j).ne.10) then
10391                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10392                PgradC(k,l,i) = PgradC(k,l,i)-aux
10393                PgradC(k,l,j) = PgradC(k,l,j)+aux
10394                PgradX(k,l,j) = PgradX(k,l,j)+aux
10395                endif
10396 c SC CA
10397                if (itype(i).ne.10) then
10398                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10399                PgradX(k,l,i) = PgradX(k,l,i)-aux
10400                PgradC(k,l,i) = PgradC(k,l,i)-aux
10401                PgradC(k,l,j) = PgradC(k,l,j)+aux
10402                endif
10403 c SC SC
10404                if (itype(i).ne.10 .and. itype(j).ne.10) then
10405                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10406                PgradC(k,l,i) = PgradC(k,l,i)-aux
10407                PgradC(k,l,j) = PgradC(k,l,j)+aux
10408                PgradX(k,l,i) = PgradX(k,l,i)-aux
10409                PgradX(k,l,j) = PgradX(k,l,j)+aux
10410                endif
10411              enddo ! l
10412            enddo ! k
10413 #else
10414            dijCACA=dist(i,j)
10415            sigma2CACA=scal_rad**2*0.25d0/
10416      &        (restok(itype(j))**2+restok(itype(i))**2)
10417
10418            IF (saxs_cutoff.eq.0) THEN
10419            do k=1,nsaxs
10420              dk = distsaxs(k)
10421              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10422              Pcalc(k) = Pcalc(k)+expCACA
10423              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10424              do l=1,3
10425                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10426                PgradC(k,l,i) = PgradC(k,l,i)-aux
10427                PgradC(k,l,j) = PgradC(k,l,j)+aux
10428              enddo ! l
10429            enddo ! k
10430            ELSE
10431            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10432            do k=1,nsaxs
10433              dk = distsaxs(k)
10434 c             write (2,*) "ijk",i,j,k
10435              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10436              if (sss2.eq.0.0d0) cycle
10437              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10438              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10439              Pcalc(k) = Pcalc(k)+expCACA
10440 #ifdef DEBUG
10441              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10442 #endif
10443              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10444      &             ssgrad2*expCACA/sss2
10445              do l=1,3
10446 c CA CA
10447                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10448                PgradC(k,l,i) = PgradC(k,l,i)+aux
10449                PgradC(k,l,j) = PgradC(k,l,j)-aux
10450              enddo ! l
10451            enddo ! k
10452            ENDIF
10453 #endif
10454          enddo ! j
10455        enddo ! iint
10456       enddo ! i
10457 #ifdef MPI
10458       if (nfgtasks.gt.1) then
10459         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10460      &    MPI_SUM,king,FG_COMM,IERR)
10461         if (fg_rank.eq.king) then
10462           do k=1,nsaxs
10463             Pcalc(k) = Pcalc_(k)
10464           enddo
10465         endif
10466         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10467      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10468         if (fg_rank.eq.king) then
10469           do i=1,nres
10470             do l=1,3
10471               do k=1,nsaxs
10472                 PgradC(k,l,i) = PgradC_(k,l,i)
10473               enddo
10474             enddo
10475           enddo
10476         endif
10477 #ifdef ALLSAXS
10478         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10479      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10480         if (fg_rank.eq.king) then
10481           do i=1,nres
10482             do l=1,3
10483               do k=1,nsaxs
10484                 PgradX(k,l,i) = PgradX_(k,l,i)
10485               enddo
10486             enddo
10487           enddo
10488         endif
10489 #endif
10490       endif
10491 #endif
10492 #ifdef MPI
10493       if (fg_rank.eq.king) then
10494 #endif
10495       Cnorm = 0.0d0
10496       do k=1,nsaxs
10497         Cnorm = Cnorm + Pcalc(k)
10498       enddo
10499       Esaxs_constr = dlog(Cnorm)-wsaxs0
10500       do k=1,nsaxs
10501         if (Pcalc(k).gt.0.0d0)
10502      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10503 #ifdef DEBUG
10504         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10505 #endif
10506       enddo
10507 #ifdef DEBUG
10508       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10509 #endif
10510       do i=nnt,nct
10511         do l=1,3
10512           auxC=0.0d0
10513           auxC1=0.0d0
10514           auxX=0.0d0
10515           auxX1=0.d0
10516           do k=1,nsaxs
10517             if (Pcalc(k).gt.0)
10518      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10519             auxC1 = auxC1+PgradC(k,l,i)
10520 #ifdef ALLSAXS
10521             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10522             auxX1 = auxX1+PgradX(k,l,i)
10523 #endif
10524           enddo
10525           gsaxsC(l,i) = auxC - auxC1/Cnorm
10526 #ifdef ALLSAXS
10527           gsaxsX(l,i) = auxX - auxX1/Cnorm
10528 #endif
10529 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10530 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10531         enddo
10532       enddo
10533 #ifdef MPI
10534       endif
10535 #endif
10536       return
10537       end
10538 c----------------------------------------------------------------------------
10539       subroutine e_saxsC(Esaxs_constr)
10540       implicit none
10541       include 'DIMENSIONS'
10542       include 'DIMENSIONS.ZSCOPT'
10543       include 'DIMENSIONS.FREE'
10544 #ifdef MPI
10545       include "mpif.h"
10546       include "COMMON.SETUP"
10547       integer IERR
10548 #endif
10549       include 'COMMON.SBRIDGE'
10550       include 'COMMON.CHAIN'
10551       include 'COMMON.GEO'
10552       include 'COMMON.LOCAL'
10553       include 'COMMON.INTERACT'
10554       include 'COMMON.VAR'
10555       include 'COMMON.IOUNITS'
10556       include 'COMMON.DERIV'
10557       include 'COMMON.CONTROL'
10558       include 'COMMON.NAMES'
10559       include 'COMMON.FFIELD'
10560       include 'COMMON.LANGEVIN'
10561       include 'COMMON.SAXS'
10562 c
10563       double precision Esaxs_constr
10564       integer i,iint,j,k,l
10565       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10566 #ifdef MPI
10567       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10568 #endif
10569       double precision dk,dijCASPH,dijSCSPH,
10570      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10571      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10572      & auxX,auxX1,Cnorm
10573 c  SAXS restraint penalty function
10574 #ifdef DEBUG
10575       write(iout,*) "------- SAXS penalty function start -------"
10576       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10577      & " isaxs_end",isaxs_end
10578       write (iout,*) "nnt",nnt," ntc",nct
10579       do i=nnt,nct
10580         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10581      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10582       enddo
10583       do i=nnt,nct
10584         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10585       enddo
10586 #endif
10587       Esaxs_constr = 0.0d0
10588       logPtot=0.0d0
10589       do j=isaxs_start,isaxs_end
10590         Pcalc=0.0d0
10591         do i=1,nres
10592           do l=1,3
10593             PgradC(l,i)=0.0d0
10594             PgradX(l,i)=0.0d0
10595           enddo
10596         enddo
10597         do i=nnt,nct
10598           dijCASPH=0.0d0
10599           dijSCSPH=0.0d0
10600           do l=1,3
10601             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10602           enddo
10603           if (itype(i).ne.10) then
10604           do l=1,3
10605             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10606           enddo
10607           endif
10608           sigma2CA=2.0d0/pstok**2
10609           sigma2SC=4.0d0/restok(itype(i))**2
10610           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10611           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10612           Pcalc = Pcalc+expCASPH+expSCSPH
10613 #ifdef DEBUG
10614           write(*,*) "processor i j Pcalc",
10615      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10616 #endif
10617           CASPHgrad = sigma2CA*expCASPH
10618           SCSPHgrad = sigma2SC*expSCSPH
10619           do l=1,3
10620             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10621             PgradX(l,i) = PgradX(l,i) + aux
10622             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10623           enddo ! l
10624         enddo ! i
10625         do i=nnt,nct
10626           do l=1,3
10627             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10628             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10629           enddo
10630         enddo
10631         logPtot = logPtot - dlog(Pcalc)
10632 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10633 c     &    " logPtot",logPtot
10634       enddo ! j
10635 #ifdef MPI
10636       if (nfgtasks.gt.1) then
10637 c        write (iout,*) "logPtot before reduction",logPtot
10638         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10639      &    MPI_SUM,king,FG_COMM,IERR)
10640         logPtot = logPtot_
10641 c        write (iout,*) "logPtot after reduction",logPtot
10642         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10643      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10644         if (fg_rank.eq.king) then
10645           do i=1,nres
10646             do l=1,3
10647               gsaxsC(l,i) = gsaxsC_(l,i)
10648             enddo
10649           enddo
10650         endif
10651         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10652      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10653         if (fg_rank.eq.king) then
10654           do i=1,nres
10655             do l=1,3
10656               gsaxsX(l,i) = gsaxsX_(l,i)
10657             enddo
10658           enddo
10659         endif
10660       endif
10661 #endif
10662       Esaxs_constr = logPtot
10663       return
10664       end
10665