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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11
  12       include 'COMMON.IOUNITS'
  13       double precision energia(0:max_ene),energia1(0:max_ene+1)
  14       include 'COMMON.FFIELD'
  15       include 'COMMON.DERIV'
  16       include 'COMMON.INTERACT'
  17       include 'COMMON.SBRIDGE'
  18       include 'COMMON.CHAIN'
  19       include 'COMMON.SHIELD'
  20       include 'COMMON.CONTROL'
  21       include 'COMMON.TORCNSTR'
  22       double precision fact(6)
  23 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  24 c      call flush(iout)
  25 cd    print *,'nnt=',nnt,' nct=',nct
  26 C
  27 C Compute the side-chain and electrostatic interaction energy
  28 C
  29       goto (101,102,103,104,105) ipot
  30 C Lennard-Jones potential.
  31   101 call elj(evdw,evdw_t)
  32 cd    print '(a)','Exit ELJ'
  33       goto 106
  34 C Lennard-Jones-Kihara potential (shifted).
  35   102 call eljk(evdw,evdw_t)
  36       goto 106
  37 C Berne-Pechukas potential (dilated LJ, angular dependence).
  38   103 call ebp(evdw,evdw_t)
  39       goto 106
  40 C Gay-Berne potential (shifted LJ, angular dependence).
  41   104 call egb(evdw,evdw_t)
  42       goto 106
  43 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  44   105 call egbv(evdw,evdw_t)
  45 C
  46 C Calculate electrostatic (H-bonding) energy of the main chain.
  47 C
  48   106 continue
  49 c      write (iout,*) "Sidechain"
  50       call flush(iout)
  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 c      call flush(iout)
  60
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68
  69       call ebond(estr)
  70 C       write (iout,*) "estr",estr
  71 C
  72 C Calculate the disulfide-bridge and other energy and the contributions
  73 C from other distance constraints.
  74 cd    print *,'Calling EHPB'
  75       call edis(ehpb)
  76 cd    print *,'EHPB exitted succesfully.'
  77 C
  78 C Calculate the virtual-bond-angle energy.
  79 C
  80 C      print *,'Bend energy finished.'
  81       if (wang.gt.0d0) then
  82        if (tor_mode.eq.0) then
  83          call ebend(ebe)
  84        else
  85 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  86 C energy function
  87          call ebend_kcc(ebe)
  88        endif
  89       else
  90         ebe=0.0d0
  91       endif
  92       ethetacnstr=0.0d0
  93       if (with_theta_constr) call etheta_constr(ethetacnstr)
  94 c      call ebend(ebe,ethetacnstr)
  95 cd    print *,'Bend energy finished.'
  96 C
  97 C Calculate the SC local energy.
  98 C
  99       call esc(escloc)
 100 C       print *,'SCLOC energy finished.'
 101 C
 102 C Calculate the virtual-bond torsional energy.
 103 C
 104       if (wtor.gt.0.0d0) then
 105          if (tor_mode.eq.0) then
 106            call etor(etors,fact(1))
 107          else
 108 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 109 C energy function
 110            call etor_kcc(etors,fact(1))
 111          endif
 112       else
 113         etors=0.0d0
 114       endif
 115       edihcnstr=0.0d0
 116       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 117 c      print *,"Processor",myrank," computed Utor"
 118 C
 119 C 6/23/01 Calculate double-torsional energy
 120 C
 121       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 122         call etor_d(etors_d,fact(2))
 123       else
 124         etors_d=0
 125       endif
 126 c      print *,"Processor",myrank," computed Utord"
 127 C
 128       call eback_sc_corr(esccor)
 129
 130       if (wliptran.gt.0) then
 131         call Eliptransfer(eliptran)
 132       endif
 133
 134 C
 135 C 12/1/95 Multi-body terms
 136 C
 137       n_corr=0
 138       n_corr1=0
 139       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 140      &    .or. wturn6.gt.0.0d0) then
 141 c         write(iout,*)"calling multibody_eello"
 142          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 143 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 144 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 145       else
 146          ecorr=0.0d0
 147          ecorr5=0.0d0
 148          ecorr6=0.0d0
 149          eturn6=0.0d0
 150       endif
 151       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 152 c         write (iout,*) "Calling multibody_hbond"
 153          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 154       endif
 155 c      write (iout,*) "NSAXS",nsaxs
 156       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 157         call e_saxs(Esaxs_constr)
 158 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 159       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 160         call e_saxsC(Esaxs_constr)
 161 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 162       else
 163         Esaxs_constr = 0.0d0
 164       endif
 165 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 166 #ifdef SPLITELE
 167       if (shield_mode.gt.0) then
 168       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 169      & +welec*fact(1)*ees
 170      & +fact(1)*wvdwpp*evdw1
 171      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 172      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 173      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 174      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 175      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 176      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 177      & +wliptran*eliptran+wsaxs*esaxs_constr
 178       else
 179       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 180      & +wvdwpp*evdw1
 181      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 182      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 183      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 184      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 185      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 186      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 187      & +wliptran*eliptran+wsaxs*esaxs_constr
 188       endif
 189 #else
 190       if (shield_mode.gt.0) then
 191       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 192      & +welec*fact(1)*(ees+evdw1)
 193      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 194      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 195      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 196      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 197      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 198      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 199      & +wliptran*eliptran+wsaxs*esaxs_constr
 200       else
 201       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 202      & +welec*fact(1)*(ees+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       endif
 211 #endif
 212       energia(0)=etot
 213       energia(1)=evdw
 214 #ifdef SCP14
 215       energia(2)=evdw2-evdw2_14
 216       energia(17)=evdw2_14
 217 #else
 218       energia(2)=evdw2
 219       energia(17)=0.0d0
 220 #endif
 221 #ifdef SPLITELE
 222       energia(3)=ees
 223       energia(16)=evdw1
 224 #else
 225       energia(3)=ees+evdw1
 226       energia(16)=0.0d0
 227 #endif
 228       energia(4)=ecorr
 229       energia(5)=ecorr5
 230       energia(6)=ecorr6
 231       energia(7)=eel_loc
 232       energia(8)=eello_turn3
 233       energia(9)=eello_turn4
 234       energia(10)=eturn6
 235       energia(11)=ebe
 236       energia(12)=escloc
 237       energia(13)=etors
 238       energia(14)=etors_d
 239       energia(15)=ehpb
 240       energia(18)=estr
 241       energia(19)=esccor
 242       energia(20)=edihcnstr
 243       energia(21)=evdw_t
 244       energia(24)=ethetacnstr
 245       energia(22)=eliptran
 246       energia(26)=esaxs_constr
 247 c detecting NaNQ
 248 #ifdef ISNAN
 249 #ifdef AIX
 250       if (isnan(etot).ne.0) energia(0)=1.0d+99
 251 #else
 252       if (isnan(etot)) energia(0)=1.0d+99
 253 #endif
 254 #else
 255       i=0
 256 #ifdef WINPGI
 257       idumm=proc_proc(etot,i)
 258 #else
 259       call proc_proc(etot,i)
 260 #endif
 261       if(i.eq.1)energia(0)=1.0d+99
 262 #endif
 263 #ifdef MPL
 264 c     endif
 265 #endif
 266 #ifdef DEBUG
 267       call enerprint(energia,fact)
 268 #endif
 269       if (calc_grad) then
 270 C
 271 C Sum up the components of the Cartesian gradient.
 272 C
 273 #ifdef SPLITELE
 274       do i=1,nct
 275         do j=1,3
 276       if (shield_mode.eq.0) then
 277           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 278      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 279      &                wbond*gradb(j,i)+
 280      &                wstrain*ghpbc(j,i)+
 281      &                wcorr*fact(3)*gradcorr(j,i)+
 282      &                wel_loc*fact(2)*gel_loc(j,i)+
 283      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 284      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 285      &                wcorr5*fact(4)*gradcorr5(j,i)+
 286      &                wcorr6*fact(5)*gradcorr6(j,i)+
 287      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 288      &                wsccor*fact(2)*gsccorc(j,i)
 289      &               +wliptran*gliptranc(j,i)
 290           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 291      &                  wbond*gradbx(j,i)+
 292      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 293      &                  wsccor*fact(2)*gsccorx(j,i)
 294      &                 +wliptran*gliptranx(j,i)
 295         else
 296           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 297      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 298      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 299      &                wbond*gradb(j,i)+
 300      &                wstrain*ghpbc(j,i)+
 301      &                wcorr*fact(3)*gradcorr(j,i)+
 302      &                wel_loc*fact(2)*gel_loc(j,i)+
 303      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 304      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 305      &                wcorr5*fact(4)*gradcorr5(j,i)+
 306      &                wcorr6*fact(5)*gradcorr6(j,i)+
 307      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 308      &                wsccor*fact(2)*gsccorc(j,i)
 309      &               +wliptran*gliptranc(j,i)
 310      &                 +welec*gshieldc(j,i)
 311      &                 +welec*gshieldc_loc(j,i)
 312      &                 +wcorr*gshieldc_ec(j,i)
 313      &                 +wcorr*gshieldc_loc_ec(j,i)
 314      &                 +wturn3*gshieldc_t3(j,i)
 315      &                 +wturn3*gshieldc_loc_t3(j,i)
 316      &                 +wturn4*gshieldc_t4(j,i)
 317      &                 +wturn4*gshieldc_loc_t4(j,i)
 318      &                 +wel_loc*gshieldc_ll(j,i)
 319      &                 +wel_loc*gshieldc_loc_ll(j,i)
 320
 321           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 322      &                 +fact(1)*wscp*gradx_scp(j,i)+
 323      &                  wbond*gradbx(j,i)+
 324      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 325      &                  wsccor*fact(2)*gsccorx(j,i)
 326      &                 +wliptran*gliptranx(j,i)
 327      &                 +welec*gshieldx(j,i)
 328      &                 +wcorr*gshieldx_ec(j,i)
 329      &                 +wturn3*gshieldx_t3(j,i)
 330      &                 +wturn4*gshieldx_t4(j,i)
 331      &                 +wel_loc*gshieldx_ll(j,i)
 332
 333
 334         endif
 335         enddo
 336 #else
 337       do i=1,nct
 338         do j=1,3
 339                 if (shield_mode.eq.0) then
 340           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 341      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 342      &                wbond*gradb(j,i)+
 343      &                wcorr*fact(3)*gradcorr(j,i)+
 344      &                wel_loc*fact(2)*gel_loc(j,i)+
 345      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 346      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 347      &                wcorr5*fact(4)*gradcorr5(j,i)+
 348      &                wcorr6*fact(5)*gradcorr6(j,i)+
 349      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 350      &                wsccor*fact(2)*gsccorc(j,i)
 351      &               +wliptran*gliptranc(j,i)
 352           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 353      &                  wbond*gradbx(j,i)+
 354      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 355      &                  wsccor*fact(1)*gsccorx(j,i)
 356      &                 +wliptran*gliptranx(j,i)
 357               else
 358           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 359      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 360      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 361      &                wbond*gradb(j,i)+
 362      &                wcorr*fact(3)*gradcorr(j,i)+
 363      &                wel_loc*fact(2)*gel_loc(j,i)+
 364      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 365      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 366      &                wcorr5*fact(4)*gradcorr5(j,i)+
 367      &                wcorr6*fact(5)*gradcorr6(j,i)+
 368      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 369      &                wsccor*fact(2)*gsccorc(j,i)
 370      &               +wliptran*gliptranc(j,i)
 371      &                 +welec*gshieldc(j,i)
 372      &                 +welec*gshieldc_loc(j,i)
 373      &                 +wcorr*gshieldc_ec(j,i)
 374      &                 +wcorr*gshieldc_loc_ec(j,i)
 375      &                 +wturn3*gshieldc_t3(j,i)
 376      &                 +wturn3*gshieldc_loc_t3(j,i)
 377      &                 +wturn4*gshieldc_t4(j,i)
 378      &                 +wturn4*gshieldc_loc_t4(j,i)
 379      &                 +wel_loc*gshieldc_ll(j,i)
 380      &                 +wel_loc*gshieldc_loc_ll(j,i)
 381
 382           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 383      &                  fact(1)*wscp*gradx_scp(j,i)+
 384      &                  wbond*gradbx(j,i)+
 385      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 386      &                  wsccor*fact(1)*gsccorx(j,i)
 387      &                 +wliptran*gliptranx(j,i)
 388      &                 +welec*gshieldx(j,i)
 389      &                 +wcorr*gshieldx_ec(j,i)
 390      &                 +wturn3*gshieldx_t3(j,i)
 391      &                 +wturn4*gshieldx_t4(j,i)
 392      &                 +wel_loc*gshieldx_ll(j,i)
 393
 394          endif
 395         enddo
 396 #endif
 397       enddo
 398
 399
 400       do i=1,nres-3
 401         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 402      &   +wcorr5*fact(4)*g_corr5_loc(i)
 403      &   +wcorr6*fact(5)*g_corr6_loc(i)
 404      &   +wturn4*fact(3)*gel_loc_turn4(i)
 405      &   +wturn3*fact(2)*gel_loc_turn3(i)
 406      &   +wturn6*fact(5)*gel_loc_turn6(i)
 407      &   +wel_loc*fact(2)*gel_loc_loc(i)
 408 c     &   +wsccor*fact(1)*gsccor_loc(i)
 409 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 410       enddo
 411       endif
 412       if (dyn_ss) call dyn_set_nss
 413       return
 414       end
 415 C------------------------------------------------------------------------
 416       subroutine enerprint(energia,fact)
 417       implicit real*8 (a-h,o-z)
 418       include 'DIMENSIONS'
 419       include 'COMMON.IOUNITS'
 420       include 'COMMON.FFIELD'
 421       include 'COMMON.SBRIDGE'
 422       double precision energia(0:max_ene),fact(6)
 423       etot=energia(0)
 424       evdw=energia(1)+fact(6)*energia(21)
 425 #ifdef SCP14
 426       evdw2=energia(2)+energia(17)
 427 #else
 428       evdw2=energia(2)
 429 #endif
 430       ees=energia(3)
 431 #ifdef SPLITELE
 432       evdw1=energia(16)
 433 #endif
 434       ecorr=energia(4)
 435       ecorr5=energia(5)
 436       ecorr6=energia(6)
 437       eel_loc=energia(7)
 438       eello_turn3=energia(8)
 439       eello_turn4=energia(9)
 440       eello_turn6=energia(10)
 441       ebe=energia(11)
 442       escloc=energia(12)
 443       etors=energia(13)
 444       etors_d=energia(14)
 445       ehpb=energia(15)
 446       esccor=energia(19)
 447       edihcnstr=energia(20)
 448       estr=energia(18)
 449       ethetacnstr=energia(24)
 450       eliptran=energia(22)
 451       esaxs=energia(26)
 452 #ifdef SPLITELE
 453       if (shield_mode.gt.0) then
 454       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(1),ees,
 455      &  welec*fact(1),evdw1,wvdwpp*fact(1),
 456      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 457      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 458      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 459      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 460      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 461      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 462      & eliptran,wliptran,esaxs,wsaxs,etot
 463       else
 464       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 465      &  wvdwpp,
 466      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 467      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 468      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 469      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 470      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 471      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 472      & eliptran,wliptran,esaxs,wsaxs,etot
 473       endif
 474    10 format (/'Virtual-chain energies:'//
 475      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 476      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 477      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 478      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 479      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 480      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 481      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 482      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 483      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 484      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 485      & ' (SS bridges & dist. cnstr.)'/
 486      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 487      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 488      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 489      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 490      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 491      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 492      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 493      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 494      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 495      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 496      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 497      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 498      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 499      & 'ETOT=  ',1pE16.6,' (total)')
 500 #else
 501       if (shield_mode.gt.0) then
 502       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(2),ees,
 503      &  welec*fact(1),estr,wbond,
 504      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 505      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 506      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 507      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 508      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 509      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,esaxs,wsaxs,etot
 510       else
 511       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 512      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 513      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 514      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 515      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 516      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 517      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,esaxs,wsaxs,etot
 518       endif
 519    10 format (/'Virtual-chain energies:'//
 520      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 521      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 522      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 523      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 524      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 525      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 526      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 527      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 528      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 529      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 530      & ' (SS bridges & dist. cnstr.)'/
 531      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 532      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 533      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 534      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 535      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 536      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 537      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 538      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.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      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 543      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 544      & 'ETOT=  ',1pE16.6,' (total)')
 545 #endif
 546       return
 547       end
 548 C-----------------------------------------------------------------------
 549       subroutine elj(evdw,evdw_t)
 550 C
 551 C This subroutine calculates the interaction energy of nonbonded side chains
 552 C assuming the LJ potential of interaction.
 553 C
 554       implicit real*8 (a-h,o-z)
 555       include 'DIMENSIONS'
 556       include "DIMENSIONS.COMPAR"
 557       parameter (accur=1.0d-10)
 558       include 'COMMON.GEO'
 559       include 'COMMON.VAR'
 560       include 'COMMON.LOCAL'
 561       include 'COMMON.CHAIN'
 562       include 'COMMON.DERIV'
 563       include 'COMMON.INTERACT'
 564       include 'COMMON.TORSION'
 565       include 'COMMON.SBRIDGE'
 566       include 'COMMON.NAMES'
 567       include 'COMMON.IOUNITS'
 568       include 'COMMON.CONTACTS'
 569       dimension gg(3)
 570       integer icant
 571       external icant
 572 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 573 c ROZNICA z cluster
 574 c      do i=1,210
 575 c        do j=1,2
 576 c          eneps_temp(j,i)=0.0d0
 577 c        enddo
 578 c      enddo
 579 cROZNICA
 580
 581       evdw=0.0D0
 582       evdw_t=0.0d0
 583       do i=iatsc_s,iatsc_e
 584         itypi=iabs(itype(i))
 585         if (itypi.eq.ntyp1) cycle
 586         itypi1=iabs(itype(i+1))
 587         xi=c(1,nres+i)
 588         yi=c(2,nres+i)
 589         zi=c(3,nres+i)
 590 C Change 12/1/95
 591         num_conti=0
 592 C
 593 C Calculate SC interaction energy.
 594 C
 595         do iint=1,nint_gr(i)
 596 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 597 cd   &                  'iend=',iend(i,iint)
 598           do j=istart(i,iint),iend(i,iint)
 599             itypj=iabs(itype(j))
 600             if (itypj.eq.ntyp1) cycle
 601             xj=c(1,nres+j)-xi
 602             yj=c(2,nres+j)-yi
 603             zj=c(3,nres+j)-zi
 604 C Change 12/1/95 to calculate four-body interactions
 605             rij=xj*xj+yj*yj+zj*zj
 606             rrij=1.0D0/rij
 607 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 608             eps0ij=eps(itypi,itypj)
 609             fac=rrij**expon2
 610             e1=fac*fac*aa
 611             e2=fac*bb
 612             evdwij=e1+e2
 613             ij=icant(itypi,itypj)
 614 c ROZNICA z cluster
 615 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 616 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 617 c
 618
 619 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 620 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 621 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 622 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 623 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 624 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 625             if (bb.gt.0.0d0) then
 626               evdw=evdw+evdwij
 627             else
 628               evdw_t=evdw_t+evdwij
 629             endif
 630             if (calc_grad) then
 631 C
 632 C Calculate the components of the gradient in DC and X
 633 C
 634             fac=-rrij*(e1+evdwij)
 635             gg(1)=xj*fac
 636             gg(2)=yj*fac
 637             gg(3)=zj*fac
 638             do k=1,3
 639               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 640               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 641             enddo
 642             do k=i,j-1
 643               do l=1,3
 644                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 645               enddo
 646             enddo
 647             endif
 648 C
 649 C 12/1/95, revised on 5/20/97
 650 C
 651 C Calculate the contact function. The ith column of the array JCONT will
 652 C contain the numbers of atoms that make contacts with the atom I (of numbers
 653 C greater than I). The arrays FACONT and GACONT will contain the values of
 654 C the contact function and its derivative.
 655 C
 656 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 657 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 658 C Uncomment next line, if the correlation interactions are contact function only
 659             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 660               rij=dsqrt(rij)
 661               sigij=sigma(itypi,itypj)
 662               r0ij=rs0(itypi,itypj)
 663 C
 664 C Check whether the SC's are not too far to make a contact.
 665 C
 666               rcut=1.5d0*r0ij
 667               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 668 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 669 C
 670               if (fcont.gt.0.0D0) then
 671 C If the SC-SC distance if close to sigma, apply spline.
 672 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 673 cAdam &             fcont1,fprimcont1)
 674 cAdam           fcont1=1.0d0-fcont1
 675 cAdam           if (fcont1.gt.0.0d0) then
 676 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 677 cAdam             fcont=fcont*fcont1
 678 cAdam           endif
 679 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 680 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 681 cga             do k=1,3
 682 cga               gg(k)=gg(k)*eps0ij
 683 cga             enddo
 684 cga             eps0ij=-evdwij*eps0ij
 685 C Uncomment for AL's type of SC correlation interactions.
 686 cadam           eps0ij=-evdwij
 687                 num_conti=num_conti+1
 688                 jcont(num_conti,i)=j
 689                 facont(num_conti,i)=fcont*eps0ij
 690                 fprimcont=eps0ij*fprimcont/rij
 691                 fcont=expon*fcont
 692 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 693 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 694 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 695 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 696                 gacont(1,num_conti,i)=-fprimcont*xj
 697                 gacont(2,num_conti,i)=-fprimcont*yj
 698                 gacont(3,num_conti,i)=-fprimcont*zj
 699 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 700 cd              write (iout,'(2i3,3f10.5)')
 701 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 702               endif
 703             endif
 704           enddo      ! j
 705         enddo        ! iint
 706 C Change 12/1/95
 707         num_cont(i)=num_conti
 708       enddo          ! i
 709       if (calc_grad) then
 710       do i=1,nct
 711         do j=1,3
 712           gvdwc(j,i)=expon*gvdwc(j,i)
 713           gvdwx(j,i)=expon*gvdwx(j,i)
 714         enddo
 715       enddo
 716       endif
 717 C******************************************************************************
 718 C
 719 C                              N O T E !!!
 720 C
 721 C To save time, the factor of EXPON has been extracted from ALL components
 722 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 723 C use!
 724 C
 725 C******************************************************************************
 726       return
 727       end
 728 C-----------------------------------------------------------------------------
 729       subroutine eljk(evdw,evdw_t)
 730 C
 731 C This subroutine calculates the interaction energy of nonbonded side chains
 732 C assuming the LJK potential of interaction.
 733 C
 734       implicit real*8 (a-h,o-z)
 735       include 'DIMENSIONS'
 736       include "DIMENSIONS.COMPAR"
 737       include 'COMMON.GEO'
 738       include 'COMMON.VAR'
 739       include 'COMMON.LOCAL'
 740       include 'COMMON.CHAIN'
 741       include 'COMMON.DERIV'
 742       include 'COMMON.INTERACT'
 743       include 'COMMON.IOUNITS'
 744       include 'COMMON.NAMES'
 745       dimension gg(3)
 746       logical scheck
 747       integer icant
 748       external icant
 749 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 750 c      do i=1,210
 751 c        do j=1,2
 752 c          eneps_temp(j,i)=0.0d0
 753 c        enddo
 754 c      enddo
 755       evdw=0.0D0
 756       evdw_t=0.0d0
 757       do i=iatsc_s,iatsc_e
 758         itypi=iabs(itype(i))
 759         if (itypi.eq.ntyp1) cycle
 760         itypi1=iabs(itype(i+1))
 761         xi=c(1,nres+i)
 762         yi=c(2,nres+i)
 763         zi=c(3,nres+i)
 764 C
 765 C Calculate SC interaction energy.
 766 C
 767         do iint=1,nint_gr(i)
 768           do j=istart(i,iint),iend(i,iint)
 769             itypj=iabs(itype(j))
 770             if (itypj.eq.ntyp1) cycle
 771             xj=c(1,nres+j)-xi
 772             yj=c(2,nres+j)-yi
 773             zj=c(3,nres+j)-zi
 774             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 775             fac_augm=rrij**expon
 776             e_augm=augm(itypi,itypj)*fac_augm
 777             r_inv_ij=dsqrt(rrij)
 778             rij=1.0D0/r_inv_ij
 779             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 780             fac=r_shift_inv**expon
 781             e1=fac*fac*aa
 782             e2=fac*bb
 783             evdwij=e_augm+e1+e2
 784             ij=icant(itypi,itypj)
 785 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 786 c     &        /dabs(eps(itypi,itypj))
 787 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 788 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 789 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 790 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 791 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 792 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 793 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 794 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 795             if (bb.gt.0.0d0) then
 796               evdw=evdw+evdwij
 797             else
 798               evdw_t=evdw_t+evdwij
 799             endif
 800             if (calc_grad) then
 801 C
 802 C Calculate the components of the gradient in DC and X
 803 C
 804             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 805             gg(1)=xj*fac
 806             gg(2)=yj*fac
 807             gg(3)=zj*fac
 808             do k=1,3
 809               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 810               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 811             enddo
 812             do k=i,j-1
 813               do l=1,3
 814                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 815               enddo
 816             enddo
 817             endif
 818           enddo      ! j
 819         enddo        ! iint
 820       enddo          ! i
 821       if (calc_grad) then
 822       do i=1,nct
 823         do j=1,3
 824           gvdwc(j,i)=expon*gvdwc(j,i)
 825           gvdwx(j,i)=expon*gvdwx(j,i)
 826         enddo
 827       enddo
 828       endif
 829       return
 830       end
 831 C-----------------------------------------------------------------------------
 832       subroutine ebp(evdw,evdw_t)
 833 C
 834 C This subroutine calculates the interaction energy of nonbonded side chains
 835 C assuming the Berne-Pechukas potential of interaction.
 836 C
 837       implicit real*8 (a-h,o-z)
 838       include 'DIMENSIONS'
 839       include "DIMENSIONS.COMPAR"
 840       include 'COMMON.GEO'
 841       include 'COMMON.VAR'
 842       include 'COMMON.LOCAL'
 843       include 'COMMON.CHAIN'
 844       include 'COMMON.DERIV'
 845       include 'COMMON.NAMES'
 846       include 'COMMON.INTERACT'
 847       include 'COMMON.IOUNITS'
 848       include 'COMMON.CALC'
 849       common /srutu/ icall
 850 c     double precision rrsave(maxdim)
 851       logical lprn
 852       integer icant
 853       external icant
 854 c      do i=1,210
 855 c        do j=1,2
 856 c          eneps_temp(j,i)=0.0d0
 857 c        enddo
 858 c      enddo
 859       evdw=0.0D0
 860       evdw_t=0.0d0
 861 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 862 c     if (icall.eq.0) then
 863 c       lprn=.true.
 864 c     else
 865         lprn=.false.
 866 c     endif
 867       ind=0
 868       do i=iatsc_s,iatsc_e
 869         itypi=iabs(itype(i))
 870         if (itypi.eq.ntyp1) cycle
 871         itypi1=iabs(itype(i+1))
 872         xi=c(1,nres+i)
 873         yi=c(2,nres+i)
 874         zi=c(3,nres+i)
 875         dxi=dc_norm(1,nres+i)
 876         dyi=dc_norm(2,nres+i)
 877         dzi=dc_norm(3,nres+i)
 878         dsci_inv=vbld_inv(i+nres)
 879 C
 880 C Calculate SC interaction energy.
 881 C
 882         do iint=1,nint_gr(i)
 883           do j=istart(i,iint),iend(i,iint)
 884             ind=ind+1
 885             itypj=iabs(itype(j))
 886             if (itypj.eq.ntyp1) cycle
 887             dscj_inv=vbld_inv(j+nres)
 888             chi1=chi(itypi,itypj)
 889             chi2=chi(itypj,itypi)
 890             chi12=chi1*chi2
 891             chip1=chip(itypi)
 892             chip2=chip(itypj)
 893             chip12=chip1*chip2
 894             alf1=alp(itypi)
 895             alf2=alp(itypj)
 896             alf12=0.5D0*(alf1+alf2)
 897 C For diagnostics only!!!
 898 c           chi1=0.0D0
 899 c           chi2=0.0D0
 900 c           chi12=0.0D0
 901 c           chip1=0.0D0
 902 c           chip2=0.0D0
 903 c           chip12=0.0D0
 904 c           alf1=0.0D0
 905 c           alf2=0.0D0
 906 c           alf12=0.0D0
 907             xj=c(1,nres+j)-xi
 908             yj=c(2,nres+j)-yi
 909             zj=c(3,nres+j)-zi
 910             dxj=dc_norm(1,nres+j)
 911             dyj=dc_norm(2,nres+j)
 912             dzj=dc_norm(3,nres+j)
 913             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 914 cd          if (icall.eq.0) then
 915 cd            rrsave(ind)=rrij
 916 cd          else
 917 cd            rrij=rrsave(ind)
 918 cd          endif
 919             rij=dsqrt(rrij)
 920 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 921             call sc_angular
 922 C Calculate whole angle-dependent part of epsilon and contributions
 923 C to its derivatives
 924             fac=(rrij*sigsq)**expon2
 925             e1=fac*fac*aa
 926             e2=fac*bb
 927             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 928             eps2der=evdwij*eps3rt
 929             eps3der=evdwij*eps2rt
 930             evdwij=evdwij*eps2rt*eps3rt
 931             ij=icant(itypi,itypj)
 932             aux=eps1*eps2rt**2*eps3rt**2
 933 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 934 c     &        /dabs(eps(itypi,itypj))
 935 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 936             if (bb.gt.0.0d0) then
 937               evdw=evdw+evdwij
 938             else
 939               evdw_t=evdw_t+evdwij
 940             endif
 941             if (calc_grad) then
 942             if (lprn) then
 943             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 944             epsi=bb**2/aa
 945             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 946      &        restyp(itypi),i,restyp(itypj),j,
 947      &        epsi,sigm,chi1,chi2,chip1,chip2,
 948      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 949      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 950      &        evdwij
 951             endif
 952 C Calculate gradient components.
 953             e1=e1*eps1*eps2rt**2*eps3rt**2
 954             fac=-expon*(e1+evdwij)
 955             sigder=fac/sigsq
 956             fac=rrij*fac
 957 C Calculate radial part of the gradient
 958             gg(1)=xj*fac
 959             gg(2)=yj*fac
 960             gg(3)=zj*fac
 961 C Calculate the angular part of the gradient and sum add the contributions
 962 C to the appropriate components of the Cartesian gradient.
 963             call sc_grad
 964             endif
 965           enddo      ! j
 966         enddo        ! iint
 967       enddo          ! i
 968 c     stop
 969       return
 970       end
 971 C-----------------------------------------------------------------------------
 972       subroutine egb(evdw,evdw_t)
 973 C
 974 C This subroutine calculates the interaction energy of nonbonded side chains
 975 C assuming the Gay-Berne potential of interaction.
 976 C
 977       implicit real*8 (a-h,o-z)
 978       include 'DIMENSIONS'
 979       include "DIMENSIONS.COMPAR"
 980       include 'COMMON.GEO'
 981       include 'COMMON.VAR'
 982       include 'COMMON.LOCAL'
 983       include 'COMMON.CHAIN'
 984       include 'COMMON.DERIV'
 985       include 'COMMON.NAMES'
 986       include 'COMMON.INTERACT'
 987       include 'COMMON.IOUNITS'
 988       include 'COMMON.CALC'
 989       include 'COMMON.SBRIDGE'
 990       logical lprn
 991       common /srutu/icall
 992       integer icant,xshift,yshift,zshift
 993       external icant
 994 c      do i=1,210
 995 c        do j=1,2
 996 c          eneps_temp(j,i)=0.0d0
 997 c        enddo
 998 c      enddo
 999 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1000       evdw=0.0D0
1001       evdw_t=0.0d0
1002       lprn=.false.
1003 c      if (icall.gt.0) lprn=.true.
1004       ind=0
1005       do i=iatsc_s,iatsc_e
1006         itypi=iabs(itype(i))
1007         if (itypi.eq.ntyp1) cycle
1008         itypi1=iabs(itype(i+1))
1009         xi=c(1,nres+i)
1010         yi=c(2,nres+i)
1011         zi=c(3,nres+i)
1012 C returning the ith atom to box
1013           xi=mod(xi,boxxsize)
1014           if (xi.lt.0) xi=xi+boxxsize
1015           yi=mod(yi,boxysize)
1016           if (yi.lt.0) yi=yi+boxysize
1017           zi=mod(zi,boxzsize)
1018           if (zi.lt.0) zi=zi+boxzsize
1019        if ((zi.gt.bordlipbot)
1020      &.and.(zi.lt.bordliptop)) then
1021 C the energy transfer exist
1022         if (zi.lt.buflipbot) then
1023 C what fraction I am in
1024          fracinbuf=1.0d0-
1025      &        ((zi-bordlipbot)/lipbufthick)
1026 C lipbufthick is thickenes of lipid buffore
1027          sslipi=sscalelip(fracinbuf)
1028          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1029         elseif (zi.gt.bufliptop) then
1030          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1031          sslipi=sscalelip(fracinbuf)
1032          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1033         else
1034          sslipi=1.0d0
1035          ssgradlipi=0.0
1036         endif
1037        else
1038          sslipi=0.0d0
1039          ssgradlipi=0.0
1040        endif
1041
1042         dxi=dc_norm(1,nres+i)
1043         dyi=dc_norm(2,nres+i)
1044         dzi=dc_norm(3,nres+i)
1045         dsci_inv=vbld_inv(i+nres)
1046 C
1047 C Calculate SC interaction energy.
1048 C
1049         do iint=1,nint_gr(i)
1050           do j=istart(i,iint),iend(i,iint)
1051             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1052               call dyn_ssbond_ene(i,j,evdwij)
1053               evdw=evdw+evdwij
1054 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1055 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1056 C triple bond artifac removal
1057              do k=j+1,iend(i,iint)
1058 C search over all next residues
1059               if (dyn_ss_mask(k)) then
1060 C check if they are cysteins
1061 C              write(iout,*) 'k=',k
1062               call triple_ssbond_ene(i,j,k,evdwij)
1063 C call the energy function that removes the artifical triple disulfide
1064 C bond the soubroutine is located in ssMD.F
1065               evdw=evdw+evdwij
1066 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1067 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1068               endif!dyn_ss_mask(k)
1069              enddo! k
1070             ELSE
1071             ind=ind+1
1072             itypj=iabs(itype(j))
1073             if (itypj.eq.ntyp1) cycle
1074             dscj_inv=vbld_inv(j+nres)
1075             sig0ij=sigma(itypi,itypj)
1076             chi1=chi(itypi,itypj)
1077             chi2=chi(itypj,itypi)
1078             chi12=chi1*chi2
1079             chip1=chip(itypi)
1080             chip2=chip(itypj)
1081             chip12=chip1*chip2
1082             alf1=alp(itypi)
1083             alf2=alp(itypj)
1084             alf12=0.5D0*(alf1+alf2)
1085 C For diagnostics only!!!
1086 c           chi1=0.0D0
1087 c           chi2=0.0D0
1088 c           chi12=0.0D0
1089 c           chip1=0.0D0
1090 c           chip2=0.0D0
1091 c           chip12=0.0D0
1092 c           alf1=0.0D0
1093 c           alf2=0.0D0
1094 c           alf12=0.0D0
1095             xj=c(1,nres+j)
1096             yj=c(2,nres+j)
1097             zj=c(3,nres+j)
1098 C returning jth atom to box
1099           xj=mod(xj,boxxsize)
1100           if (xj.lt.0) xj=xj+boxxsize
1101           yj=mod(yj,boxysize)
1102           if (yj.lt.0) yj=yj+boxysize
1103           zj=mod(zj,boxzsize)
1104           if (zj.lt.0) zj=zj+boxzsize
1105        if ((zj.gt.bordlipbot)
1106      &.and.(zj.lt.bordliptop)) then
1107 C the energy transfer exist
1108         if (zj.lt.buflipbot) then
1109 C what fraction I am in
1110          fracinbuf=1.0d0-
1111      &        ((zj-bordlipbot)/lipbufthick)
1112 C lipbufthick is thickenes of lipid buffore
1113          sslipj=sscalelip(fracinbuf)
1114          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1115         elseif (zj.gt.bufliptop) then
1116          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1117          sslipj=sscalelip(fracinbuf)
1118          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1119         else
1120          sslipj=1.0d0
1121          ssgradlipj=0.0
1122         endif
1123        else
1124          sslipj=0.0d0
1125          ssgradlipj=0.0
1126        endif
1127       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1128      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1129       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1130      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1131 C       if (aa.ne.aa_aq(itypi,itypj)) then
1132
1133 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1134 C     & bb_aq(itypi,itypj)-bb,
1135 C     & sslipi,sslipj
1136 C         endif
1137
1138 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1139 C checking the distance
1140       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1141       xj_safe=xj
1142       yj_safe=yj
1143       zj_safe=zj
1144       subchap=0
1145 C finding the closest
1146       do xshift=-1,1
1147       do yshift=-1,1
1148       do zshift=-1,1
1149           xj=xj_safe+xshift*boxxsize
1150           yj=yj_safe+yshift*boxysize
1151           zj=zj_safe+zshift*boxzsize
1152           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1153           if(dist_temp.lt.dist_init) then
1154             dist_init=dist_temp
1155             xj_temp=xj
1156             yj_temp=yj
1157             zj_temp=zj
1158             subchap=1
1159           endif
1160        enddo
1161        enddo
1162        enddo
1163        if (subchap.eq.1) then
1164           xj=xj_temp-xi
1165           yj=yj_temp-yi
1166           zj=zj_temp-zi
1167        else
1168           xj=xj_safe-xi
1169           yj=yj_safe-yi
1170           zj=zj_safe-zi
1171        endif
1172
1173             dxj=dc_norm(1,nres+j)
1174             dyj=dc_norm(2,nres+j)
1175             dzj=dc_norm(3,nres+j)
1176 c            write (iout,*) i,j,xj,yj,zj
1177             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1178             rij=dsqrt(rrij)
1179             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1180             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1181             if (sss.le.0.0) cycle
1182 C Calculate angle-dependent terms of energy and contributions to their
1183 C derivatives.
1184
1185             call sc_angular
1186             sigsq=1.0D0/sigsq
1187             sig=sig0ij*dsqrt(sigsq)
1188             rij_shift=1.0D0/rij-sig+sig0ij
1189 C I hate to put IF's in the loops, but here don't have another choice!!!!
1190             if (rij_shift.le.0.0D0) then
1191               evdw=1.0D20
1192               return
1193             endif
1194             sigder=-sig*sigsq
1195 c---------------------------------------------------------------
1196             rij_shift=1.0D0/rij_shift
1197             fac=rij_shift**expon
1198             e1=fac*fac*aa
1199             e2=fac*bb
1200             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1201             eps2der=evdwij*eps3rt
1202             eps3der=evdwij*eps2rt
1203             evdwij=evdwij*eps2rt*eps3rt
1204             if (bb.gt.0) then
1205               evdw=evdw+evdwij*sss
1206             else
1207               evdw_t=evdw_t+evdwij*sss
1208             endif
1209             ij=icant(itypi,itypj)
1210             aux=eps1*eps2rt**2*eps3rt**2
1211 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1212 c     &        /dabs(eps(itypi,itypj))
1213 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1214 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1215 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1216 c     &         aux*e2/eps(itypi,itypj)
1217 c            if (lprn) then
1218             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1219             epsi=bb**2/aa
1220 C#define DEBUG
1221 #ifdef DEBUG
1222             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1223      &        restyp(itypi),i,restyp(itypj),j,
1224      &        epsi,sigm,chi1,chi2,chip1,chip2,
1225      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1226      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1227      &        evdwij
1228              write (iout,*) "partial sum", evdw, evdw_t
1229 #endif
1230 C#undef DEBUG
1231 c            endif
1232             if (calc_grad) then
1233 C Calculate gradient components.
1234             e1=e1*eps1*eps2rt**2*eps3rt**2
1235             fac=-expon*(e1+evdwij)*rij_shift
1236             sigder=fac*sigder
1237             fac=rij*fac
1238             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1239 C Calculate the radial part of the gradient
1240             gg(1)=xj*fac
1241             gg(2)=yj*fac
1242             gg(3)=zj*fac
1243 C Calculate angular part of the gradient.
1244             call sc_grad
1245             endif
1246 C            write(iout,*)  "partial sum", evdw, evdw_t
1247             ENDIF    ! dyn_ss
1248           enddo      ! j
1249         enddo        ! iint
1250       enddo          ! i
1251       return
1252       end
1253 C-----------------------------------------------------------------------------
1254       subroutine egbv(evdw,evdw_t)
1255 C
1256 C This subroutine calculates the interaction energy of nonbonded side chains
1257 C assuming the Gay-Berne-Vorobjev potential of interaction.
1258 C
1259       implicit real*8 (a-h,o-z)
1260       include 'DIMENSIONS'
1261       include "DIMENSIONS.COMPAR"
1262       include 'COMMON.GEO'
1263       include 'COMMON.VAR'
1264       include 'COMMON.LOCAL'
1265       include 'COMMON.CHAIN'
1266       include 'COMMON.DERIV'
1267       include 'COMMON.NAMES'
1268       include 'COMMON.INTERACT'
1269       include 'COMMON.IOUNITS'
1270       include 'COMMON.CALC'
1271       common /srutu/ icall
1272       logical lprn
1273       integer icant
1274       external icant
1275 c      do i=1,210
1276 c        do j=1,2
1277 c          eneps_temp(j,i)=0.0d0
1278 c        enddo
1279 c      enddo
1280       evdw=0.0D0
1281       evdw_t=0.0d0
1282 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1283       evdw=0.0D0
1284       lprn=.false.
1285 c      if (icall.gt.0) lprn=.true.
1286       ind=0
1287       do i=iatsc_s,iatsc_e
1288         itypi=iabs(itype(i))
1289         if (itypi.eq.ntyp1) cycle
1290         itypi1=iabs(itype(i+1))
1291         xi=c(1,nres+i)
1292         yi=c(2,nres+i)
1293         zi=c(3,nres+i)
1294         dxi=dc_norm(1,nres+i)
1295         dyi=dc_norm(2,nres+i)
1296         dzi=dc_norm(3,nres+i)
1297         dsci_inv=vbld_inv(i+nres)
1298 C
1299 C Calculate SC interaction energy.
1300 C
1301         do iint=1,nint_gr(i)
1302           do j=istart(i,iint),iend(i,iint)
1303             ind=ind+1
1304             itypj=iabs(itype(j))
1305             if (itypj.eq.ntyp1) cycle
1306             dscj_inv=vbld_inv(j+nres)
1307             sig0ij=sigma(itypi,itypj)
1308             r0ij=r0(itypi,itypj)
1309             chi1=chi(itypi,itypj)
1310             chi2=chi(itypj,itypi)
1311             chi12=chi1*chi2
1312             chip1=chip(itypi)
1313             chip2=chip(itypj)
1314             chip12=chip1*chip2
1315             alf1=alp(itypi)
1316             alf2=alp(itypj)
1317             alf12=0.5D0*(alf1+alf2)
1318 C For diagnostics only!!!
1319 c           chi1=0.0D0
1320 c           chi2=0.0D0
1321 c           chi12=0.0D0
1322 c           chip1=0.0D0
1323 c           chip2=0.0D0
1324 c           chip12=0.0D0
1325 c           alf1=0.0D0
1326 c           alf2=0.0D0
1327 c           alf12=0.0D0
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             dxj=dc_norm(1,nres+j)
1332             dyj=dc_norm(2,nres+j)
1333             dzj=dc_norm(3,nres+j)
1334             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1335             rij=dsqrt(rrij)
1336 C Calculate angle-dependent terms of energy and contributions to their
1337 C derivatives.
1338             call sc_angular
1339             sigsq=1.0D0/sigsq
1340             sig=sig0ij*dsqrt(sigsq)
1341             rij_shift=1.0D0/rij-sig+r0ij
1342 C I hate to put IF's in the loops, but here don't have another choice!!!!
1343             if (rij_shift.le.0.0D0) then
1344               evdw=1.0D20
1345               return
1346             endif
1347             sigder=-sig*sigsq
1348 c---------------------------------------------------------------
1349             rij_shift=1.0D0/rij_shift
1350             fac=rij_shift**expon
1351             e1=fac*fac*aa
1352             e2=fac*bb
1353             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1354             eps2der=evdwij*eps3rt
1355             eps3der=evdwij*eps2rt
1356             fac_augm=rrij**expon
1357             e_augm=augm(itypi,itypj)*fac_augm
1358             evdwij=evdwij*eps2rt*eps3rt
1359             if (bb.gt.0.0d0) then
1360               evdw=evdw+evdwij+e_augm
1361             else
1362               evdw_t=evdw_t+evdwij+e_augm
1363             endif
1364             ij=icant(itypi,itypj)
1365             aux=eps1*eps2rt**2*eps3rt**2
1366 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1367 c     &        /dabs(eps(itypi,itypj))
1368 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1369 c            eneps_temp(ij)=eneps_temp(ij)
1370 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1371 c            if (lprn) then
1372 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1373 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1374 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1375 c     &        restyp(itypi),i,restyp(itypj),j,
1376 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1377 c     &        chi1,chi2,chip1,chip2,
1378 c     &        eps1,eps2rt**2,eps3rt**2,
1379 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1380 c     &        evdwij+e_augm
1381 c            endif
1382             if (calc_grad) then
1383 C Calculate gradient components.
1384             e1=e1*eps1*eps2rt**2*eps3rt**2
1385             fac=-expon*(e1+evdwij)*rij_shift
1386             sigder=fac*sigder
1387             fac=rij*fac-2*expon*rrij*e_augm
1388 C Calculate the radial part of the gradient
1389             gg(1)=xj*fac
1390             gg(2)=yj*fac
1391             gg(3)=zj*fac
1392 C Calculate angular part of the gradient.
1393             call sc_grad
1394             endif
1395           enddo      ! j
1396         enddo        ! iint
1397       enddo          ! i
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine sc_angular
1402 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1403 C om12. Called by ebp, egb, and egbv.
1404       implicit none
1405       include 'COMMON.CALC'
1406       erij(1)=xj*rij
1407       erij(2)=yj*rij
1408       erij(3)=zj*rij
1409       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1410       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1411       om12=dxi*dxj+dyi*dyj+dzi*dzj
1412       chiom12=chi12*om12
1413 C Calculate eps1(om12) and its derivative in om12
1414       faceps1=1.0D0-om12*chiom12
1415       faceps1_inv=1.0D0/faceps1
1416       eps1=dsqrt(faceps1_inv)
1417 C Following variable is eps1*deps1/dom12
1418       eps1_om12=faceps1_inv*chiom12
1419 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1420 C and om12.
1421       om1om2=om1*om2
1422       chiom1=chi1*om1
1423       chiom2=chi2*om2
1424       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1425       sigsq=1.0D0-facsig*faceps1_inv
1426       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1427       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1428       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1429 C Calculate eps2 and its derivatives in om1, om2, and om12.
1430       chipom1=chip1*om1
1431       chipom2=chip2*om2
1432       chipom12=chip12*om12
1433       facp=1.0D0-om12*chipom12
1434       facp_inv=1.0D0/facp
1435       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1436 C Following variable is the square root of eps2
1437       eps2rt=1.0D0-facp1*facp_inv
1438 C Following three variables are the derivatives of the square root of eps
1439 C in om1, om2, and om12.
1440       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1441       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1442       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1443 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1444       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1445 C Calculate whole angle-dependent part of epsilon and contributions
1446 C to its derivatives
1447       return
1448       end
1449 C----------------------------------------------------------------------------
1450       subroutine sc_grad
1451       implicit real*8 (a-h,o-z)
1452       include 'DIMENSIONS'
1453       include 'COMMON.CHAIN'
1454       include 'COMMON.DERIV'
1455       include 'COMMON.CALC'
1456       double precision dcosom1(3),dcosom2(3)
1457       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1458       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1459       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1460      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1461       do k=1,3
1462         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1463         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1464       enddo
1465       do k=1,3
1466         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1467       enddo
1468       do k=1,3
1469         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1470      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1471      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1472         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1474      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1475       enddo
1476 C
1477 C Calculate the components of the gradient in DC and X
1478 C
1479       do k=i,j-1
1480         do l=1,3
1481           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1482         enddo
1483       enddo
1484       return
1485       end
1486 c------------------------------------------------------------------------------
1487       subroutine vec_and_deriv
1488       implicit real*8 (a-h,o-z)
1489       include 'DIMENSIONS'
1490       include 'COMMON.IOUNITS'
1491       include 'COMMON.GEO'
1492       include 'COMMON.VAR'
1493       include 'COMMON.LOCAL'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.VECTORS'
1496       include 'COMMON.DERIV'
1497       include 'COMMON.INTERACT'
1498       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1499 C Compute the local reference systems. For reference system (i), the
1500 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1501 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1502       do i=1,nres-1
1503 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1504           if (i.eq.nres-1) then
1505 C Case of the last full residue
1506 C Compute the Z-axis
1507             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1508             costh=dcos(pi-theta(nres))
1509             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1510 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1511 c     &         " uz",uz(:,i)
1512             do k=1,3
1513               uz(k,i)=fac*uz(k,i)
1514             enddo
1515             if (calc_grad) then
1516 C Compute the derivatives of uz
1517             uzder(1,1,1)= 0.0d0
1518             uzder(2,1,1)=-dc_norm(3,i-1)
1519             uzder(3,1,1)= dc_norm(2,i-1)
1520             uzder(1,2,1)= dc_norm(3,i-1)
1521             uzder(2,2,1)= 0.0d0
1522             uzder(3,2,1)=-dc_norm(1,i-1)
1523             uzder(1,3,1)=-dc_norm(2,i-1)
1524             uzder(2,3,1)= dc_norm(1,i-1)
1525             uzder(3,3,1)= 0.0d0
1526             uzder(1,1,2)= 0.0d0
1527             uzder(2,1,2)= dc_norm(3,i)
1528             uzder(3,1,2)=-dc_norm(2,i)
1529             uzder(1,2,2)=-dc_norm(3,i)
1530             uzder(2,2,2)= 0.0d0
1531             uzder(3,2,2)= dc_norm(1,i)
1532             uzder(1,3,2)= dc_norm(2,i)
1533             uzder(2,3,2)=-dc_norm(1,i)
1534             uzder(3,3,2)= 0.0d0
1535             endif ! calc_grad
1536 C Compute the Y-axis
1537             facy=fac
1538             do k=1,3
1539               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1540             enddo
1541             if (calc_grad) then
1542 C Compute the derivatives of uy
1543             do j=1,3
1544               do k=1,3
1545                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1546      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1547                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1548               enddo
1549               uyder(j,j,1)=uyder(j,j,1)-costh
1550               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1551             enddo
1552             do j=1,2
1553               do k=1,3
1554                 do l=1,3
1555                   uygrad(l,k,j,i)=uyder(l,k,j)
1556                   uzgrad(l,k,j,i)=uzder(l,k,j)
1557                 enddo
1558               enddo
1559             enddo
1560             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1561             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1562             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1563             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1564             endif
1565           else
1566 C Other residues
1567 C Compute the Z-axis
1568             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1569             costh=dcos(pi-theta(i+2))
1570             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1571             do k=1,3
1572               uz(k,i)=fac*uz(k,i)
1573             enddo
1574             if (calc_grad) then
1575 C Compute the derivatives of uz
1576             uzder(1,1,1)= 0.0d0
1577             uzder(2,1,1)=-dc_norm(3,i+1)
1578             uzder(3,1,1)= dc_norm(2,i+1)
1579             uzder(1,2,1)= dc_norm(3,i+1)
1580             uzder(2,2,1)= 0.0d0
1581             uzder(3,2,1)=-dc_norm(1,i+1)
1582             uzder(1,3,1)=-dc_norm(2,i+1)
1583             uzder(2,3,1)= dc_norm(1,i+1)
1584             uzder(3,3,1)= 0.0d0
1585             uzder(1,1,2)= 0.0d0
1586             uzder(2,1,2)= dc_norm(3,i)
1587             uzder(3,1,2)=-dc_norm(2,i)
1588             uzder(1,2,2)=-dc_norm(3,i)
1589             uzder(2,2,2)= 0.0d0
1590             uzder(3,2,2)= dc_norm(1,i)
1591             uzder(1,3,2)= dc_norm(2,i)
1592             uzder(2,3,2)=-dc_norm(1,i)
1593             uzder(3,3,2)= 0.0d0
1594             endif
1595 C Compute the Y-axis
1596             facy=fac
1597             do k=1,3
1598               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1599             enddo
1600             if (calc_grad) then
1601 C Compute the derivatives of uy
1602             do j=1,3
1603               do k=1,3
1604                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1605      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1606                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1607               enddo
1608               uyder(j,j,1)=uyder(j,j,1)-costh
1609               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1610             enddo
1611             do j=1,2
1612               do k=1,3
1613                 do l=1,3
1614                   uygrad(l,k,j,i)=uyder(l,k,j)
1615                   uzgrad(l,k,j,i)=uzder(l,k,j)
1616                 enddo
1617               enddo
1618             enddo
1619             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1620             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1621             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1622             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1623           endif
1624           endif
1625       enddo
1626       if (calc_grad) then
1627       do i=1,nres-1
1628         vbld_inv_temp(1)=vbld_inv(i+1)
1629         if (i.lt.nres-1) then
1630           vbld_inv_temp(2)=vbld_inv(i+2)
1631         else
1632           vbld_inv_temp(2)=vbld_inv(i)
1633         endif
1634         do j=1,2
1635           do k=1,3
1636             do l=1,3
1637               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1638               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1639             enddo
1640           enddo
1641         enddo
1642       enddo
1643       endif
1644       return
1645       end
1646 C--------------------------------------------------------------------------
1647       subroutine set_matrices
1648       implicit real*8 (a-h,o-z)
1649       include 'DIMENSIONS'
1650 #ifdef MPI
1651       include "mpif.h"
1652       integer IERR
1653       integer status(MPI_STATUS_SIZE)
1654 #endif
1655       include 'COMMON.IOUNITS'
1656       include 'COMMON.GEO'
1657       include 'COMMON.VAR'
1658       include 'COMMON.LOCAL'
1659       include 'COMMON.CHAIN'
1660       include 'COMMON.DERIV'
1661       include 'COMMON.INTERACT'
1662       include 'COMMON.CONTACTS'
1663       include 'COMMON.TORSION'
1664       include 'COMMON.VECTORS'
1665       include 'COMMON.FFIELD'
1666       double precision auxvec(2),auxmat(2,2)
1667 C
1668 C Compute the virtual-bond-torsional-angle dependent quantities needed
1669 C to calculate the el-loc multibody terms of various order.
1670 C
1671 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1672       do i=3,nres+1
1673         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1674           iti = itype2loc(itype(i-2))
1675         else
1676           iti=nloctyp
1677         endif
1678 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1679         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1680           iti1 = itype2loc(itype(i-1))
1681         else
1682           iti1=nloctyp
1683         endif
1684 #ifdef NEWCORR
1685         cost1=dcos(theta(i-1))
1686         sint1=dsin(theta(i-1))
1687         sint1sq=sint1*sint1
1688         sint1cub=sint1sq*sint1
1689         sint1cost1=2*sint1*cost1
1690 #ifdef DEBUG
1691         write (iout,*) "bnew1",i,iti
1692         write (iout,*) (bnew1(k,1,iti),k=1,3)
1693         write (iout,*) (bnew1(k,2,iti),k=1,3)
1694         write (iout,*) "bnew2",i,iti
1695         write (iout,*) (bnew2(k,1,iti),k=1,3)
1696         write (iout,*) (bnew2(k,2,iti),k=1,3)
1697 #endif
1698         do k=1,2
1699           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1700           b1(k,i-2)=sint1*b1k
1701           gtb1(k,i-2)=cost1*b1k-sint1sq*
1702      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1703           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1704           b2(k,i-2)=sint1*b2k
1705           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1706      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1707         enddo
1708         do k=1,2
1709           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1710           cc(1,k,i-2)=sint1sq*aux
1711           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1712      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1713           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1714           dd(1,k,i-2)=sint1sq*aux
1715           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1716      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1717         enddo
1718         cc(2,1,i-2)=cc(1,2,i-2)
1719         cc(2,2,i-2)=-cc(1,1,i-2)
1720         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1721         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1722         dd(2,1,i-2)=dd(1,2,i-2)
1723         dd(2,2,i-2)=-dd(1,1,i-2)
1724         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1725         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1726         do k=1,2
1727           do l=1,2
1728             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1729             EE(l,k,i-2)=sint1sq*aux
1730             if (calc_grad)
1731      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1732           enddo
1733         enddo
1734         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1735         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1736         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1737         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1738         if (calc_grad) then
1739         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1740         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1741         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1742         endif
1743 c        b1tilde(1,i-2)=b1(1,i-2)
1744 c        b1tilde(2,i-2)=-b1(2,i-2)
1745 c        b2tilde(1,i-2)=b2(1,i-2)
1746 c        b2tilde(2,i-2)=-b2(2,i-2)
1747 #ifdef DEBUG
1748         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1749         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1750         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1751         write (iout,*) 'theta=', theta(i-1)
1752 #endif
1753 #else
1754 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1755 c          iti = itype2loc(itype(i-2))
1756 c        else
1757 c          iti=nloctyp
1758 c        endif
1759 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1760 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1761 c          iti1 = itype2loc(itype(i-1))
1762 c        else
1763 c          iti1=nloctyp
1764 c        endif
1765         b1(1,i-2)=b(3,iti)
1766         b1(2,i-2)=b(5,iti)
1767         b2(1,i-2)=b(2,iti)
1768         b2(2,i-2)=b(4,iti)
1769         do k=1,2
1770           do l=1,2
1771            CC(k,l,i-2)=ccold(k,l,iti)
1772            DD(k,l,i-2)=ddold(k,l,iti)
1773            EE(k,l,i-2)=eeold(k,l,iti)
1774           enddo
1775         enddo
1776 #endif
1777         b1tilde(1,i-2)= b1(1,i-2)
1778         b1tilde(2,i-2)=-b1(2,i-2)
1779         b2tilde(1,i-2)= b2(1,i-2)
1780         b2tilde(2,i-2)=-b2(2,i-2)
1781 c
1782         Ctilde(1,1,i-2)= CC(1,1,i-2)
1783         Ctilde(1,2,i-2)= CC(1,2,i-2)
1784         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1785         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1786 c
1787         Dtilde(1,1,i-2)= DD(1,1,i-2)
1788         Dtilde(1,2,i-2)= DD(1,2,i-2)
1789         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1790         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1791 c        write(iout,*) "i",i," iti",iti
1792 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1793 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1794       enddo
1795       do i=3,nres+1
1796         if (i .lt. nres+1) then
1797           sin1=dsin(phi(i))
1798           cos1=dcos(phi(i))
1799           sintab(i-2)=sin1
1800           costab(i-2)=cos1
1801           obrot(1,i-2)=cos1
1802           obrot(2,i-2)=sin1
1803           sin2=dsin(2*phi(i))
1804           cos2=dcos(2*phi(i))
1805           sintab2(i-2)=sin2
1806           costab2(i-2)=cos2
1807           obrot2(1,i-2)=cos2
1808           obrot2(2,i-2)=sin2
1809           Ug(1,1,i-2)=-cos1
1810           Ug(1,2,i-2)=-sin1
1811           Ug(2,1,i-2)=-sin1
1812           Ug(2,2,i-2)= cos1
1813           Ug2(1,1,i-2)=-cos2
1814           Ug2(1,2,i-2)=-sin2
1815           Ug2(2,1,i-2)=-sin2
1816           Ug2(2,2,i-2)= cos2
1817         else
1818           costab(i-2)=1.0d0
1819           sintab(i-2)=0.0d0
1820           obrot(1,i-2)=1.0d0
1821           obrot(2,i-2)=0.0d0
1822           obrot2(1,i-2)=0.0d0
1823           obrot2(2,i-2)=0.0d0
1824           Ug(1,1,i-2)=1.0d0
1825           Ug(1,2,i-2)=0.0d0
1826           Ug(2,1,i-2)=0.0d0
1827           Ug(2,2,i-2)=1.0d0
1828           Ug2(1,1,i-2)=0.0d0
1829           Ug2(1,2,i-2)=0.0d0
1830           Ug2(2,1,i-2)=0.0d0
1831           Ug2(2,2,i-2)=0.0d0
1832         endif
1833         if (i .gt. 3 .and. i .lt. nres+1) then
1834           obrot_der(1,i-2)=-sin1
1835           obrot_der(2,i-2)= cos1
1836           Ugder(1,1,i-2)= sin1
1837           Ugder(1,2,i-2)=-cos1
1838           Ugder(2,1,i-2)=-cos1
1839           Ugder(2,2,i-2)=-sin1
1840           dwacos2=cos2+cos2
1841           dwasin2=sin2+sin2
1842           obrot2_der(1,i-2)=-dwasin2
1843           obrot2_der(2,i-2)= dwacos2
1844           Ug2der(1,1,i-2)= dwasin2
1845           Ug2der(1,2,i-2)=-dwacos2
1846           Ug2der(2,1,i-2)=-dwacos2
1847           Ug2der(2,2,i-2)=-dwasin2
1848         else
1849           obrot_der(1,i-2)=0.0d0
1850           obrot_der(2,i-2)=0.0d0
1851           Ugder(1,1,i-2)=0.0d0
1852           Ugder(1,2,i-2)=0.0d0
1853           Ugder(2,1,i-2)=0.0d0
1854           Ugder(2,2,i-2)=0.0d0
1855           obrot2_der(1,i-2)=0.0d0
1856           obrot2_der(2,i-2)=0.0d0
1857           Ug2der(1,1,i-2)=0.0d0
1858           Ug2der(1,2,i-2)=0.0d0
1859           Ug2der(2,1,i-2)=0.0d0
1860           Ug2der(2,2,i-2)=0.0d0
1861         endif
1862 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1863         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1864           iti = itype2loc(itype(i-2))
1865         else
1866           iti=nloctyp
1867         endif
1868 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1869         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1870           iti1 = itype2loc(itype(i-1))
1871         else
1872           iti1=nloctyp
1873         endif
1874 cd        write (iout,*) '*******i',i,' iti1',iti
1875 cd        write (iout,*) 'b1',b1(:,iti)
1876 cd        write (iout,*) 'b2',b2(:,iti)
1877 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1878 c        if (i .gt. iatel_s+2) then
1879         if (i .gt. nnt+2) then
1880           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1881 #ifdef NEWCORR
1882           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1883 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1884 #endif
1885 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1886 c     &    EE(1,2,iti),EE(2,2,i)
1887           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1888           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1889 c          write(iout,*) "Macierz EUG",
1890 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1891 c     &    eug(2,2,i-2)
1892           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1893      &    then
1894           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1895           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1896           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1897           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1898           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1899           endif
1900         else
1901           do k=1,2
1902             Ub2(k,i-2)=0.0d0
1903             Ctobr(k,i-2)=0.0d0
1904             Dtobr2(k,i-2)=0.0d0
1905             do l=1,2
1906               EUg(l,k,i-2)=0.0d0
1907               CUg(l,k,i-2)=0.0d0
1908               DUg(l,k,i-2)=0.0d0
1909               DtUg2(l,k,i-2)=0.0d0
1910             enddo
1911           enddo
1912         endif
1913         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1914         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1915         do k=1,2
1916           muder(k,i-2)=Ub2der(k,i-2)
1917         enddo
1918 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1919         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1920           if (itype(i-1).le.ntyp) then
1921             iti1 = itype2loc(itype(i-1))
1922           else
1923             iti1=nloctyp
1924           endif
1925         else
1926           iti1=nloctyp
1927         endif
1928         do k=1,2
1929           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
1930         enddo
1931 #ifdef MUOUT
1932         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
1933      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
1934      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
1935      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
1936      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
1937      &      ((ee(l,k,i-2),l=1,2),k=1,2)
1938 #endif
1939 cd        write (iout,*) 'mu1',mu1(:,i-2)
1940 cd        write (iout,*) 'mu2',mu2(:,i-2)
1941         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
1942      &  then
1943         if (calc_grad) then
1944         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1945         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
1946         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1947         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
1948         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1949         endif
1950 C Vectors and matrices dependent on a single virtual-bond dihedral.
1951         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
1952         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1953         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
1954         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
1955         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
1956         if (calc_grad) then
1957         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1958         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
1959         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
1960         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
1961         endif
1962         endif
1963       enddo
1964 C Matrices dependent on two consecutive virtual-bond dihedrals.
1965 C The order of matrices is from left to right.
1966       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
1967      &then
1968       do i=2,nres-1
1969         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1970         if (calc_grad) then
1971         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1972         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1973         endif
1974         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1975         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1976         if (calc_grad) then
1977         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1978         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1979         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1980         endif
1981       enddo
1982       endif
1983       return
1984       end
1985 C--------------------------------------------------------------------------
1986       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1987 C
1988 C This subroutine calculates the average interaction energy and its gradient
1989 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1990 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1991 C The potential depends both on the distance of peptide-group centers and on
1992 C the orientation of the CA-CA virtual bonds.
1993 C
1994       implicit real*8 (a-h,o-z)
1995 #ifdef MPI
1996       include 'mpif.h'
1997 #endif
1998       include 'DIMENSIONS'
1999       include 'COMMON.CONTROL'
2000       include 'COMMON.IOUNITS'
2001       include 'COMMON.GEO'
2002       include 'COMMON.VAR'
2003       include 'COMMON.LOCAL'
2004       include 'COMMON.CHAIN'
2005       include 'COMMON.DERIV'
2006       include 'COMMON.INTERACT'
2007       include 'COMMON.CONTACTS'
2008       include 'COMMON.TORSION'
2009       include 'COMMON.VECTORS'
2010       include 'COMMON.FFIELD'
2011       include 'COMMON.TIME1'
2012       include 'COMMON.SPLITELE'
2013       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2014      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2015       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2016      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2017       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2018      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2019      &    num_conti,j1,j2
2020 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2021 #ifdef MOMENT
2022       double precision scal_el /1.0d0/
2023 #else
2024       double precision scal_el /0.5d0/
2025 #endif
2026 C 12/13/98
2027 C 13-go grudnia roku pamietnego...
2028       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2029      &                   0.0d0,1.0d0,0.0d0,
2030      &                   0.0d0,0.0d0,1.0d0/
2031 cd      write(iout,*) 'In EELEC'
2032 cd      do i=1,nloctyp
2033 cd        write(iout,*) 'Type',i
2034 cd        write(iout,*) 'B1',B1(:,i)
2035 cd        write(iout,*) 'B2',B2(:,i)
2036 cd        write(iout,*) 'CC',CC(:,:,i)
2037 cd        write(iout,*) 'DD',DD(:,:,i)
2038 cd        write(iout,*) 'EE',EE(:,:,i)
2039 cd      enddo
2040 cd      call check_vecgrad
2041 cd      stop
2042       if (icheckgrad.eq.1) then
2043         do i=1,nres-1
2044           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2045           do k=1,3
2046             dc_norm(k,i)=dc(k,i)*fac
2047           enddo
2048 c          write (iout,*) 'i',i,' fac',fac
2049         enddo
2050       endif
2051       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2052      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2053      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2054 c        call vec_and_deriv
2055 #ifdef TIMING
2056         time01=MPI_Wtime()
2057 #endif
2058         call set_matrices
2059 #ifdef TIMING
2060         time_mat=time_mat+MPI_Wtime()-time01
2061 #endif
2062       endif
2063 cd      do i=1,nres-1
2064 cd        write (iout,*) 'i=',i
2065 cd        do k=1,3
2066 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2067 cd        enddo
2068 cd        do k=1,3
2069 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2070 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2071 cd        enddo
2072 cd      enddo
2073       t_eelecij=0.0d0
2074       ees=0.0D0
2075       evdw1=0.0D0
2076       eel_loc=0.0d0
2077       eello_turn3=0.0d0
2078       eello_turn4=0.0d0
2079       ind=0
2080       do i=1,nres
2081         num_cont_hb(i)=0
2082       enddo
2083 cd      print '(a)','Enter EELEC'
2084 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2085 c      call flush(iout)
2086       do i=1,nres
2087         gel_loc_loc(i)=0.0d0
2088         gcorr_loc(i)=0.0d0
2089       enddo
2090 c
2091 c
2092 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2093 C
2094 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2095 C
2096 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2097       do i=iturn3_start,iturn3_end
2098 c        if (i.le.1) cycle
2099 C        write(iout,*) "tu jest i",i
2100         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2101 C changes suggested by Ana to avoid out of bounds
2102 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2103 c     & .or.((i+4).gt.nres)
2104 c     & .or.((i-1).le.0)
2105 C end of changes by Ana
2106 C dobra zmiana wycofana
2107      &  .or. itype(i+2).eq.ntyp1
2108      &  .or. itype(i+3).eq.ntyp1) cycle
2109 C Adam: Instructions below will switch off existing interactions
2110 c        if(i.gt.1)then
2111 c          if(itype(i-1).eq.ntyp1)cycle
2112 c        end if
2113 c        if(i.LT.nres-3)then
2114 c          if (itype(i+4).eq.ntyp1) cycle
2115 c        end if
2116         dxi=dc(1,i)
2117         dyi=dc(2,i)
2118         dzi=dc(3,i)
2119         dx_normi=dc_norm(1,i)
2120         dy_normi=dc_norm(2,i)
2121         dz_normi=dc_norm(3,i)
2122         xmedi=c(1,i)+0.5d0*dxi
2123         ymedi=c(2,i)+0.5d0*dyi
2124         zmedi=c(3,i)+0.5d0*dzi
2125           xmedi=mod(xmedi,boxxsize)
2126           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2127           ymedi=mod(ymedi,boxysize)
2128           if (ymedi.lt.0) ymedi=ymedi+boxysize
2129           zmedi=mod(zmedi,boxzsize)
2130           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2131         num_conti=0
2132         call eelecij(i,i+2,ees,evdw1,eel_loc)
2133         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2134         num_cont_hb(i)=num_conti
2135       enddo
2136       do i=iturn4_start,iturn4_end
2137         if (i.lt.1) cycle
2138         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2139 C changes suggested by Ana to avoid out of bounds
2140 c     & .or.((i+5).gt.nres)
2141 c     & .or.((i-1).le.0)
2142 C end of changes suggested by Ana
2143      &    .or. itype(i+3).eq.ntyp1
2144      &    .or. itype(i+4).eq.ntyp1
2145 c     &    .or. itype(i+5).eq.ntyp1
2146 c     &    .or. itype(i).eq.ntyp1
2147 c     &    .or. itype(i-1).eq.ntyp1
2148      &                             ) cycle
2149         dxi=dc(1,i)
2150         dyi=dc(2,i)
2151         dzi=dc(3,i)
2152         dx_normi=dc_norm(1,i)
2153         dy_normi=dc_norm(2,i)
2154         dz_normi=dc_norm(3,i)
2155         xmedi=c(1,i)+0.5d0*dxi
2156         ymedi=c(2,i)+0.5d0*dyi
2157         zmedi=c(3,i)+0.5d0*dzi
2158 C Return atom into box, boxxsize is size of box in x dimension
2159 c  194   continue
2160 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2161 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2162 C Condition for being inside the proper box
2163 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2164 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2165 c        go to 194
2166 c        endif
2167 c  195   continue
2168 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2169 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2170 C Condition for being inside the proper box
2171 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2172 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2173 c        go to 195
2174 c        endif
2175 c  196   continue
2176 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2177 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2178 C Condition for being inside the proper box
2179 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2180 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2181 c        go to 196
2182 c        endif
2183           xmedi=mod(xmedi,boxxsize)
2184           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2185           ymedi=mod(ymedi,boxysize)
2186           if (ymedi.lt.0) ymedi=ymedi+boxysize
2187           zmedi=mod(zmedi,boxzsize)
2188           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2189
2190         num_conti=num_cont_hb(i)
2191 c        write(iout,*) "JESTEM W PETLI"
2192         call eelecij(i,i+3,ees,evdw1,eel_loc)
2193         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2194      &   call eturn4(i,eello_turn4)
2195         num_cont_hb(i)=num_conti
2196       enddo   ! i
2197 C Loop over all neighbouring boxes
2198 C      do xshift=-1,1
2199 C      do yshift=-1,1
2200 C      do zshift=-1,1
2201 c
2202 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2203 c
2204 CTU KURWA
2205       do i=iatel_s,iatel_e
2206 C        do i=75,75
2207 c        if (i.le.1) cycle
2208         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2209 C changes suggested by Ana to avoid out of bounds
2210 c     & .or.((i+2).gt.nres)
2211 c     & .or.((i-1).le.0)
2212 C end of changes by Ana
2213 c     &  .or. itype(i+2).eq.ntyp1
2214 c     &  .or. itype(i-1).eq.ntyp1
2215      &                ) cycle
2216         dxi=dc(1,i)
2217         dyi=dc(2,i)
2218         dzi=dc(3,i)
2219         dx_normi=dc_norm(1,i)
2220         dy_normi=dc_norm(2,i)
2221         dz_normi=dc_norm(3,i)
2222         xmedi=c(1,i)+0.5d0*dxi
2223         ymedi=c(2,i)+0.5d0*dyi
2224         zmedi=c(3,i)+0.5d0*dzi
2225           xmedi=mod(xmedi,boxxsize)
2226           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2227           ymedi=mod(ymedi,boxysize)
2228           if (ymedi.lt.0) ymedi=ymedi+boxysize
2229           zmedi=mod(zmedi,boxzsize)
2230           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2231 C          xmedi=xmedi+xshift*boxxsize
2232 C          ymedi=ymedi+yshift*boxysize
2233 C          zmedi=zmedi+zshift*boxzsize
2234
2235 C Return tom into box, boxxsize is size of box in x dimension
2236 c  164   continue
2237 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2238 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2239 C Condition for being inside the proper box
2240 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2241 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2242 c        go to 164
2243 c        endif
2244 c  165   continue
2245 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2246 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2247 C Condition for being inside the proper box
2248 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2249 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2250 c        go to 165
2251 c        endif
2252 c  166   continue
2253 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2254 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2255 cC Condition for being inside the proper box
2256 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2257 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2258 c        go to 166
2259 c        endif
2260
2261 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2262         num_conti=num_cont_hb(i)
2263 C I TU KURWA
2264         do j=ielstart(i),ielend(i)
2265 C          do j=16,17
2266 C          write (iout,*) i,j
2267 C         if (j.le.1) cycle
2268           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2269 C changes suggested by Ana to avoid out of bounds
2270 c     & .or.((j+2).gt.nres)
2271 c     & .or.((j-1).le.0)
2272 C end of changes by Ana
2273 c     & .or.itype(j+2).eq.ntyp1
2274 c     & .or.itype(j-1).eq.ntyp1
2275      &) cycle
2276           call eelecij(i,j,ees,evdw1,eel_loc)
2277         enddo ! j
2278         num_cont_hb(i)=num_conti
2279       enddo   ! i
2280 C     enddo   ! zshift
2281 C      enddo   ! yshift
2282 C      enddo   ! xshift
2283
2284 c      write (iout,*) "Number of loop steps in EELEC:",ind
2285 cd      do i=1,nres
2286 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2287 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2288 cd      enddo
2289 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2290 ccc      eel_loc=eel_loc+eello_turn3
2291 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2292       return
2293       end
2294 C-------------------------------------------------------------------------------
2295       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2296       implicit real*8 (a-h,o-z)
2297       include 'DIMENSIONS'
2298 #ifdef MPI
2299       include "mpif.h"
2300 #endif
2301       include 'COMMON.CONTROL'
2302       include 'COMMON.IOUNITS'
2303       include 'COMMON.GEO'
2304       include 'COMMON.VAR'
2305       include 'COMMON.LOCAL'
2306       include 'COMMON.CHAIN'
2307       include 'COMMON.DERIV'
2308       include 'COMMON.INTERACT'
2309       include 'COMMON.CONTACTS'
2310       include 'COMMON.TORSION'
2311       include 'COMMON.VECTORS'
2312       include 'COMMON.FFIELD'
2313       include 'COMMON.TIME1'
2314       include 'COMMON.SPLITELE'
2315       include 'COMMON.SHIELD'
2316       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2317      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2318       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2319      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2320      &    gmuij2(4),gmuji2(4)
2321       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2322      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2323      &    num_conti,j1,j2
2324 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2325 #ifdef MOMENT
2326       double precision scal_el /1.0d0/
2327 #else
2328       double precision scal_el /0.5d0/
2329 #endif
2330 C 12/13/98
2331 C 13-go grudnia roku pamietnego...
2332       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2333      &                   0.0d0,1.0d0,0.0d0,
2334      &                   0.0d0,0.0d0,1.0d0/
2335        integer xshift,yshift,zshift
2336 c          time00=MPI_Wtime()
2337 cd      write (iout,*) "eelecij",i,j
2338 c          ind=ind+1
2339           iteli=itel(i)
2340           itelj=itel(j)
2341           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2342           aaa=app(iteli,itelj)
2343           bbb=bpp(iteli,itelj)
2344           ael6i=ael6(iteli,itelj)
2345           ael3i=ael3(iteli,itelj)
2346           dxj=dc(1,j)
2347           dyj=dc(2,j)
2348           dzj=dc(3,j)
2349           dx_normj=dc_norm(1,j)
2350           dy_normj=dc_norm(2,j)
2351           dz_normj=dc_norm(3,j)
2352 C          xj=c(1,j)+0.5D0*dxj-xmedi
2353 C          yj=c(2,j)+0.5D0*dyj-ymedi
2354 C          zj=c(3,j)+0.5D0*dzj-zmedi
2355           xj=c(1,j)+0.5D0*dxj
2356           yj=c(2,j)+0.5D0*dyj
2357           zj=c(3,j)+0.5D0*dzj
2358           xj=mod(xj,boxxsize)
2359           if (xj.lt.0) xj=xj+boxxsize
2360           yj=mod(yj,boxysize)
2361           if (yj.lt.0) yj=yj+boxysize
2362           zj=mod(zj,boxzsize)
2363           if (zj.lt.0) zj=zj+boxzsize
2364           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2365       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2366       xj_safe=xj
2367       yj_safe=yj
2368       zj_safe=zj
2369       isubchap=0
2370       do xshift=-1,1
2371       do yshift=-1,1
2372       do zshift=-1,1
2373           xj=xj_safe+xshift*boxxsize
2374           yj=yj_safe+yshift*boxysize
2375           zj=zj_safe+zshift*boxzsize
2376           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2377           if(dist_temp.lt.dist_init) then
2378             dist_init=dist_temp
2379             xj_temp=xj
2380             yj_temp=yj
2381             zj_temp=zj
2382             isubchap=1
2383           endif
2384        enddo
2385        enddo
2386        enddo
2387        if (isubchap.eq.1) then
2388           xj=xj_temp-xmedi
2389           yj=yj_temp-ymedi
2390           zj=zj_temp-zmedi
2391        else
2392           xj=xj_safe-xmedi
2393           yj=yj_safe-ymedi
2394           zj=zj_safe-zmedi
2395        endif
2396 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2397 c  174   continue
2398 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2399 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2400 C Condition for being inside the proper box
2401 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2402 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2403 c        go to 174
2404 c        endif
2405 c  175   continue
2406 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2407 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2408 C Condition for being inside the proper box
2409 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2410 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2411 c        go to 175
2412 c        endif
2413 c  176   continue
2414 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2415 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2416 C Condition for being inside the proper box
2417 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2418 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2419 c        go to 176
2420 c        endif
2421 C        endif !endPBC condintion
2422 C        xj=xj-xmedi
2423 C        yj=yj-ymedi
2424 C        zj=zj-zmedi
2425           rij=xj*xj+yj*yj+zj*zj
2426
2427             sss=sscale(sqrt(rij))
2428             sssgrad=sscagrad(sqrt(rij))
2429 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2430 c     &       " rlamb",rlamb," sss",sss
2431 c            if (sss.gt.0.0d0) then
2432           rrmij=1.0D0/rij
2433           rij=dsqrt(rij)
2434           rmij=1.0D0/rij
2435           r3ij=rrmij*rmij
2436           r6ij=r3ij*r3ij
2437           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2438           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2439           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2440           fac=cosa-3.0D0*cosb*cosg
2441           ev1=aaa*r6ij*r6ij
2442 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2443           if (j.eq.i+2) ev1=scal_el*ev1
2444           ev2=bbb*r6ij
2445           fac3=ael6i*r6ij
2446           fac4=ael3i*r3ij
2447           evdwij=(ev1+ev2)
2448           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2449           el2=fac4*fac
2450 C MARYSIA
2451 C          eesij=(el1+el2)
2452 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2453           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2454           if (shield_mode.gt.0) then
2455 C          fac_shield(i)=0.4
2456 C          fac_shield(j)=0.6
2457           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2458           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2459           eesij=(el1+el2)
2460           ees=ees+eesij
2461           else
2462           fac_shield(i)=1.0
2463           fac_shield(j)=1.0
2464           eesij=(el1+el2)
2465           ees=ees+eesij
2466           endif
2467           evdw1=evdw1+evdwij*sss
2468 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2469 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2470 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2471 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2472
2473           if (energy_dec) then
2474               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2475      &'evdw1',i,j,evdwij
2476      &,iteli,itelj,aaa,evdw1,sss
2477               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2478      &fac_shield(i),fac_shield(j)
2479           endif
2480
2481 C
2482 C Calculate contributions to the Cartesian gradient.
2483 C
2484 #ifdef SPLITELE
2485           facvdw=-6*rrmij*(ev1+evdwij)*sss
2486           facel=-3*rrmij*(el1+eesij)
2487           fac1=fac
2488           erij(1)=xj*rmij
2489           erij(2)=yj*rmij
2490           erij(3)=zj*rmij
2491
2492 *
2493 * Radial derivatives. First process both termini of the fragment (i,j)
2494 *
2495           if (calc_grad) then
2496           ggg(1)=facel*xj
2497           ggg(2)=facel*yj
2498           ggg(3)=facel*zj
2499           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2500      &  (shield_mode.gt.0)) then
2501 C          print *,i,j
2502           do ilist=1,ishield_list(i)
2503            iresshield=shield_list(ilist,i)
2504            do k=1,3
2505            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2506      &      *2.0
2507            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2508      &              rlocshield
2509      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2510             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2511 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2512 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2513 C             if (iresshield.gt.i) then
2514 C               do ishi=i+1,iresshield-1
2515 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2516 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2517 C
2518 C              enddo
2519 C             else
2520 C               do ishi=iresshield,i
2521 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2522 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2523 C
2524 C               enddo
2525 C              endif
2526            enddo
2527           enddo
2528           do ilist=1,ishield_list(j)
2529            iresshield=shield_list(ilist,j)
2530            do k=1,3
2531            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2532      &     *2.0
2533            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2534      &              rlocshield
2535      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2536            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2537
2538 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2539 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2540 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2541 C             if (iresshield.gt.j) then
2542 C               do ishi=j+1,iresshield-1
2543 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2544 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2545 C
2546 C               enddo
2547 C            else
2548 C               do ishi=iresshield,j
2549 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2550 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2551 C               enddo
2552 C              endif
2553            enddo
2554           enddo
2555
2556           do k=1,3
2557             gshieldc(k,i)=gshieldc(k,i)+
2558      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2559             gshieldc(k,j)=gshieldc(k,j)+
2560      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2561             gshieldc(k,i-1)=gshieldc(k,i-1)+
2562      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2563             gshieldc(k,j-1)=gshieldc(k,j-1)+
2564      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2565
2566            enddo
2567            endif
2568 c          do k=1,3
2569 c            ghalf=0.5D0*ggg(k)
2570 c            gelc(k,i)=gelc(k,i)+ghalf
2571 c            gelc(k,j)=gelc(k,j)+ghalf
2572 c          enddo
2573 c 9/28/08 AL Gradient compotents will be summed only at the end
2574 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2575           do k=1,3
2576             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2577 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2578             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2579 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2580 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2581 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2582 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2583 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2584           enddo
2585 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2586
2587 *
2588 * Loop over residues i+1 thru j-1.
2589 *
2590 cgrad          do k=i+1,j-1
2591 cgrad            do l=1,3
2592 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2593 cgrad            enddo
2594 cgrad          enddo
2595           if (sss.gt.0.0) then
2596           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2597           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2598           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2599           else
2600           ggg(1)=0.0
2601           ggg(2)=0.0
2602           ggg(3)=0.0
2603           endif
2604 c          do k=1,3
2605 c            ghalf=0.5D0*ggg(k)
2606 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2607 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2608 c          enddo
2609 c 9/28/08 AL Gradient compotents will be summed only at the end
2610           do k=1,3
2611             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2612             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2613           enddo
2614 *
2615 * Loop over residues i+1 thru j-1.
2616 *
2617 cgrad          do k=i+1,j-1
2618 cgrad            do l=1,3
2619 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2620 cgrad            enddo
2621 cgrad          enddo
2622           endif ! calc_grad
2623 #else
2624 C MARYSIA
2625           facvdw=(ev1+evdwij)*sss
2626           facel=(el1+eesij)
2627           fac1=fac
2628           fac=-3*rrmij*(facvdw+facvdw+facel)
2629           erij(1)=xj*rmij
2630           erij(2)=yj*rmij
2631           erij(3)=zj*rmij
2632 *
2633 * Radial derivatives. First process both termini of the fragment (i,j)
2634 *
2635           if (calc_grad) then
2636           ggg(1)=fac*xj
2637 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2638           ggg(2)=fac*yj
2639 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2640           ggg(3)=fac*zj
2641 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
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           do k=1,3
2649             gelc_long(k,j)=gelc(k,j)+ggg(k)
2650             gelc_long(k,i)=gelc(k,i)-ggg(k)
2651           enddo
2652 *
2653 * Loop over residues i+1 thru j-1.
2654 *
2655 cgrad          do k=i+1,j-1
2656 cgrad            do l=1,3
2657 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2658 cgrad            enddo
2659 cgrad          enddo
2660 c 9/28/08 AL Gradient compotents will be summed only at the end
2661           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2662           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2663           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2664           do k=1,3
2665             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2666             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2667           enddo
2668           endif ! calc_grad
2669 #endif
2670 *
2671 * Angular part
2672 *
2673           if (calc_grad) then
2674           ecosa=2.0D0*fac3*fac1+fac4
2675           fac4=-3.0D0*fac4
2676           fac3=-6.0D0*fac3
2677           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2678           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2679           do k=1,3
2680             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2681             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2682           enddo
2683 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2684 cd   &          (dcosg(k),k=1,3)
2685           do k=1,3
2686             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2687      &      fac_shield(i)**2*fac_shield(j)**2
2688           enddo
2689 c          do k=1,3
2690 c            ghalf=0.5D0*ggg(k)
2691 c            gelc(k,i)=gelc(k,i)+ghalf
2692 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2693 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2694 c            gelc(k,j)=gelc(k,j)+ghalf
2695 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2696 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2697 c          enddo
2698 cgrad          do k=i+1,j-1
2699 cgrad            do l=1,3
2700 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2701 cgrad            enddo
2702 cgrad          enddo
2703 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2704           do k=1,3
2705             gelc(k,i)=gelc(k,i)
2706      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2707      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2708      &           *fac_shield(i)**2*fac_shield(j)**2
2709             gelc(k,j)=gelc(k,j)
2710      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2711      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2712      &           *fac_shield(i)**2*fac_shield(j)**2
2713             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2714             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2715           enddo
2716 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2717
2718 C MARYSIA
2719 c          endif !sscale
2720           endif ! calc_grad
2721           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2722      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2723      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2724 C
2725 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2726 C   energy of a peptide unit is assumed in the form of a second-order
2727 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2728 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2729 C   are computed for EVERY pair of non-contiguous peptide groups.
2730 C
2731
2732           if (j.lt.nres-1) then
2733             j1=j+1
2734             j2=j-1
2735           else
2736             j1=j-1
2737             j2=j-2
2738           endif
2739           kkk=0
2740           lll=0
2741           do k=1,2
2742             do l=1,2
2743               kkk=kkk+1
2744               muij(kkk)=mu(k,i)*mu(l,j)
2745 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2746 #ifdef NEWCORR
2747              if (calc_grad) then
2748              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2749 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2750              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2751              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2752 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2753              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2754              endif
2755 #endif
2756             enddo
2757           enddo
2758 #ifdef DEBUG
2759           write (iout,*) 'EELEC: i',i,' j',j
2760           write (iout,*) 'j',j,' j1',j1,' j2',j2
2761           write(iout,*) 'muij',muij
2762           write (iout,*) "uy",uy(:,i)
2763           write (iout,*) "uz",uz(:,j)
2764           write (iout,*) "erij",erij
2765 #endif
2766           ury=scalar(uy(1,i),erij)
2767           urz=scalar(uz(1,i),erij)
2768           vry=scalar(uy(1,j),erij)
2769           vrz=scalar(uz(1,j),erij)
2770           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2771           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2772           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2773           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2774           fac=dsqrt(-ael6i)*r3ij
2775           a22=a22*fac
2776           a23=a23*fac
2777           a32=a32*fac
2778           a33=a33*fac
2779 cd          write (iout,'(4i5,4f10.5)')
2780 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2781 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2782 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2783 cd     &      uy(:,j),uz(:,j)
2784 cd          write (iout,'(4f10.5)')
2785 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2786 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2787 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2788 cd           write (iout,'(9f10.5/)')
2789 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2790 C Derivatives of the elements of A in virtual-bond vectors
2791           if (calc_grad) then
2792           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2793           do k=1,3
2794             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2795             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2796             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2797             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2798             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2799             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2800             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2801             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2802             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2803             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2804             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2805             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2806           enddo
2807 C Compute radial contributions to the gradient
2808           facr=-3.0d0*rrmij
2809           a22der=a22*facr
2810           a23der=a23*facr
2811           a32der=a32*facr
2812           a33der=a33*facr
2813           agg(1,1)=a22der*xj
2814           agg(2,1)=a22der*yj
2815           agg(3,1)=a22der*zj
2816           agg(1,2)=a23der*xj
2817           agg(2,2)=a23der*yj
2818           agg(3,2)=a23der*zj
2819           agg(1,3)=a32der*xj
2820           agg(2,3)=a32der*yj
2821           agg(3,3)=a32der*zj
2822           agg(1,4)=a33der*xj
2823           agg(2,4)=a33der*yj
2824           agg(3,4)=a33der*zj
2825 C Add the contributions coming from er
2826           fac3=-3.0d0*fac
2827           do k=1,3
2828             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2829             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2830             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2831             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2832           enddo
2833           do k=1,3
2834 C Derivatives in DC(i)
2835 cgrad            ghalf1=0.5d0*agg(k,1)
2836 cgrad            ghalf2=0.5d0*agg(k,2)
2837 cgrad            ghalf3=0.5d0*agg(k,3)
2838 cgrad            ghalf4=0.5d0*agg(k,4)
2839             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2840      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2841             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2842      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2843             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2844      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2845             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2846      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2847 C Derivatives in DC(i+1)
2848             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2849      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2850             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2851      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2852             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2853      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2854             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2855      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2856 C Derivatives in DC(j)
2857             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2858      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2859             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2860      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2861             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2862      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2863             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2864      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2865 C Derivatives in DC(j+1) or DC(nres-1)
2866             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2867      &      -3.0d0*vryg(k,3)*ury)
2868             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2869      &      -3.0d0*vrzg(k,3)*ury)
2870             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2871      &      -3.0d0*vryg(k,3)*urz)
2872             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2873      &      -3.0d0*vrzg(k,3)*urz)
2874 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2875 cgrad              do l=1,4
2876 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2877 cgrad              enddo
2878 cgrad            endif
2879           enddo
2880           endif ! calc_grad
2881           acipa(1,1)=a22
2882           acipa(1,2)=a23
2883           acipa(2,1)=a32
2884           acipa(2,2)=a33
2885           a22=-a22
2886           a23=-a23
2887           if (calc_grad) then
2888           do l=1,2
2889             do k=1,3
2890               agg(k,l)=-agg(k,l)
2891               aggi(k,l)=-aggi(k,l)
2892               aggi1(k,l)=-aggi1(k,l)
2893               aggj(k,l)=-aggj(k,l)
2894               aggj1(k,l)=-aggj1(k,l)
2895             enddo
2896           enddo
2897           endif ! calc_grad
2898           if (j.lt.nres-1) then
2899             a22=-a22
2900             a32=-a32
2901             do l=1,3,2
2902               do k=1,3
2903                 agg(k,l)=-agg(k,l)
2904                 aggi(k,l)=-aggi(k,l)
2905                 aggi1(k,l)=-aggi1(k,l)
2906                 aggj(k,l)=-aggj(k,l)
2907                 aggj1(k,l)=-aggj1(k,l)
2908               enddo
2909             enddo
2910           else
2911             a22=-a22
2912             a23=-a23
2913             a32=-a32
2914             a33=-a33
2915             do l=1,4
2916               do k=1,3
2917                 agg(k,l)=-agg(k,l)
2918                 aggi(k,l)=-aggi(k,l)
2919                 aggi1(k,l)=-aggi1(k,l)
2920                 aggj(k,l)=-aggj(k,l)
2921                 aggj1(k,l)=-aggj1(k,l)
2922               enddo
2923             enddo
2924           endif
2925           ENDIF ! WCORR
2926           IF (wel_loc.gt.0.0d0) THEN
2927 C Contribution to the local-electrostatic energy coming from the i-j pair
2928           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2929      &     +a33*muij(4)
2930 #ifdef DEBUG
2931           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2932      &     " a33",a33
2933           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2934      &     " wel_loc",wel_loc
2935 #endif
2936           if (shield_mode.eq.0) then
2937            fac_shield(i)=1.0
2938            fac_shield(j)=1.0
2939 C          else
2940 C           fac_shield(i)=0.4
2941 C           fac_shield(j)=0.6
2942           endif
2943           eel_loc_ij=eel_loc_ij
2944      &    *fac_shield(i)*fac_shield(j)
2945           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2946      &            'eelloc',i,j,eel_loc_ij
2947 c           if (eel_loc_ij.ne.0)
2948 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2949 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2950
2951           eel_loc=eel_loc+eel_loc_ij
2952 C Now derivative over eel_loc
2953           if (calc_grad) then
2954           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2955      &  (shield_mode.gt.0)) then
2956 C          print *,i,j
2957
2958           do ilist=1,ishield_list(i)
2959            iresshield=shield_list(ilist,i)
2960            do k=1,3
2961            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2962      &                                          /fac_shield(i)
2963 C     &      *2.0
2964            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2965      &              rlocshield
2966      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2967             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2968      &      +rlocshield
2969            enddo
2970           enddo
2971           do ilist=1,ishield_list(j)
2972            iresshield=shield_list(ilist,j)
2973            do k=1,3
2974            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2975      &                                       /fac_shield(j)
2976 C     &     *2.0
2977            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2978      &              rlocshield
2979      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2980            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2981      &             +rlocshield
2982
2983            enddo
2984           enddo
2985
2986           do k=1,3
2987             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2988      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2989             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2990      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2991             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2992      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2993             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2994      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2995            enddo
2996            endif
2997
2998
2999 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3000 c     &                     ' eel_loc_ij',eel_loc_ij
3001 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3002 C Calculate patrial derivative for theta angle
3003 #ifdef NEWCORR
3004          geel_loc_ij=(a22*gmuij1(1)
3005      &     +a23*gmuij1(2)
3006      &     +a32*gmuij1(3)
3007      &     +a33*gmuij1(4))
3008      &    *fac_shield(i)*fac_shield(j)
3009 c         write(iout,*) "derivative over thatai"
3010 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3011 c     &   a33*gmuij1(4)
3012          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3013      &      geel_loc_ij*wel_loc
3014 c         write(iout,*) "derivative over thatai-1"
3015 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3016 c     &   a33*gmuij2(4)
3017          geel_loc_ij=
3018      &     a22*gmuij2(1)
3019      &     +a23*gmuij2(2)
3020      &     +a32*gmuij2(3)
3021      &     +a33*gmuij2(4)
3022          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3023      &      geel_loc_ij*wel_loc
3024      &    *fac_shield(i)*fac_shield(j)
3025
3026 c  Derivative over j residue
3027          geel_loc_ji=a22*gmuji1(1)
3028      &     +a23*gmuji1(2)
3029      &     +a32*gmuji1(3)
3030      &     +a33*gmuji1(4)
3031 c         write(iout,*) "derivative over thataj"
3032 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3033 c     &   a33*gmuji1(4)
3034
3035         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3036      &      geel_loc_ji*wel_loc
3037      &    *fac_shield(i)*fac_shield(j)
3038
3039          geel_loc_ji=
3040      &     +a22*gmuji2(1)
3041      &     +a23*gmuji2(2)
3042      &     +a32*gmuji2(3)
3043      &     +a33*gmuji2(4)
3044 c         write(iout,*) "derivative over thataj-1"
3045 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3046 c     &   a33*gmuji2(4)
3047          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3048      &      geel_loc_ji*wel_loc
3049      &    *fac_shield(i)*fac_shield(j)
3050 #endif
3051 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3052
3053 C Partial derivatives in virtual-bond dihedral angles gamma
3054           if (i.gt.1)
3055      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3056      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3057      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3058      &    *fac_shield(i)*fac_shield(j)
3059
3060           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3061      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3062      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3063      &    *fac_shield(i)*fac_shield(j)
3064 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3065           do l=1,3
3066             ggg(l)=(agg(l,1)*muij(1)+
3067      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3068      &    *fac_shield(i)*fac_shield(j)
3069             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3070             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3071 cgrad            ghalf=0.5d0*ggg(l)
3072 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3073 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3074           enddo
3075 cgrad          do k=i+1,j2
3076 cgrad            do l=1,3
3077 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3078 cgrad            enddo
3079 cgrad          enddo
3080 C Remaining derivatives of eello
3081           do l=1,3
3082             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3083      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3084      &    *fac_shield(i)*fac_shield(j)
3085
3086             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3087      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3088      &    *fac_shield(i)*fac_shield(j)
3089
3090             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3091      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3092      &    *fac_shield(i)*fac_shield(j)
3093
3094             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3095      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3096      &    *fac_shield(i)*fac_shield(j)
3097
3098           enddo
3099           endif ! calc_grad
3100           ENDIF
3101
3102
3103 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3104 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3105           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3106      &       .and. num_conti.le.maxconts) then
3107 c            write (iout,*) i,j," entered corr"
3108 C
3109 C Calculate the contact function. The ith column of the array JCONT will
3110 C contain the numbers of atoms that make contacts with the atom I (of numbers
3111 C greater than I). The arrays FACONT and GACONT will contain the values of
3112 C the contact function and its derivative.
3113 c           r0ij=1.02D0*rpp(iteli,itelj)
3114 c           r0ij=1.11D0*rpp(iteli,itelj)
3115             r0ij=2.20D0*rpp(iteli,itelj)
3116 c           r0ij=1.55D0*rpp(iteli,itelj)
3117             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3118             if (fcont.gt.0.0D0) then
3119               num_conti=num_conti+1
3120               if (num_conti.gt.maxconts) then
3121                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3122      &                         ' will skip next contacts for this conf.'
3123               else
3124                 jcont_hb(num_conti,i)=j
3125 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3126 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3127                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3128      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3129 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3130 C  terms.
3131                 d_cont(num_conti,i)=rij
3132 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3133 C     --- Electrostatic-interaction matrix ---
3134                 a_chuj(1,1,num_conti,i)=a22
3135                 a_chuj(1,2,num_conti,i)=a23
3136                 a_chuj(2,1,num_conti,i)=a32
3137                 a_chuj(2,2,num_conti,i)=a33
3138 C     --- Gradient of rij
3139                 if (calc_grad) then
3140                 do kkk=1,3
3141                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3142                 enddo
3143                 kkll=0
3144                 do k=1,2
3145                   do l=1,2
3146                     kkll=kkll+1
3147                     do m=1,3
3148                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3149                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3150                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3151                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3152                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3153                     enddo
3154                   enddo
3155                 enddo
3156                 endif ! calc_grad
3157                 ENDIF
3158                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3159 C Calculate contact energies
3160                 cosa4=4.0D0*cosa
3161                 wij=cosa-3.0D0*cosb*cosg
3162                 cosbg1=cosb+cosg
3163                 cosbg2=cosb-cosg
3164 c               fac3=dsqrt(-ael6i)/r0ij**3
3165                 fac3=dsqrt(-ael6i)*r3ij
3166 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3167                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3168                 if (ees0tmp.gt.0) then
3169                   ees0pij=dsqrt(ees0tmp)
3170                 else
3171                   ees0pij=0
3172                 endif
3173 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3174                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3175                 if (ees0tmp.gt.0) then
3176                   ees0mij=dsqrt(ees0tmp)
3177                 else
3178                   ees0mij=0
3179                 endif
3180 c               ees0mij=0.0D0
3181                 if (shield_mode.eq.0) then
3182                 fac_shield(i)=1.0d0
3183                 fac_shield(j)=1.0d0
3184                 else
3185                 ees0plist(num_conti,i)=j
3186 C                fac_shield(i)=0.4d0
3187 C                fac_shield(j)=0.6d0
3188                 endif
3189                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3190      &          *fac_shield(i)*fac_shield(j)
3191                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3192      &          *fac_shield(i)*fac_shield(j)
3193 C Diagnostics. Comment out or remove after debugging!
3194 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3195 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3196 c               ees0m(num_conti,i)=0.0D0
3197 C End diagnostics.
3198 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3199 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3200 C Angular derivatives of the contact function
3201
3202                 ees0pij1=fac3/ees0pij
3203                 ees0mij1=fac3/ees0mij
3204                 fac3p=-3.0D0*fac3*rrmij
3205                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3206                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3207 c               ees0mij1=0.0D0
3208                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3209                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3210                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3211                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3212                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3213                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3214                 ecosap=ecosa1+ecosa2
3215                 ecosbp=ecosb1+ecosb2
3216                 ecosgp=ecosg1+ecosg2
3217                 ecosam=ecosa1-ecosa2
3218                 ecosbm=ecosb1-ecosb2
3219                 ecosgm=ecosg1-ecosg2
3220 C Diagnostics
3221 c               ecosap=ecosa1
3222 c               ecosbp=ecosb1
3223 c               ecosgp=ecosg1
3224 c               ecosam=0.0D0
3225 c               ecosbm=0.0D0
3226 c               ecosgm=0.0D0
3227 C End diagnostics
3228                 facont_hb(num_conti,i)=fcont
3229
3230                 if (calc_grad) then
3231                 fprimcont=fprimcont/rij
3232 cd              facont_hb(num_conti,i)=1.0D0
3233 C Following line is for diagnostics.
3234 cd              fprimcont=0.0D0
3235                 do k=1,3
3236                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3237                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3238                 enddo
3239                 do k=1,3
3240                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3241                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3242                 enddo
3243                 gggp(1)=gggp(1)+ees0pijp*xj
3244                 gggp(2)=gggp(2)+ees0pijp*yj
3245                 gggp(3)=gggp(3)+ees0pijp*zj
3246                 gggm(1)=gggm(1)+ees0mijp*xj
3247                 gggm(2)=gggm(2)+ees0mijp*yj
3248                 gggm(3)=gggm(3)+ees0mijp*zj
3249 C Derivatives due to the contact function
3250                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3251                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3252                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3253                 do k=1,3
3254 c
3255 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3256 c          following the change of gradient-summation algorithm.
3257 c
3258 cgrad                  ghalfp=0.5D0*gggp(k)
3259 cgrad                  ghalfm=0.5D0*gggm(k)
3260                   gacontp_hb1(k,num_conti,i)=!ghalfp
3261      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3262      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3263      &          *fac_shield(i)*fac_shield(j)
3264
3265                   gacontp_hb2(k,num_conti,i)=!ghalfp
3266      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3267      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3268      &          *fac_shield(i)*fac_shield(j)
3269
3270                   gacontp_hb3(k,num_conti,i)=gggp(k)
3271      &          *fac_shield(i)*fac_shield(j)
3272
3273                   gacontm_hb1(k,num_conti,i)=!ghalfm
3274      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3275      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3276      &          *fac_shield(i)*fac_shield(j)
3277
3278                   gacontm_hb2(k,num_conti,i)=!ghalfm
3279      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3280      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3281      &          *fac_shield(i)*fac_shield(j)
3282
3283                   gacontm_hb3(k,num_conti,i)=gggm(k)
3284      &          *fac_shield(i)*fac_shield(j)
3285
3286                 enddo
3287 C Diagnostics. Comment out or remove after debugging!
3288 cdiag           do k=1,3
3289 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3290 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3291 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3292 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3293 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3294 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3295 cdiag           enddo
3296
3297                  endif ! calc_grad
3298
3299               ENDIF ! wcorr
3300               endif  ! num_conti.le.maxconts
3301             endif  ! fcont.gt.0
3302           endif    ! j.gt.i+1
3303           if (calc_grad) then
3304           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3305             do k=1,4
3306               do l=1,3
3307                 ghalf=0.5d0*agg(l,k)
3308                 aggi(l,k)=aggi(l,k)+ghalf
3309                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3310                 aggj(l,k)=aggj(l,k)+ghalf
3311               enddo
3312             enddo
3313             if (j.eq.nres-1 .and. i.lt.j-2) then
3314               do k=1,4
3315                 do l=1,3
3316                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3317                 enddo
3318               enddo
3319             endif
3320           endif
3321           endif ! calc_grad
3322 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3323       return
3324       end
3325 C-----------------------------------------------------------------------------
3326       subroutine eturn3(i,eello_turn3)
3327 C Third- and fourth-order contributions from turns
3328       implicit real*8 (a-h,o-z)
3329       include 'DIMENSIONS'
3330       include 'COMMON.IOUNITS'
3331       include 'COMMON.GEO'
3332       include 'COMMON.VAR'
3333       include 'COMMON.LOCAL'
3334       include 'COMMON.CHAIN'
3335       include 'COMMON.DERIV'
3336       include 'COMMON.INTERACT'
3337       include 'COMMON.CONTACTS'
3338       include 'COMMON.TORSION'
3339       include 'COMMON.VECTORS'
3340       include 'COMMON.FFIELD'
3341       include 'COMMON.CONTROL'
3342       include 'COMMON.SHIELD'
3343       dimension ggg(3)
3344       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3345      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3346      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3347      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3348      &  auxgmat2(2,2),auxgmatt2(2,2)
3349       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3350      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3351       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3352      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3353      &    num_conti,j1,j2
3354       j=i+2
3355 c      write (iout,*) "eturn3",i,j,j1,j2
3356       a_temp(1,1)=a22
3357       a_temp(1,2)=a23
3358       a_temp(2,1)=a32
3359       a_temp(2,2)=a33
3360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3361 C
3362 C               Third-order contributions
3363 C
3364 C                 (i+2)o----(i+3)
3365 C                      | |
3366 C                      | |
3367 C                 (i+1)o----i
3368 C
3369 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3370 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3371         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3372 c auxalary matices for theta gradient
3373 c auxalary matrix for i+1 and constant i+2
3374         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3375 c auxalary matrix for i+2 and constant i+1
3376         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3377         call transpose2(auxmat(1,1),auxmat1(1,1))
3378         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3379         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3380         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3381         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3382         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3383         if (shield_mode.eq.0) then
3384         fac_shield(i)=1.0
3385         fac_shield(j)=1.0
3386 C        else
3387 C        fac_shield(i)=0.4
3388 C        fac_shield(j)=0.6
3389         endif
3390         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3391      &  *fac_shield(i)*fac_shield(j)
3392         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3393      &  *fac_shield(i)*fac_shield(j)
3394         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3395      &    eello_t3
3396         if (calc_grad) then
3397 C#ifdef NEWCORR
3398 C Derivatives in theta
3399         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3400      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3401      &   *fac_shield(i)*fac_shield(j)
3402         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3403      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3404      &   *fac_shield(i)*fac_shield(j)
3405 C#endif
3406
3407 C Derivatives in shield mode
3408           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3409      &  (shield_mode.gt.0)) then
3410 C          print *,i,j
3411
3412           do ilist=1,ishield_list(i)
3413            iresshield=shield_list(ilist,i)
3414            do k=1,3
3415            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3416 C     &      *2.0
3417            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3418      &              rlocshield
3419      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3420             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3421      &      +rlocshield
3422            enddo
3423           enddo
3424           do ilist=1,ishield_list(j)
3425            iresshield=shield_list(ilist,j)
3426            do k=1,3
3427            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3428 C     &     *2.0
3429            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3430      &              rlocshield
3431      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3432            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3433      &             +rlocshield
3434
3435            enddo
3436           enddo
3437
3438           do k=1,3
3439             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3440      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3441             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3442      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3443             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3444      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3445             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3446      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3447            enddo
3448            endif
3449
3450 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3451 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3452 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3453 cd     &    ' eello_turn3_num',4*eello_turn3_num
3454 C Derivatives in gamma(i)
3455         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3456         call transpose2(auxmat2(1,1),auxmat3(1,1))
3457         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3458         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3459      &   *fac_shield(i)*fac_shield(j)
3460 C Derivatives in gamma(i+1)
3461         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3462         call transpose2(auxmat2(1,1),auxmat3(1,1))
3463         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3464         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3465      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3466      &   *fac_shield(i)*fac_shield(j)
3467 C Cartesian derivatives
3468         do l=1,3
3469 c            ghalf1=0.5d0*agg(l,1)
3470 c            ghalf2=0.5d0*agg(l,2)
3471 c            ghalf3=0.5d0*agg(l,3)
3472 c            ghalf4=0.5d0*agg(l,4)
3473           a_temp(1,1)=aggi(l,1)!+ghalf1
3474           a_temp(1,2)=aggi(l,2)!+ghalf2
3475           a_temp(2,1)=aggi(l,3)!+ghalf3
3476           a_temp(2,2)=aggi(l,4)!+ghalf4
3477           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3478           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3479      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3480      &   *fac_shield(i)*fac_shield(j)
3481
3482           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3483           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3484           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3485           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3486           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3487           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3488      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3489      &   *fac_shield(i)*fac_shield(j)
3490           a_temp(1,1)=aggj(l,1)!+ghalf1
3491           a_temp(1,2)=aggj(l,2)!+ghalf2
3492           a_temp(2,1)=aggj(l,3)!+ghalf3
3493           a_temp(2,2)=aggj(l,4)!+ghalf4
3494           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3495           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3496      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3497      &   *fac_shield(i)*fac_shield(j)
3498           a_temp(1,1)=aggj1(l,1)
3499           a_temp(1,2)=aggj1(l,2)
3500           a_temp(2,1)=aggj1(l,3)
3501           a_temp(2,2)=aggj1(l,4)
3502           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3503           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3504      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3505      &   *fac_shield(i)*fac_shield(j)
3506         enddo
3507
3508         endif ! calc_grad
3509
3510       return
3511       end
3512 C-------------------------------------------------------------------------------
3513       subroutine eturn4(i,eello_turn4)
3514 C Third- and fourth-order contributions from turns
3515       implicit real*8 (a-h,o-z)
3516       include 'DIMENSIONS'
3517       include 'COMMON.IOUNITS'
3518       include 'COMMON.GEO'
3519       include 'COMMON.VAR'
3520       include 'COMMON.LOCAL'
3521       include 'COMMON.CHAIN'
3522       include 'COMMON.DERIV'
3523       include 'COMMON.INTERACT'
3524       include 'COMMON.CONTACTS'
3525       include 'COMMON.TORSION'
3526       include 'COMMON.VECTORS'
3527       include 'COMMON.FFIELD'
3528       include 'COMMON.CONTROL'
3529       include 'COMMON.SHIELD'
3530       dimension ggg(3)
3531       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3532      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3533      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3534      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3535      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3536      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3537      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3538       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3539      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3540       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3541      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3542      &    num_conti,j1,j2
3543       j=i+3
3544 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3545 C
3546 C               Fourth-order contributions
3547 C
3548 C                 (i+3)o----(i+4)
3549 C                     /  |
3550 C               (i+2)o   |
3551 C                     \  |
3552 C                 (i+1)o----i
3553 C
3554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3555 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3556 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3557 c        write(iout,*)"WCHODZE W PROGRAM"
3558         a_temp(1,1)=a22
3559         a_temp(1,2)=a23
3560         a_temp(2,1)=a32
3561         a_temp(2,2)=a33
3562         iti1=itype2loc(itype(i+1))
3563         iti2=itype2loc(itype(i+2))
3564         iti3=itype2loc(itype(i+3))
3565 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3566         call transpose2(EUg(1,1,i+1),e1t(1,1))
3567         call transpose2(Eug(1,1,i+2),e2t(1,1))
3568         call transpose2(Eug(1,1,i+3),e3t(1,1))
3569 C Ematrix derivative in theta
3570         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3571         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3572         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3573         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3574 c       eta1 in derivative theta
3575         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3576         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3577 c       auxgvec is derivative of Ub2 so i+3 theta
3578         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3579 c       auxalary matrix of E i+1
3580         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3581 c        s1=0.0
3582 c        gs1=0.0
3583         s1=scalar2(b1(1,i+2),auxvec(1))
3584 c derivative of theta i+2 with constant i+3
3585         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3586 c derivative of theta i+2 with constant i+2
3587         gs32=scalar2(b1(1,i+2),auxgvec(1))
3588 c derivative of E matix in theta of i+1
3589         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3590
3591         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3592 c       ea31 in derivative theta
3593         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3594         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3595 c auxilary matrix auxgvec of Ub2 with constant E matirx
3596         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3597 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3598         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3599
3600 c        s2=0.0
3601 c        gs2=0.0
3602         s2=scalar2(b1(1,i+1),auxvec(1))
3603 c derivative of theta i+1 with constant i+3
3604         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3605 c derivative of theta i+2 with constant i+1
3606         gs21=scalar2(b1(1,i+1),auxgvec(1))
3607 c derivative of theta i+3 with constant i+1
3608         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3609 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3610 c     &  gtb1(1,i+1)
3611         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3612 c two derivatives over diffetent matrices
3613 c gtae3e2 is derivative over i+3
3614         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3615 c ae3gte2 is derivative over i+2
3616         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3617         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3618 c three possible derivative over theta E matices
3619 c i+1
3620         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3621 c i+2
3622         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3623 c i+3
3624         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3625         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3626
3627         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3628         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3629         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3630         if (shield_mode.eq.0) then
3631         fac_shield(i)=1.0
3632         fac_shield(j)=1.0
3633 C        else
3634 C        fac_shield(i)=0.6
3635 C        fac_shield(j)=0.4
3636         endif
3637         eello_turn4=eello_turn4-(s1+s2+s3)
3638      &  *fac_shield(i)*fac_shield(j)
3639         eello_t4=-(s1+s2+s3)
3640      &  *fac_shield(i)*fac_shield(j)
3641 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3642         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3643      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3644 C Now derivative over shield:
3645           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3646      &  (shield_mode.gt.0)) then
3647 C          print *,i,j
3648
3649           do ilist=1,ishield_list(i)
3650            iresshield=shield_list(ilist,i)
3651            do k=1,3
3652            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3653 C     &      *2.0
3654            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3655      &              rlocshield
3656      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3657             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3658      &      +rlocshield
3659            enddo
3660           enddo
3661           do ilist=1,ishield_list(j)
3662            iresshield=shield_list(ilist,j)
3663            do k=1,3
3664            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3665 C     &     *2.0
3666            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3667      &              rlocshield
3668      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3669            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3670      &             +rlocshield
3671
3672            enddo
3673           enddo
3674
3675           do k=1,3
3676             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3677      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3678             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3679      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3680             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3681      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3682             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3683      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3684            enddo
3685            endif
3686 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3687 cd     &    ' eello_turn4_num',8*eello_turn4_num
3688 #ifdef NEWCORR
3689         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3690      &                  -(gs13+gsE13+gsEE1)*wturn4
3691      &  *fac_shield(i)*fac_shield(j)
3692         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3693      &                    -(gs23+gs21+gsEE2)*wturn4
3694      &  *fac_shield(i)*fac_shield(j)
3695
3696         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3697      &                    -(gs32+gsE31+gsEE3)*wturn4
3698      &  *fac_shield(i)*fac_shield(j)
3699
3700 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3701 c     &   gs2
3702 #endif
3703         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3704      &      'eturn4',i,j,-(s1+s2+s3)
3705 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3706 c     &    ' eello_turn4_num',8*eello_turn4_num
3707 C Derivatives in gamma(i)
3708         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3709         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3710         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3711         s1=scalar2(b1(1,i+2),auxvec(1))
3712         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3715      &  *fac_shield(i)*fac_shield(j)
3716 C Derivatives in gamma(i+1)
3717         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3718         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3719         s2=scalar2(b1(1,i+1),auxvec(1))
3720         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3721         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3722         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3723         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3724      &  *fac_shield(i)*fac_shield(j)
3725 C Derivatives in gamma(i+2)
3726         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3727         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3728         s1=scalar2(b1(1,i+2),auxvec(1))
3729         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3730         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3731         s2=scalar2(b1(1,i+1),auxvec(1))
3732         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3733         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3734         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3735         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3736      &  *fac_shield(i)*fac_shield(j)
3737         if (calc_grad) then
3738 C Cartesian derivatives
3739 C Derivatives of this turn contributions in DC(i+2)
3740         if (j.lt.nres-1) then
3741           do l=1,3
3742             a_temp(1,1)=agg(l,1)
3743             a_temp(1,2)=agg(l,2)
3744             a_temp(2,1)=agg(l,3)
3745             a_temp(2,2)=agg(l,4)
3746             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3747             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3748             s1=scalar2(b1(1,i+2),auxvec(1))
3749             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3750             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3751             s2=scalar2(b1(1,i+1),auxvec(1))
3752             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3753             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3754             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3755             ggg(l)=-(s1+s2+s3)
3756             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3757      &  *fac_shield(i)*fac_shield(j)
3758           enddo
3759         endif
3760 C Remaining derivatives of this turn contribution
3761         do l=1,3
3762           a_temp(1,1)=aggi(l,1)
3763           a_temp(1,2)=aggi(l,2)
3764           a_temp(2,1)=aggi(l,3)
3765           a_temp(2,2)=aggi(l,4)
3766           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3767           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3768           s1=scalar2(b1(1,i+2),auxvec(1))
3769           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3770           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3771           s2=scalar2(b1(1,i+1),auxvec(1))
3772           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3773           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3774           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3775           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3776      &  *fac_shield(i)*fac_shield(j)
3777           a_temp(1,1)=aggi1(l,1)
3778           a_temp(1,2)=aggi1(l,2)
3779           a_temp(2,1)=aggi1(l,3)
3780           a_temp(2,2)=aggi1(l,4)
3781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3783           s1=scalar2(b1(1,i+2),auxvec(1))
3784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3786           s2=scalar2(b1(1,i+1),auxvec(1))
3787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3791      &  *fac_shield(i)*fac_shield(j)
3792           a_temp(1,1)=aggj(l,1)
3793           a_temp(1,2)=aggj(l,2)
3794           a_temp(2,1)=aggj(l,3)
3795           a_temp(2,2)=aggj(l,4)
3796           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3797           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3798           s1=scalar2(b1(1,i+2),auxvec(1))
3799           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3800           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3801           s2=scalar2(b1(1,i+1),auxvec(1))
3802           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3803           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3804           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3805           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3806      &  *fac_shield(i)*fac_shield(j)
3807           a_temp(1,1)=aggj1(l,1)
3808           a_temp(1,2)=aggj1(l,2)
3809           a_temp(2,1)=aggj1(l,3)
3810           a_temp(2,2)=aggj1(l,4)
3811           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3812           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3813           s1=scalar2(b1(1,i+2),auxvec(1))
3814           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3815           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3816           s2=scalar2(b1(1,i+1),auxvec(1))
3817           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3818           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3819           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3820 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3821           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3822      &  *fac_shield(i)*fac_shield(j)
3823         enddo
3824
3825         endif ! calc_grad
3826
3827       return
3828       end
3829 C-----------------------------------------------------------------------------
3830       subroutine vecpr(u,v,w)
3831       implicit real*8(a-h,o-z)
3832       dimension u(3),v(3),w(3)
3833       w(1)=u(2)*v(3)-u(3)*v(2)
3834       w(2)=-u(1)*v(3)+u(3)*v(1)
3835       w(3)=u(1)*v(2)-u(2)*v(1)
3836       return
3837       end
3838 C-----------------------------------------------------------------------------
3839       subroutine unormderiv(u,ugrad,unorm,ungrad)
3840 C This subroutine computes the derivatives of a normalized vector u, given
3841 C the derivatives computed without normalization conditions, ugrad. Returns
3842 C ungrad.
3843       implicit none
3844       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3845       double precision vec(3)
3846       double precision scalar
3847       integer i,j
3848 c      write (2,*) 'ugrad',ugrad
3849 c      write (2,*) 'u',u
3850       do i=1,3
3851         vec(i)=scalar(ugrad(1,i),u(1))
3852       enddo
3853 c      write (2,*) 'vec',vec
3854       do i=1,3
3855         do j=1,3
3856           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3857         enddo
3858       enddo
3859 c      write (2,*) 'ungrad',ungrad
3860       return
3861       end
3862 C-----------------------------------------------------------------------------
3863       subroutine escp(evdw2,evdw2_14)
3864 C
3865 C This subroutine calculates the excluded-volume interaction energy between
3866 C peptide-group centers and side chains and its gradient in virtual-bond and
3867 C side-chain vectors.
3868 C
3869       implicit real*8 (a-h,o-z)
3870       include 'DIMENSIONS'
3871       include 'COMMON.GEO'
3872       include 'COMMON.VAR'
3873       include 'COMMON.LOCAL'
3874       include 'COMMON.CHAIN'
3875       include 'COMMON.DERIV'
3876       include 'COMMON.INTERACT'
3877       include 'COMMON.FFIELD'
3878       include 'COMMON.IOUNITS'
3879       dimension ggg(3)
3880       evdw2=0.0D0
3881       evdw2_14=0.0d0
3882 cd    print '(a)','Enter ESCP'
3883 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3884 c     &  ' scal14',scal14
3885       do i=iatscp_s,iatscp_e
3886         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3887         iteli=itel(i)
3888 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3889 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3890         if (iteli.eq.0) goto 1225
3891         xi=0.5D0*(c(1,i)+c(1,i+1))
3892         yi=0.5D0*(c(2,i)+c(2,i+1))
3893         zi=0.5D0*(c(3,i)+c(3,i+1))
3894 C Returning the ith atom to box
3895           xi=mod(xi,boxxsize)
3896           if (xi.lt.0) xi=xi+boxxsize
3897           yi=mod(yi,boxysize)
3898           if (yi.lt.0) yi=yi+boxysize
3899           zi=mod(zi,boxzsize)
3900           if (zi.lt.0) zi=zi+boxzsize
3901         do iint=1,nscp_gr(i)
3902
3903         do j=iscpstart(i,iint),iscpend(i,iint)
3904           itypj=iabs(itype(j))
3905           if (itypj.eq.ntyp1) cycle
3906 C Uncomment following three lines for SC-p interactions
3907 c         xj=c(1,nres+j)-xi
3908 c         yj=c(2,nres+j)-yi
3909 c         zj=c(3,nres+j)-zi
3910 C Uncomment following three lines for Ca-p interactions
3911           xj=c(1,j)
3912           yj=c(2,j)
3913           zj=c(3,j)
3914 C returning the jth atom to box
3915           xj=mod(xj,boxxsize)
3916           if (xj.lt.0) xj=xj+boxxsize
3917           yj=mod(yj,boxysize)
3918           if (yj.lt.0) yj=yj+boxysize
3919           zj=mod(zj,boxzsize)
3920           if (zj.lt.0) zj=zj+boxzsize
3921       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3922       xj_safe=xj
3923       yj_safe=yj
3924       zj_safe=zj
3925       subchap=0
3926 C Finding the closest jth atom
3927       do xshift=-1,1
3928       do yshift=-1,1
3929       do zshift=-1,1
3930           xj=xj_safe+xshift*boxxsize
3931           yj=yj_safe+yshift*boxysize
3932           zj=zj_safe+zshift*boxzsize
3933           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3934           if(dist_temp.lt.dist_init) then
3935             dist_init=dist_temp
3936             xj_temp=xj
3937             yj_temp=yj
3938             zj_temp=zj
3939             subchap=1
3940           endif
3941        enddo
3942        enddo
3943        enddo
3944        if (subchap.eq.1) then
3945           xj=xj_temp-xi
3946           yj=yj_temp-yi
3947           zj=zj_temp-zi
3948        else
3949           xj=xj_safe-xi
3950           yj=yj_safe-yi
3951           zj=zj_safe-zi
3952        endif
3953           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3954 C sss is scaling function for smoothing the cutoff gradient otherwise
3955 C the gradient would not be continuouse
3956           sss=sscale(1.0d0/(dsqrt(rrij)))
3957           if (sss.le.0.0d0) cycle
3958           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3959           fac=rrij**expon2
3960           e1=fac*fac*aad(itypj,iteli)
3961           e2=fac*bad(itypj,iteli)
3962           if (iabs(j-i) .le. 2) then
3963             e1=scal14*e1
3964             e2=scal14*e2
3965             evdw2_14=evdw2_14+(e1+e2)*sss
3966           endif
3967           evdwij=e1+e2
3968 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3969 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3970 c     &       bad(itypj,iteli)
3971           evdw2=evdw2+evdwij*sss
3972           if (calc_grad) then
3973 C
3974 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3975 C
3976           fac=-(evdwij+e1)*rrij*sss
3977           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3978           ggg(1)=xj*fac
3979           ggg(2)=yj*fac
3980           ggg(3)=zj*fac
3981           if (j.lt.i) then
3982 cd          write (iout,*) 'j<i'
3983 C Uncomment following three lines for SC-p interactions
3984 c           do k=1,3
3985 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3986 c           enddo
3987           else
3988 cd          write (iout,*) 'j>i'
3989             do k=1,3
3990               ggg(k)=-ggg(k)
3991 C Uncomment following line for SC-p interactions
3992 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3993             enddo
3994           endif
3995           do k=1,3
3996             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3997           enddo
3998           kstart=min0(i+1,j)
3999           kend=max0(i-1,j-1)
4000 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4001 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4002           do k=kstart,kend
4003             do l=1,3
4004               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4005             enddo
4006           enddo
4007           endif ! calc_grad
4008         enddo
4009         enddo ! iint
4010  1225   continue
4011       enddo ! i
4012       do i=1,nct
4013         do j=1,3
4014           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4015           gradx_scp(j,i)=expon*gradx_scp(j,i)
4016         enddo
4017       enddo
4018 C******************************************************************************
4019 C
4020 C                              N O T E !!!
4021 C
4022 C To save time the factor EXPON has been extracted from ALL components
4023 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4024 C use!
4025 C
4026 C******************************************************************************
4027       return
4028       end
4029 C--------------------------------------------------------------------------
4030       subroutine edis(ehpb)
4031 C
4032 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4033 C
4034       implicit real*8 (a-h,o-z)
4035       include 'DIMENSIONS'
4036       include 'COMMON.SBRIDGE'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.VAR'
4040       include 'COMMON.INTERACT'
4041       include 'COMMON.CONTROL'
4042       include 'COMMON.IOUNITS'
4043       dimension ggg(3),ggg_peak(3,1000)
4044       ehpb=0.0D0
4045       ggg=0.0d0
4046 c 8/21/18 AL: added explicit restraints on reference coords
4047 c      write (iout,*) "restr_on_coord",restr_on_coord
4048       if (restr_on_coord) then
4049
4050       do i=nnt,nct
4051         ecoor=0.0d0
4052         if (itype(i).eq.ntyp1) cycle
4053         do j=1,3
4054           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4055           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4056         enddo
4057         if (itype(i).ne.10) then
4058           do j=1,3
4059             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4060             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4061           enddo
4062         endif
4063         if (energy_dec) write (iout,*)
4064      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4065         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4066       enddo
4067
4068       endif
4069 C      write (iout,*) ,"link_end",link_end,constr_dist
4070 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4071 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4072 c     &  " constr_dist",constr_dist
4073       if (link_end.eq.0.and.link_end_peak.eq.0) return
4074       do i=link_start_peak,link_end_peak
4075         ehpb_peak=0.0d0
4076 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4077 c     &   ipeak(1,i),ipeak(2,i)
4078         do ip=ipeak(1,i),ipeak(2,i)
4079           ii=ihpb_peak(ip)
4080           jj=jhpb_peak(ip)
4081           dd=dist(ii,jj)
4082           iip=ip-ipeak(1,i)+1
4083 C iii and jjj point to the residues for which the distance is assigned.
4084 c          if (ii.gt.nres) then
4085 c            iii=ii-nres
4086 c            jjj=jj-nres
4087 c          else
4088 c            iii=ii
4089 c            jjj=jj
4090 c          endif
4091           if (ii.gt.nres) then
4092             iii=ii-nres
4093           else
4094             iii=ii
4095           endif
4096           if (jj.gt.nres) then
4097             jjj=jj-nres
4098           else
4099             jjj=jj
4100           endif
4101           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4102           aux=dexp(-scal_peak*aux)
4103           ehpb_peak=ehpb_peak+aux
4104           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4105      &      forcon_peak(ip))*aux/dd
4106           do j=1,3
4107             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4108           enddo
4109           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4110      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4111      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4112         enddo
4113 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4114         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4115         do ip=ipeak(1,i),ipeak(2,i)
4116           iip=ip-ipeak(1,i)+1
4117           do j=1,3
4118             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4119           enddo
4120           ii=ihpb_peak(ip)
4121           jj=jhpb_peak(ip)
4122 C iii and jjj point to the residues for which the distance is assigned.
4123 c          if (ii.gt.nres) then
4124 c            iii=ii-nres
4125 c            jjj=jj-nres
4126 c          else
4127 c            iii=ii
4128 c            jjj=jj
4129 c          endif
4130           if (ii.gt.nres) then
4131             iii=ii-nres
4132           else
4133             iii=ii
4134           endif
4135           if (jj.gt.nres) then
4136             jjj=jj-nres
4137           else
4138             jjj=jj
4139           endif
4140           if (iii.lt.ii) then
4141             do j=1,3
4142               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4143             enddo
4144           endif
4145           if (jjj.lt.jj) then
4146             do j=1,3
4147               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4148             enddo
4149           endif
4150           do k=1,3
4151             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4152             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4153           enddo
4154         enddo
4155       enddo
4156       do i=link_start,link_end
4157 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4158 C CA-CA distance used in regularization of structure.
4159         ii=ihpb(i)
4160         jj=jhpb(i)
4161 C iii and jjj point to the residues for which the distance is assigned.
4162 c        if (ii.gt.nres) then
4163 c          iii=ii-nres
4164 c          jjj=jj-nres
4165 c        else
4166 c          iii=ii
4167 c          jjj=jj
4168 c        endif
4169         if (ii.gt.nres) then
4170           iii=ii-nres
4171         else
4172           iii=ii
4173         endif
4174         if (jj.gt.nres) then
4175           jjj=jj-nres
4176         else
4177           jjj=jj
4178         endif
4179 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4180 c     &    dhpb(i),dhpb1(i),forcon(i)
4181 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4182 C    distance and angle dependent SS bond potential.
4183 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4184 C     & iabs(itype(jjj)).eq.1) then
4185 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4186 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4187         if (.not.dyn_ss .and. i.le.nss) then
4188 C 15/02/13 CC dynamic SSbond - additional check
4189           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4190      &        iabs(itype(jjj)).eq.1) then
4191            call ssbond_ene(iii,jjj,eij)
4192            ehpb=ehpb+2*eij
4193          endif
4194 cd          write (iout,*) "eij",eij
4195 cd   &   ' waga=',waga,' fac=',fac
4196 !        else if (ii.gt.nres .and. jj.gt.nres) then
4197         else
4198 C Calculate the distance between the two points and its difference from the
4199 C target distance.
4200           dd=dist(ii,jj)
4201           if (irestr_type(i).eq.11) then
4202             ehpb=ehpb+fordepth(i)!**4.0d0
4203      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4204             fac=fordepth(i)!**4.0d0
4205      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4206             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4207      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4208      &        ehpb,irestr_type(i)
4209           else if (irestr_type(i).eq.10) then
4210 c AL 6//19/2018 cross-link restraints
4211             xdis = 0.5d0*(dd/forcon(i))**2
4212             expdis = dexp(-xdis)
4213 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4214             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4215 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4216 c     &          " wboltzd",wboltzd
4217             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4218 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4219             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4220      &           *expdis/(aux*forcon(i)**2)
4221             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4222      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4223      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4224           else if (irestr_type(i).eq.2) then
4225 c Quartic restraints
4226             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4227             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4228      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4229      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4230             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4231           else
4232 c Quadratic restraints
4233             rdis=dd-dhpb(i)
4234 C Get the force constant corresponding to this distance.
4235             waga=forcon(i)
4236 C Calculate the contribution to energy.
4237             ehpb=ehpb+0.5d0*waga*rdis*rdis
4238             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4239      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4240      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4241 C
4242 C Evaluate gradient.
4243 C
4244             fac=waga*rdis/dd
4245           endif
4246 c Calculate Cartesian gradient
4247           do j=1,3
4248             ggg(j)=fac*(c(j,jj)-c(j,ii))
4249           enddo
4250 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4251 C If this is a SC-SC distance, we need to calculate the contributions to the
4252 C Cartesian gradient in the SC vectors (ghpbx).
4253           if (iii.lt.ii) then
4254             do j=1,3
4255               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4256             enddo
4257           endif
4258           if (jjj.lt.jj) then
4259             do j=1,3
4260               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4261             enddo
4262           endif
4263           do k=1,3
4264             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4265             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4266           enddo
4267         endif
4268       enddo
4269       return
4270       end
4271 C--------------------------------------------------------------------------
4272       subroutine ssbond_ene(i,j,eij)
4273 C
4274 C Calculate the distance and angle dependent SS-bond potential energy
4275 C using a free-energy function derived based on RHF/6-31G** ab initio
4276 C calculations of diethyl disulfide.
4277 C
4278 C A. Liwo and U. Kozlowska, 11/24/03
4279 C
4280       implicit real*8 (a-h,o-z)
4281       include 'DIMENSIONS'
4282       include 'COMMON.SBRIDGE'
4283       include 'COMMON.CHAIN'
4284       include 'COMMON.DERIV'
4285       include 'COMMON.LOCAL'
4286       include 'COMMON.INTERACT'
4287       include 'COMMON.VAR'
4288       include 'COMMON.IOUNITS'
4289       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4290       itypi=iabs(itype(i))
4291       xi=c(1,nres+i)
4292       yi=c(2,nres+i)
4293       zi=c(3,nres+i)
4294       dxi=dc_norm(1,nres+i)
4295       dyi=dc_norm(2,nres+i)
4296       dzi=dc_norm(3,nres+i)
4297       dsci_inv=dsc_inv(itypi)
4298       itypj=iabs(itype(j))
4299       dscj_inv=dsc_inv(itypj)
4300       xj=c(1,nres+j)-xi
4301       yj=c(2,nres+j)-yi
4302       zj=c(3,nres+j)-zi
4303       dxj=dc_norm(1,nres+j)
4304       dyj=dc_norm(2,nres+j)
4305       dzj=dc_norm(3,nres+j)
4306       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4307       rij=dsqrt(rrij)
4308       erij(1)=xj*rij
4309       erij(2)=yj*rij
4310       erij(3)=zj*rij
4311       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4312       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4313       om12=dxi*dxj+dyi*dyj+dzi*dzj
4314       do k=1,3
4315         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4316         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4317       enddo
4318       rij=1.0d0/rij
4319       deltad=rij-d0cm
4320       deltat1=1.0d0-om1
4321       deltat2=1.0d0+om2
4322       deltat12=om2-om1+2.0d0
4323       cosphi=om12-om1*om2
4324       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4325      &  +akct*deltad*deltat12
4326      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4327 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4328 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4329 c     &  " deltat12",deltat12," eij",eij
4330       ed=2*akcm*deltad+akct*deltat12
4331       pom1=akct*deltad
4332       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4333       eom1=-2*akth*deltat1-pom1-om2*pom2
4334       eom2= 2*akth*deltat2+pom1-om1*pom2
4335       eom12=pom2
4336       do k=1,3
4337         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4338       enddo
4339       do k=1,3
4340         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4341      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4342         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4343      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4344       enddo
4345 C
4346 C Calculate the components of the gradient in DC and X
4347 C
4348       do k=i,j-1
4349         do l=1,3
4350           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4351         enddo
4352       enddo
4353       return
4354       end
4355 C--------------------------------------------------------------------------
4356       subroutine ebond(estr)
4357 c
4358 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4359 c
4360       implicit real*8 (a-h,o-z)
4361       include 'DIMENSIONS'
4362       include 'COMMON.LOCAL'
4363       include 'COMMON.GEO'
4364       include 'COMMON.INTERACT'
4365       include 'COMMON.DERIV'
4366       include 'COMMON.VAR'
4367       include 'COMMON.CHAIN'
4368       include 'COMMON.IOUNITS'
4369       include 'COMMON.NAMES'
4370       include 'COMMON.FFIELD'
4371       include 'COMMON.CONTROL'
4372       double precision u(3),ud(3)
4373       estr=0.0d0
4374       estr1=0.0d0
4375 c      write (iout,*) "distchainmax",distchainmax
4376       do i=nnt+1,nct
4377         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4378 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4379 C          do j=1,3
4380 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4381 C     &      *dc(j,i-1)/vbld(i)
4382 C          enddo
4383 C          if (energy_dec) write(iout,*)
4384 C     &       "estr1",i,vbld(i),distchainmax,
4385 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4386 C        else
4387          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4388         diff = vbld(i)-vbldpDUM
4389 C         write(iout,*) i,diff
4390          else
4391           diff = vbld(i)-vbldp0
4392 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4393          endif
4394           estr=estr+diff*diff
4395           do j=1,3
4396             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4397           enddo
4398 C        endif
4399 C        write (iout,'(a7,i5,4f7.3)')
4400 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4401       enddo
4402       estr=0.5d0*AKP*estr+estr1
4403 c
4404 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4405 c
4406       do i=nnt,nct
4407         iti=iabs(itype(i))
4408         if (iti.ne.10 .and. iti.ne.ntyp1) then
4409           nbi=nbondterm(iti)
4410           if (nbi.eq.1) then
4411             diff=vbld(i+nres)-vbldsc0(1,iti)
4412 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4413 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4414             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4415             do j=1,3
4416               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4417             enddo
4418           else
4419             do j=1,nbi
4420               diff=vbld(i+nres)-vbldsc0(j,iti)
4421               ud(j)=aksc(j,iti)*diff
4422               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4423             enddo
4424             uprod=u(1)
4425             do j=2,nbi
4426               uprod=uprod*u(j)
4427             enddo
4428             usum=0.0d0
4429             usumsqder=0.0d0
4430             do j=1,nbi
4431               uprod1=1.0d0
4432               uprod2=1.0d0
4433               do k=1,nbi
4434                 if (k.ne.j) then
4435                   uprod1=uprod1*u(k)
4436                   uprod2=uprod2*u(k)*u(k)
4437                 endif
4438               enddo
4439               usum=usum+uprod1
4440               usumsqder=usumsqder+ud(j)*uprod2
4441             enddo
4442 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4443 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4444             estr=estr+uprod/usum
4445             do j=1,3
4446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4447             enddo
4448           endif
4449         endif
4450       enddo
4451       return
4452       end
4453 #ifdef CRYST_THETA
4454 C--------------------------------------------------------------------------
4455       subroutine ebend(etheta,ethetacnstr)
4456 C
4457 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4458 C angles gamma and its derivatives in consecutive thetas and gammas.
4459 C
4460       implicit real*8 (a-h,o-z)
4461       include 'DIMENSIONS'
4462       include 'COMMON.LOCAL'
4463       include 'COMMON.GEO'
4464       include 'COMMON.INTERACT'
4465       include 'COMMON.DERIV'
4466       include 'COMMON.VAR'
4467       include 'COMMON.CHAIN'
4468       include 'COMMON.IOUNITS'
4469       include 'COMMON.NAMES'
4470       include 'COMMON.FFIELD'
4471       include 'COMMON.TORCNSTR'
4472       common /calcthet/ term1,term2,termm,diffak,ratak,
4473      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4474      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4475       double precision y(2),z(2)
4476       delta=0.02d0*pi
4477 c      time11=dexp(-2*time)
4478 c      time12=1.0d0
4479       etheta=0.0D0
4480 c      write (iout,*) "nres",nres
4481 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4482 c      write (iout,*) ithet_start,ithet_end
4483       do i=ithet_start,ithet_end
4484 C        if (itype(i-1).eq.ntyp1) cycle
4485         if (i.le.2) cycle
4486         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4487      &  .or.itype(i).eq.ntyp1) cycle
4488 C Zero the energy function and its derivative at 0 or pi.
4489         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4490         it=itype(i-1)
4491         ichir1=isign(1,itype(i-2))
4492         ichir2=isign(1,itype(i))
4493          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4494          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4495          if (itype(i-1).eq.10) then
4496           itype1=isign(10,itype(i-2))
4497           ichir11=isign(1,itype(i-2))
4498           ichir12=isign(1,itype(i-2))
4499           itype2=isign(10,itype(i))
4500           ichir21=isign(1,itype(i))
4501           ichir22=isign(1,itype(i))
4502          endif
4503          if (i.eq.3) then
4504           y(1)=0.0D0
4505           y(2)=0.0D0
4506           else
4507
4508         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4509 #ifdef OSF
4510           phii=phi(i)
4511 c          icrc=0
4512 c          call proc_proc(phii,icrc)
4513           if (icrc.eq.1) phii=150.0
4514 #else
4515           phii=phi(i)
4516 #endif
4517           y(1)=dcos(phii)
4518           y(2)=dsin(phii)
4519         else
4520           y(1)=0.0D0
4521           y(2)=0.0D0
4522         endif
4523         endif
4524         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4525 #ifdef OSF
4526           phii1=phi(i+1)
4527 c          icrc=0
4528 c          call proc_proc(phii1,icrc)
4529           if (icrc.eq.1) phii1=150.0
4530           phii1=pinorm(phii1)
4531           z(1)=cos(phii1)
4532 #else
4533           phii1=phi(i+1)
4534           z(1)=dcos(phii1)
4535 #endif
4536           z(2)=dsin(phii1)
4537         else
4538           z(1)=0.0D0
4539           z(2)=0.0D0
4540         endif
4541 C Calculate the "mean" value of theta from the part of the distribution
4542 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4543 C In following comments this theta will be referred to as t_c.
4544         thet_pred_mean=0.0d0
4545         do k=1,2
4546             athetk=athet(k,it,ichir1,ichir2)
4547             bthetk=bthet(k,it,ichir1,ichir2)
4548           if (it.eq.10) then
4549              athetk=athet(k,itype1,ichir11,ichir12)
4550              bthetk=bthet(k,itype2,ichir21,ichir22)
4551           endif
4552           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4553         enddo
4554 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4555         dthett=thet_pred_mean*ssd
4556         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4557 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4558 C Derivatives of the "mean" values in gamma1 and gamma2.
4559         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4560      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4561          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4562      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4563          if (it.eq.10) then
4564       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4565      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4566         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4567      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4568          endif
4569         if (theta(i).gt.pi-delta) then
4570           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4571      &         E_tc0)
4572           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4573           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4574           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4575      &        E_theta)
4576           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4577      &        E_tc)
4578         else if (theta(i).lt.delta) then
4579           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4580           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4581           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4582      &        E_theta)
4583           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4584           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4585      &        E_tc)
4586         else
4587           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4588      &        E_theta,E_tc)
4589         endif
4590         etheta=etheta+ethetai
4591 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4592 c     &      'ebend',i,ethetai,theta(i),itype(i)
4593 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4594 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4595         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4596         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4597         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4598 c 1215   continue
4599       enddo
4600       ethetacnstr=0.0d0
4601 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4602       do i=1,ntheta_constr
4603         itheta=itheta_constr(i)
4604         thetiii=theta(itheta)
4605         difi=pinorm(thetiii-theta_constr0(i))
4606         if (difi.gt.theta_drange(i)) then
4607           difi=difi-theta_drange(i)
4608           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4609           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4610      &    +for_thet_constr(i)*difi**3
4611         else if (difi.lt.-drange(i)) then
4612           difi=difi+drange(i)
4613           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4614           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4615      &    +for_thet_constr(i)*difi**3
4616         else
4617           difi=0.0
4618         endif
4619 C       if (energy_dec) then
4620 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4621 C     &    i,itheta,rad2deg*thetiii,
4622 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4623 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4624 C     &    gloc(itheta+nphi-2,icg)
4625 C        endif
4626       enddo
4627 C Ufff.... We've done all this!!!
4628       return
4629       end
4630 C---------------------------------------------------------------------------
4631       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4632      &     E_tc)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640 C Calculate the contributions to both Gaussian lobes.
4641 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4642 C The "polynomial part" of the "standard deviation" of this part of
4643 C the distribution.
4644         sig=polthet(3,it)
4645         do j=2,0,-1
4646           sig=sig*thet_pred_mean+polthet(j,it)
4647         enddo
4648 C Derivative of the "interior part" of the "standard deviation of the"
4649 C gamma-dependent Gaussian lobe in t_c.
4650         sigtc=3*polthet(3,it)
4651         do j=2,1,-1
4652           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4653         enddo
4654         sigtc=sig*sigtc
4655 C Set the parameters of both Gaussian lobes of the distribution.
4656 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4657         fac=sig*sig+sigc0(it)
4658         sigcsq=fac+fac
4659         sigc=1.0D0/sigcsq
4660 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4661         sigsqtc=-4.0D0*sigcsq*sigtc
4662 c       print *,i,sig,sigtc,sigsqtc
4663 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4664         sigtc=-sigtc/(fac*fac)
4665 C Following variable is sigma(t_c)**(-2)
4666         sigcsq=sigcsq*sigcsq
4667         sig0i=sig0(it)
4668         sig0inv=1.0D0/sig0i**2
4669         delthec=thetai-thet_pred_mean
4670         delthe0=thetai-theta0i
4671         term1=-0.5D0*sigcsq*delthec*delthec
4672         term2=-0.5D0*sig0inv*delthe0*delthe0
4673 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4674 C NaNs in taking the logarithm. We extract the largest exponent which is added
4675 C to the energy (this being the log of the distribution) at the end of energy
4676 C term evaluation for this virtual-bond angle.
4677         if (term1.gt.term2) then
4678           termm=term1
4679           term2=dexp(term2-termm)
4680           term1=1.0d0
4681         else
4682           termm=term2
4683           term1=dexp(term1-termm)
4684           term2=1.0d0
4685         endif
4686 C The ratio between the gamma-independent and gamma-dependent lobes of
4687 C the distribution is a Gaussian function of thet_pred_mean too.
4688         diffak=gthet(2,it)-thet_pred_mean
4689         ratak=diffak/gthet(3,it)**2
4690         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4691 C Let's differentiate it in thet_pred_mean NOW.
4692         aktc=ak*ratak
4693 C Now put together the distribution terms to make complete distribution.
4694         termexp=term1+ak*term2
4695         termpre=sigc+ak*sig0i
4696 C Contribution of the bending energy from this theta is just the -log of
4697 C the sum of the contributions from the two lobes and the pre-exponential
4698 C factor. Simple enough, isn't it?
4699         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4700 C NOW the derivatives!!!
4701 C 6/6/97 Take into account the deformation.
4702         E_theta=(delthec*sigcsq*term1
4703      &       +ak*delthe0*sig0inv*term2)/termexp
4704         E_tc=((sigtc+aktc*sig0i)/termpre
4705      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4706      &       aktc*term2)/termexp)
4707       return
4708       end
4709 c-----------------------------------------------------------------------------
4710       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.LOCAL'
4714       include 'COMMON.IOUNITS'
4715       common /calcthet/ term1,term2,termm,diffak,ratak,
4716      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4717      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4718       delthec=thetai-thet_pred_mean
4719       delthe0=thetai-theta0i
4720 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4721       t3 = thetai-thet_pred_mean
4722       t6 = t3**2
4723       t9 = term1
4724       t12 = t3*sigcsq
4725       t14 = t12+t6*sigsqtc
4726       t16 = 1.0d0
4727       t21 = thetai-theta0i
4728       t23 = t21**2
4729       t26 = term2
4730       t27 = t21*t26
4731       t32 = termexp
4732       t40 = t32**2
4733       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4734      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4735      & *(-t12*t9-ak*sig0inv*t27)
4736       return
4737       end
4738 #else
4739 C--------------------------------------------------------------------------
4740       subroutine ebend(etheta)
4741 C
4742 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4743 C angles gamma and its derivatives in consecutive thetas and gammas.
4744 C ab initio-derived potentials from
4745 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4746 C
4747       implicit real*8 (a-h,o-z)
4748       include 'DIMENSIONS'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.GEO'
4751       include 'COMMON.INTERACT'
4752       include 'COMMON.DERIV'
4753       include 'COMMON.VAR'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.IOUNITS'
4756       include 'COMMON.NAMES'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       include 'COMMON.TORCNSTR'
4760       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4761      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4762      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4763      & sinph1ph2(maxdouble,maxdouble)
4764       logical lprn /.false./, lprn1 /.false./
4765       etheta=0.0D0
4766 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4767       do i=ithet_start,ithet_end
4768 C         if (i.eq.2) cycle
4769 C        if (itype(i-1).eq.ntyp1) cycle
4770         if (i.le.2) cycle
4771         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4772      &  .or.itype(i).eq.ntyp1) cycle
4773         if (iabs(itype(i+1)).eq.20) iblock=2
4774         if (iabs(itype(i+1)).ne.20) iblock=1
4775         dethetai=0.0d0
4776         dephii=0.0d0
4777         dephii1=0.0d0
4778         theti2=0.5d0*theta(i)
4779         ityp2=ithetyp((itype(i-1)))
4780         do k=1,nntheterm
4781           coskt(k)=dcos(k*theti2)
4782           sinkt(k)=dsin(k*theti2)
4783         enddo
4784         if (i.eq.3) then
4785           phii=0.0d0
4786           ityp1=nthetyp+1
4787           do k=1,nsingle
4788             cosph1(k)=0.0d0
4789             sinph1(k)=0.0d0
4790           enddo
4791         else
4792         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4793 #ifdef OSF
4794           phii=phi(i)
4795           if (phii.ne.phii) phii=150.0
4796 #else
4797           phii=phi(i)
4798 #endif
4799           ityp1=ithetyp((itype(i-2)))
4800           do k=1,nsingle
4801             cosph1(k)=dcos(k*phii)
4802             sinph1(k)=dsin(k*phii)
4803           enddo
4804         else
4805           phii=0.0d0
4806 c          ityp1=nthetyp+1
4807           do k=1,nsingle
4808             ityp1=ithetyp((itype(i-2)))
4809             cosph1(k)=0.0d0
4810             sinph1(k)=0.0d0
4811           enddo
4812         endif
4813         endif
4814         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4815 #ifdef OSF
4816           phii1=phi(i+1)
4817           if (phii1.ne.phii1) phii1=150.0
4818           phii1=pinorm(phii1)
4819 #else
4820           phii1=phi(i+1)
4821 #endif
4822           ityp3=ithetyp((itype(i)))
4823           do k=1,nsingle
4824             cosph2(k)=dcos(k*phii1)
4825             sinph2(k)=dsin(k*phii1)
4826           enddo
4827         else
4828           phii1=0.0d0
4829 c          ityp3=nthetyp+1
4830           ityp3=ithetyp((itype(i)))
4831           do k=1,nsingle
4832             cosph2(k)=0.0d0
4833             sinph2(k)=0.0d0
4834           enddo
4835         endif
4836 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4837 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4838 c        call flush(iout)
4839         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4840         do k=1,ndouble
4841           do l=1,k-1
4842             ccl=cosph1(l)*cosph2(k-l)
4843             ssl=sinph1(l)*sinph2(k-l)
4844             scl=sinph1(l)*cosph2(k-l)
4845             csl=cosph1(l)*sinph2(k-l)
4846             cosph1ph2(l,k)=ccl-ssl
4847             cosph1ph2(k,l)=ccl+ssl
4848             sinph1ph2(l,k)=scl+csl
4849             sinph1ph2(k,l)=scl-csl
4850           enddo
4851         enddo
4852         if (lprn) then
4853         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4854      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4855         write (iout,*) "coskt and sinkt"
4856         do k=1,nntheterm
4857           write (iout,*) k,coskt(k),sinkt(k)
4858         enddo
4859         endif
4860         do k=1,ntheterm
4861           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4862           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4863      &      *coskt(k)
4864           if (lprn)
4865      &    write (iout,*) "k",k,"
4866      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4867      &     " ethetai",ethetai
4868         enddo
4869         if (lprn) then
4870         write (iout,*) "cosph and sinph"
4871         do k=1,nsingle
4872           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4873         enddo
4874         write (iout,*) "cosph1ph2 and sinph2ph2"
4875         do k=2,ndouble
4876           do l=1,k-1
4877             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4878      &         sinph1ph2(l,k),sinph1ph2(k,l)
4879           enddo
4880         enddo
4881         write(iout,*) "ethetai",ethetai
4882         endif
4883         do m=1,ntheterm2
4884           do k=1,nsingle
4885             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4886      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4887      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4888      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4889             ethetai=ethetai+sinkt(m)*aux
4890             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4891             dephii=dephii+k*sinkt(m)*(
4892      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4893      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4894             dephii1=dephii1+k*sinkt(m)*(
4895      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4896      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4897             if (lprn)
4898      &      write (iout,*) "m",m," k",k," bbthet",
4899      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4900      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4901      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4902      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4903           enddo
4904         enddo
4905         if (lprn)
4906      &  write(iout,*) "ethetai",ethetai
4907         do m=1,ntheterm3
4908           do k=2,ndouble
4909             do l=1,k-1
4910               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4911      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4912      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4913      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4914               ethetai=ethetai+sinkt(m)*aux
4915               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4916               dephii=dephii+l*sinkt(m)*(
4917      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4918      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4919      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4920      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4921               dephii1=dephii1+(k-l)*sinkt(m)*(
4922      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4923      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4924      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4925      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4926               if (lprn) then
4927               write (iout,*) "m",m," k",k," l",l," ffthet",
4928      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4929      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4930      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4931      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4932      &            " ethetai",ethetai
4933               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4934      &            cosph1ph2(k,l)*sinkt(m),
4935      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4936               endif
4937             enddo
4938           enddo
4939         enddo
4940 10      continue
4941         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4942      &   i,theta(i)*rad2deg,phii*rad2deg,
4943      &   phii1*rad2deg,ethetai
4944         etheta=etheta+ethetai
4945         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4946         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4947 c        gloc(nphi+i-2,icg)=wang*dethetai
4948         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4949       enddo
4950       return
4951       end
4952 #endif
4953 #ifdef CRYST_SC
4954 c-----------------------------------------------------------------------------
4955       subroutine esc(escloc)
4956 C Calculate the local energy of a side chain and its derivatives in the
4957 C corresponding virtual-bond valence angles THETA and the spherical angles
4958 C ALPHA and OMEGA.
4959       implicit real*8 (a-h,o-z)
4960       include 'DIMENSIONS'
4961       include 'COMMON.GEO'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.VAR'
4964       include 'COMMON.INTERACT'
4965       include 'COMMON.DERIV'
4966       include 'COMMON.CHAIN'
4967       include 'COMMON.IOUNITS'
4968       include 'COMMON.NAMES'
4969       include 'COMMON.FFIELD'
4970       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4971      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4972       common /sccalc/ time11,time12,time112,theti,it,nlobit
4973       delta=0.02d0*pi
4974       escloc=0.0D0
4975 C      write (iout,*) 'ESC'
4976       do i=loc_start,loc_end
4977         it=itype(i)
4978         if (it.eq.ntyp1) cycle
4979         if (it.eq.10) goto 1
4980         nlobit=nlob(iabs(it))
4981 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4982 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4983         theti=theta(i+1)-pipol
4984         x(1)=dtan(theti)
4985         x(2)=alph(i)
4986         x(3)=omeg(i)
4987 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4988
4989         if (x(2).gt.pi-delta) then
4990           xtemp(1)=x(1)
4991           xtemp(2)=pi-delta
4992           xtemp(3)=x(3)
4993           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4994           xtemp(2)=pi
4995           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4996           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4997      &        escloci,dersc(2))
4998           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4999      &        ddersc0(1),dersc(1))
5000           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5001      &        ddersc0(3),dersc(3))
5002           xtemp(2)=pi-delta
5003           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5004           xtemp(2)=pi
5005           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5006           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5007      &            dersc0(2),esclocbi,dersc02)
5008           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5009      &            dersc12,dersc01)
5010           call splinthet(x(2),0.5d0*delta,ss,ssd)
5011           dersc0(1)=dersc01
5012           dersc0(2)=dersc02
5013           dersc0(3)=0.0d0
5014           do k=1,3
5015             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5016           enddo
5017           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5018           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5019      &             esclocbi,ss,ssd
5020           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5021 c         escloci=esclocbi
5022 c         write (iout,*) escloci
5023         else if (x(2).lt.delta) then
5024           xtemp(1)=x(1)
5025           xtemp(2)=delta
5026           xtemp(3)=x(3)
5027           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5028           xtemp(2)=0.0d0
5029           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5030           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5031      &        escloci,dersc(2))
5032           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5033      &        ddersc0(1),dersc(1))
5034           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5035      &        ddersc0(3),dersc(3))
5036           xtemp(2)=delta
5037           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5038           xtemp(2)=0.0d0
5039           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5040           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5041      &            dersc0(2),esclocbi,dersc02)
5042           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5043      &            dersc12,dersc01)
5044           dersc0(1)=dersc01
5045           dersc0(2)=dersc02
5046           dersc0(3)=0.0d0
5047           call splinthet(x(2),0.5d0*delta,ss,ssd)
5048           do k=1,3
5049             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5050           enddo
5051           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5052 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5053 c     &             esclocbi,ss,ssd
5054           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5055 C         write (iout,*) 'i=',i, escloci
5056         else
5057           call enesc(x,escloci,dersc,ddummy,.false.)
5058         endif
5059
5060         escloc=escloc+escloci
5061 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5062             write (iout,'(a6,i5,0pf7.3)')
5063      &     'escloc',i,escloci
5064
5065         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5066      &   wscloc*dersc(1)
5067         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5068         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5069     1   continue
5070       enddo
5071       return
5072       end
5073 C---------------------------------------------------------------------------
5074       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5075       implicit real*8 (a-h,o-z)
5076       include 'DIMENSIONS'
5077       include 'COMMON.GEO'
5078       include 'COMMON.LOCAL'
5079       include 'COMMON.IOUNITS'
5080       common /sccalc/ time11,time12,time112,theti,it,nlobit
5081       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5082       double precision contr(maxlob,-1:1)
5083       logical mixed
5084 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5085         escloc_i=0.0D0
5086         do j=1,3
5087           dersc(j)=0.0D0
5088           if (mixed) ddersc(j)=0.0d0
5089         enddo
5090         x3=x(3)
5091
5092 C Because of periodicity of the dependence of the SC energy in omega we have
5093 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5094 C To avoid underflows, first compute & store the exponents.
5095
5096         do iii=-1,1
5097
5098           x(3)=x3+iii*dwapi
5099
5100           do j=1,nlobit
5101             do k=1,3
5102               z(k)=x(k)-censc(k,j,it)
5103             enddo
5104             do k=1,3
5105               Axk=0.0D0
5106               do l=1,3
5107                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5108               enddo
5109               Ax(k,j,iii)=Axk
5110             enddo
5111             expfac=0.0D0
5112             do k=1,3
5113               expfac=expfac+Ax(k,j,iii)*z(k)
5114             enddo
5115             contr(j,iii)=expfac
5116           enddo ! j
5117
5118         enddo ! iii
5119
5120         x(3)=x3
5121 C As in the case of ebend, we want to avoid underflows in exponentiation and
5122 C subsequent NaNs and INFs in energy calculation.
5123 C Find the largest exponent
5124         emin=contr(1,-1)
5125         do iii=-1,1
5126           do j=1,nlobit
5127             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5128           enddo
5129         enddo
5130         emin=0.5D0*emin
5131 cd      print *,'it=',it,' emin=',emin
5132
5133 C Compute the contribution to SC energy and derivatives
5134         do iii=-1,1
5135
5136           do j=1,nlobit
5137             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5138 cd          print *,'j=',j,' expfac=',expfac
5139             escloc_i=escloc_i+expfac
5140             do k=1,3
5141               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5142             enddo
5143             if (mixed) then
5144               do k=1,3,2
5145                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5146      &            +gaussc(k,2,j,it))*expfac
5147               enddo
5148             endif
5149           enddo
5150
5151         enddo ! iii
5152
5153         dersc(1)=dersc(1)/cos(theti)**2
5154         ddersc(1)=ddersc(1)/cos(theti)**2
5155         ddersc(3)=ddersc(3)
5156
5157         escloci=-(dlog(escloc_i)-emin)
5158         do j=1,3
5159           dersc(j)=dersc(j)/escloc_i
5160         enddo
5161         if (mixed) then
5162           do j=1,3,2
5163             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5164           enddo
5165         endif
5166       return
5167       end
5168 C------------------------------------------------------------------------------
5169       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5170       implicit real*8 (a-h,o-z)
5171       include 'DIMENSIONS'
5172       include 'COMMON.GEO'
5173       include 'COMMON.LOCAL'
5174       include 'COMMON.IOUNITS'
5175       common /sccalc/ time11,time12,time112,theti,it,nlobit
5176       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5177       double precision contr(maxlob)
5178       logical mixed
5179
5180       escloc_i=0.0D0
5181
5182       do j=1,3
5183         dersc(j)=0.0D0
5184       enddo
5185
5186       do j=1,nlobit
5187         do k=1,2
5188           z(k)=x(k)-censc(k,j,it)
5189         enddo
5190         z(3)=dwapi
5191         do k=1,3
5192           Axk=0.0D0
5193           do l=1,3
5194             Axk=Axk+gaussc(l,k,j,it)*z(l)
5195           enddo
5196           Ax(k,j)=Axk
5197         enddo
5198         expfac=0.0D0
5199         do k=1,3
5200           expfac=expfac+Ax(k,j)*z(k)
5201         enddo
5202         contr(j)=expfac
5203       enddo ! j
5204
5205 C As in the case of ebend, we want to avoid underflows in exponentiation and
5206 C subsequent NaNs and INFs in energy calculation.
5207 C Find the largest exponent
5208       emin=contr(1)
5209       do j=1,nlobit
5210         if (emin.gt.contr(j)) emin=contr(j)
5211       enddo
5212       emin=0.5D0*emin
5213
5214 C Compute the contribution to SC energy and derivatives
5215
5216       dersc12=0.0d0
5217       do j=1,nlobit
5218         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5219         escloc_i=escloc_i+expfac
5220         do k=1,2
5221           dersc(k)=dersc(k)+Ax(k,j)*expfac
5222         enddo
5223         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5224      &            +gaussc(1,2,j,it))*expfac
5225         dersc(3)=0.0d0
5226       enddo
5227
5228       dersc(1)=dersc(1)/cos(theti)**2
5229       dersc12=dersc12/cos(theti)**2
5230       escloci=-(dlog(escloc_i)-emin)
5231       do j=1,2
5232         dersc(j)=dersc(j)/escloc_i
5233       enddo
5234       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5235       return
5236       end
5237 #else
5238 c----------------------------------------------------------------------------------
5239       subroutine esc(escloc)
5240 C Calculate the local energy of a side chain and its derivatives in the
5241 C corresponding virtual-bond valence angles THETA and the spherical angles
5242 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5243 C added by Urszula Kozlowska. 07/11/2007
5244 C
5245       implicit real*8 (a-h,o-z)
5246       include 'DIMENSIONS'
5247       include 'COMMON.GEO'
5248       include 'COMMON.LOCAL'
5249       include 'COMMON.VAR'
5250       include 'COMMON.SCROT'
5251       include 'COMMON.INTERACT'
5252       include 'COMMON.DERIV'
5253       include 'COMMON.CHAIN'
5254       include 'COMMON.IOUNITS'
5255       include 'COMMON.NAMES'
5256       include 'COMMON.FFIELD'
5257       include 'COMMON.CONTROL'
5258       include 'COMMON.VECTORS'
5259       double precision x_prime(3),y_prime(3),z_prime(3)
5260      &    , sumene,dsc_i,dp2_i,x(65),
5261      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5262      &    de_dxx,de_dyy,de_dzz,de_dt
5263       double precision s1_t,s1_6_t,s2_t,s2_6_t
5264       double precision
5265      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5266      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5267      & dt_dCi(3),dt_dCi1(3)
5268       common /sccalc/ time11,time12,time112,theti,it,nlobit
5269       delta=0.02d0*pi
5270       escloc=0.0D0
5271       do i=loc_start,loc_end
5272         if (itype(i).eq.ntyp1) cycle
5273         costtab(i+1) =dcos(theta(i+1))
5274         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5275         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5276         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5277         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5278         cosfac=dsqrt(cosfac2)
5279         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5280         sinfac=dsqrt(sinfac2)
5281         it=iabs(itype(i))
5282         if (it.eq.10) goto 1
5283 c
5284 C  Compute the axes of tghe local cartesian coordinates system; store in
5285 c   x_prime, y_prime and z_prime
5286 c
5287         do j=1,3
5288           x_prime(j) = 0.00
5289           y_prime(j) = 0.00
5290           z_prime(j) = 0.00
5291         enddo
5292 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5293 C     &   dc_norm(3,i+nres)
5294         do j = 1,3
5295           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5296           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5297         enddo
5298         do j = 1,3
5299           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5300         enddo
5301 c       write (2,*) "i",i
5302 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5303 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5304 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5305 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5306 c      & " xy",scalar(x_prime(1),y_prime(1)),
5307 c      & " xz",scalar(x_prime(1),z_prime(1)),
5308 c      & " yy",scalar(y_prime(1),y_prime(1)),
5309 c      & " yz",scalar(y_prime(1),z_prime(1)),
5310 c      & " zz",scalar(z_prime(1),z_prime(1))
5311 c
5312 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5313 C to local coordinate system. Store in xx, yy, zz.
5314 c
5315         xx=0.0d0
5316         yy=0.0d0
5317         zz=0.0d0
5318         do j = 1,3
5319           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5320           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5321           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5322         enddo
5323
5324         xxtab(i)=xx
5325         yytab(i)=yy
5326         zztab(i)=zz
5327 C
5328 C Compute the energy of the ith side cbain
5329 C
5330 c        write (2,*) "xx",xx," yy",yy," zz",zz
5331         it=iabs(itype(i))
5332         do j = 1,65
5333           x(j) = sc_parmin(j,it)
5334         enddo
5335 #ifdef CHECK_COORD
5336 Cc diagnostics - remove later
5337         xx1 = dcos(alph(2))
5338         yy1 = dsin(alph(2))*dcos(omeg(2))
5339         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5340         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5341      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5342      &    xx1,yy1,zz1
5343 C,"  --- ", xx_w,yy_w,zz_w
5344 c end diagnostics
5345 #endif
5346         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5347      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5348      &   + x(10)*yy*zz
5349         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5350      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5351      & + x(20)*yy*zz
5352         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5353      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5354      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5355      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5356      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5357      &  +x(40)*xx*yy*zz
5358         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5359      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5360      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5361      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5362      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5363      &  +x(60)*xx*yy*zz
5364         dsc_i   = 0.743d0+x(61)
5365         dp2_i   = 1.9d0+x(62)
5366         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5367      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5368         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5369      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5370         s1=(1+x(63))/(0.1d0 + dscp1)
5371         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5372         s2=(1+x(65))/(0.1d0 + dscp2)
5373         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5374         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5375      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5376 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5377 c     &   sumene4,
5378 c     &   dscp1,dscp2,sumene
5379 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5380         escloc = escloc + sumene
5381 c        write (2,*) "escloc",escloc
5382 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5383 c     &  zz,xx,yy
5384         if (.not. calc_grad) goto 1
5385 #ifdef DEBUG
5386 C
5387 C This section to check the numerical derivatives of the energy of ith side
5388 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5389 C #define DEBUG in the code to turn it on.
5390 C
5391         write (2,*) "sumene               =",sumene
5392         aincr=1.0d-7
5393         xxsave=xx
5394         xx=xx+aincr
5395         write (2,*) xx,yy,zz
5396         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5397         de_dxx_num=(sumenep-sumene)/aincr
5398         xx=xxsave
5399         write (2,*) "xx+ sumene from enesc=",sumenep
5400         yysave=yy
5401         yy=yy+aincr
5402         write (2,*) xx,yy,zz
5403         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5404         de_dyy_num=(sumenep-sumene)/aincr
5405         yy=yysave
5406         write (2,*) "yy+ sumene from enesc=",sumenep
5407         zzsave=zz
5408         zz=zz+aincr
5409         write (2,*) xx,yy,zz
5410         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5411         de_dzz_num=(sumenep-sumene)/aincr
5412         zz=zzsave
5413         write (2,*) "zz+ sumene from enesc=",sumenep
5414         costsave=cost2tab(i+1)
5415         sintsave=sint2tab(i+1)
5416         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5417         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dt_num=(sumenep-sumene)/aincr
5420         write (2,*) " t+ sumene from enesc=",sumenep
5421         cost2tab(i+1)=costsave
5422         sint2tab(i+1)=sintsave
5423 C End of diagnostics section.
5424 #endif
5425 C
5426 C Compute the gradient of esc
5427 C
5428         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5429         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5430         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5431         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5432         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5433         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5434         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5435         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5436         pom1=(sumene3*sint2tab(i+1)+sumene1)
5437      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5438         pom2=(sumene4*cost2tab(i+1)+sumene2)
5439      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5440         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5441         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5442      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5443      &  +x(40)*yy*zz
5444         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5445         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5446      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5447      &  +x(60)*yy*zz
5448         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5449      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5450      &        +(pom1+pom2)*pom_dx
5451 #ifdef DEBUG
5452         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5453 #endif
5454 C
5455         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5456         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5457      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5458      &  +x(40)*xx*zz
5459         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5460         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5461      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5462      &  +x(59)*zz**2 +x(60)*xx*zz
5463         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5464      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5465      &        +(pom1-pom2)*pom_dy
5466 #ifdef DEBUG
5467         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5468 #endif
5469 C
5470         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5471      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5472      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5473      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5474      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5475      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5476      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5477      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5478 #ifdef DEBUG
5479         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5480 #endif
5481 C
5482         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5483      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5484      &  +pom1*pom_dt1+pom2*pom_dt2
5485 #ifdef DEBUG
5486         write(2,*), "de_dt = ", de_dt,de_dt_num
5487 #endif
5488 c
5489 C
5490        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5491        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5492        cosfac2xx=cosfac2*xx
5493        sinfac2yy=sinfac2*yy
5494        do k = 1,3
5495          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5496      &      vbld_inv(i+1)
5497          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5498      &      vbld_inv(i)
5499          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5500          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5501 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5502 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5503 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5504 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5505          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5506          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5507          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5508          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5509          dZZ_Ci1(k)=0.0d0
5510          dZZ_Ci(k)=0.0d0
5511          do j=1,3
5512            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5513      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5514            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5515      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5516          enddo
5517
5518          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5519          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5520          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5521 c
5522          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5523          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5524        enddo
5525
5526        do k=1,3
5527          dXX_Ctab(k,i)=dXX_Ci(k)
5528          dXX_C1tab(k,i)=dXX_Ci1(k)
5529          dYY_Ctab(k,i)=dYY_Ci(k)
5530          dYY_C1tab(k,i)=dYY_Ci1(k)
5531          dZZ_Ctab(k,i)=dZZ_Ci(k)
5532          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5533          dXX_XYZtab(k,i)=dXX_XYZ(k)
5534          dYY_XYZtab(k,i)=dYY_XYZ(k)
5535          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5536        enddo
5537
5538        do k = 1,3
5539 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5540 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5541 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5542 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5543 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5544 c     &    dt_dci(k)
5545 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5546 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5547          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5548      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5549          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5550      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5551          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5552      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5553        enddo
5554 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5555 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5556
5557 C to check gradient call subroutine check_grad
5558
5559     1 continue
5560       enddo
5561       return
5562       end
5563 #endif
5564 c------------------------------------------------------------------------------
5565       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5566 C
5567 C This procedure calculates two-body contact function g(rij) and its derivative:
5568 C
5569 C           eps0ij                                     !       x < -1
5570 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5571 C            0                                         !       x > 1
5572 C
5573 C where x=(rij-r0ij)/delta
5574 C
5575 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5576 C
5577       implicit none
5578       double precision rij,r0ij,eps0ij,fcont,fprimcont
5579       double precision x,x2,x4,delta
5580 c     delta=0.02D0*r0ij
5581 c      delta=0.2D0*r0ij
5582       x=(rij-r0ij)/delta
5583       if (x.lt.-1.0D0) then
5584         fcont=eps0ij
5585         fprimcont=0.0D0
5586       else if (x.le.1.0D0) then
5587         x2=x*x
5588         x4=x2*x2
5589         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5590         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5591       else
5592         fcont=0.0D0
5593         fprimcont=0.0D0
5594       endif
5595       return
5596       end
5597 c------------------------------------------------------------------------------
5598       subroutine splinthet(theti,delta,ss,ssder)
5599       implicit real*8 (a-h,o-z)
5600       include 'DIMENSIONS'
5601       include 'COMMON.VAR'
5602       include 'COMMON.GEO'
5603       thetup=pi-delta
5604       thetlow=delta
5605       if (theti.gt.pipol) then
5606         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5607       else
5608         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5609         ssder=-ssder
5610       endif
5611       return
5612       end
5613 c------------------------------------------------------------------------------
5614       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5615       implicit none
5616       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5617       double precision ksi,ksi2,ksi3,a1,a2,a3
5618       a1=fprim0*delta/(f1-f0)
5619       a2=3.0d0-2.0d0*a1
5620       a3=a1-2.0d0
5621       ksi=(x-x0)/delta
5622       ksi2=ksi*ksi
5623       ksi3=ksi2*ksi
5624       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5625       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5630       implicit none
5631       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5632       double precision ksi,ksi2,ksi3,a1,a2,a3
5633       ksi=(x-x0)/delta
5634       ksi2=ksi*ksi
5635       ksi3=ksi2*ksi
5636       a1=fprim0x*delta
5637       a2=3*(f1x-f0x)-2*fprim0x*delta
5638       a3=fprim0x*delta-2*(f1x-f0x)
5639       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5640       return
5641       end
5642 C-----------------------------------------------------------------------------
5643 #ifdef CRYST_TOR
5644 C-----------------------------------------------------------------------------
5645       subroutine etor(etors,fact)
5646       implicit real*8 (a-h,o-z)
5647       include 'DIMENSIONS'
5648       include 'COMMON.VAR'
5649       include 'COMMON.GEO'
5650       include 'COMMON.LOCAL'
5651       include 'COMMON.TORSION'
5652       include 'COMMON.INTERACT'
5653       include 'COMMON.DERIV'
5654       include 'COMMON.CHAIN'
5655       include 'COMMON.NAMES'
5656       include 'COMMON.IOUNITS'
5657       include 'COMMON.FFIELD'
5658       include 'COMMON.TORCNSTR'
5659       logical lprn
5660 C Set lprn=.true. for debugging
5661       lprn=.false.
5662 c      lprn=.true.
5663       etors=0.0D0
5664       do i=iphi_start,iphi_end
5665         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5666      &      .or. itype(i).eq.ntyp1) cycle
5667         itori=itortyp(itype(i-2))
5668         itori1=itortyp(itype(i-1))
5669         phii=phi(i)
5670         gloci=0.0D0
5671 C Proline-Proline pair is a special case...
5672         if (itori.eq.3 .and. itori1.eq.3) then
5673           if (phii.gt.-dwapi3) then
5674             cosphi=dcos(3*phii)
5675             fac=1.0D0/(1.0D0-cosphi)
5676             etorsi=v1(1,3,3)*fac
5677             etorsi=etorsi+etorsi
5678             etors=etors+etorsi-v1(1,3,3)
5679             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5680           endif
5681           do j=1,3
5682             v1ij=v1(j+1,itori,itori1)
5683             v2ij=v2(j+1,itori,itori1)
5684             cosphi=dcos(j*phii)
5685             sinphi=dsin(j*phii)
5686             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5687             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5688           enddo
5689         else
5690           do j=1,nterm_old
5691             v1ij=v1(j,itori,itori1)
5692             v2ij=v2(j,itori,itori1)
5693             cosphi=dcos(j*phii)
5694             sinphi=dsin(j*phii)
5695             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5696             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5697           enddo
5698         endif
5699         if (lprn)
5700      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5701      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5702      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5703         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5704 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5705       enddo
5706       return
5707       end
5708 c------------------------------------------------------------------------------
5709 #else
5710       subroutine etor(etors,fact)
5711       implicit real*8 (a-h,o-z)
5712       include 'DIMENSIONS'
5713       include 'COMMON.VAR'
5714       include 'COMMON.GEO'
5715       include 'COMMON.LOCAL'
5716       include 'COMMON.TORSION'
5717       include 'COMMON.INTERACT'
5718       include 'COMMON.DERIV'
5719       include 'COMMON.CHAIN'
5720       include 'COMMON.NAMES'
5721       include 'COMMON.IOUNITS'
5722       include 'COMMON.FFIELD'
5723       include 'COMMON.TORCNSTR'
5724       logical lprn
5725 C Set lprn=.true. for debugging
5726       lprn=.false.
5727 c      lprn=.true.
5728       etors=0.0D0
5729       do i=iphi_start,iphi_end
5730         if (i.le.2) cycle
5731         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5732      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5733 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5734 C     &       .or. itype(i).eq.ntyp1) cycle
5735         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5736          if (iabs(itype(i)).eq.20) then
5737          iblock=2
5738          else
5739          iblock=1
5740          endif
5741         itori=itortyp(itype(i-2))
5742         itori1=itortyp(itype(i-1))
5743         phii=phi(i)
5744         gloci=0.0D0
5745 C Regular cosine and sine terms
5746         do j=1,nterm(itori,itori1,iblock)
5747           v1ij=v1(j,itori,itori1,iblock)
5748           v2ij=v2(j,itori,itori1,iblock)
5749           cosphi=dcos(j*phii)
5750           sinphi=dsin(j*phii)
5751           etors=etors+v1ij*cosphi+v2ij*sinphi
5752           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5753         enddo
5754 C Lorentz terms
5755 C                         v1
5756 C  E = SUM ----------------------------------- - v1
5757 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5758 C
5759         cosphi=dcos(0.5d0*phii)
5760         sinphi=dsin(0.5d0*phii)
5761         do j=1,nlor(itori,itori1,iblock)
5762           vl1ij=vlor1(j,itori,itori1)
5763           vl2ij=vlor2(j,itori,itori1)
5764           vl3ij=vlor3(j,itori,itori1)
5765           pom=vl2ij*cosphi+vl3ij*sinphi
5766           pom1=1.0d0/(pom*pom+1.0d0)
5767           etors=etors+vl1ij*pom1
5768 c          if (energy_dec) etors_ii=etors_ii+
5769 c     &                vl1ij*pom1
5770           pom=-pom*pom1*pom1
5771           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5772         enddo
5773 C Subtract the constant term
5774         etors=etors-v0(itori,itori1,iblock)
5775         if (lprn)
5776      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5777      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5778      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5779         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5780 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5781  1215   continue
5782       enddo
5783       return
5784       end
5785 c----------------------------------------------------------------------------
5786       subroutine etor_d(etors_d,fact2)
5787 C 6/23/01 Compute double torsional energy
5788       implicit real*8 (a-h,o-z)
5789       include 'DIMENSIONS'
5790       include 'COMMON.VAR'
5791       include 'COMMON.GEO'
5792       include 'COMMON.LOCAL'
5793       include 'COMMON.TORSION'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.DERIV'
5796       include 'COMMON.CHAIN'
5797       include 'COMMON.NAMES'
5798       include 'COMMON.IOUNITS'
5799       include 'COMMON.FFIELD'
5800       include 'COMMON.TORCNSTR'
5801       logical lprn
5802 C Set lprn=.true. for debugging
5803       lprn=.false.
5804 c     lprn=.true.
5805       etors_d=0.0D0
5806       do i=iphi_start,iphi_end-1
5807         if (i.le.3) cycle
5808 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5809 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5810          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5811      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5812      &  (itype(i+1).eq.ntyp1)) cycle
5813         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5814      &     goto 1215
5815         itori=itortyp(itype(i-2))
5816         itori1=itortyp(itype(i-1))
5817         itori2=itortyp(itype(i))
5818         phii=phi(i)
5819         phii1=phi(i+1)
5820         gloci1=0.0D0
5821         gloci2=0.0D0
5822         iblock=1
5823         if (iabs(itype(i+1)).eq.20) iblock=2
5824 C Regular cosine and sine terms
5825         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5826           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5827           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5828           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5829           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5830           cosphi1=dcos(j*phii)
5831           sinphi1=dsin(j*phii)
5832           cosphi2=dcos(j*phii1)
5833           sinphi2=dsin(j*phii1)
5834           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5835      &     v2cij*cosphi2+v2sij*sinphi2
5836           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5837           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5838         enddo
5839         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5840           do l=1,k-1
5841             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5842             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5843             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5844             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5845             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5846             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5847             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5848             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5849             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5850      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5851             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5852      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5853             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5854      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5855           enddo
5856         enddo
5857         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5858         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5859  1215   continue
5860       enddo
5861       return
5862       end
5863 #endif
5864 c---------------------------------------------------------------------------
5865 C The rigorous attempt to derive energy function
5866       subroutine etor_kcc(etors,fact)
5867       implicit real*8 (a-h,o-z)
5868       include 'DIMENSIONS'
5869       include 'COMMON.VAR'
5870       include 'COMMON.GEO'
5871       include 'COMMON.LOCAL'
5872       include 'COMMON.TORSION'
5873       include 'COMMON.INTERACT'
5874       include 'COMMON.DERIV'
5875       include 'COMMON.CHAIN'
5876       include 'COMMON.NAMES'
5877       include 'COMMON.IOUNITS'
5878       include 'COMMON.FFIELD'
5879       include 'COMMON.TORCNSTR'
5880       include 'COMMON.CONTROL'
5881       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5882       logical lprn
5883 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5884 C Set lprn=.true. for debugging
5885       lprn=energy_dec
5886 c     lprn=.true.
5887 C      print *,"wchodze kcc"
5888       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5889       etors=0.0D0
5890       do i=iphi_start,iphi_end
5891 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5892 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5893 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5894 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5895         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5896      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5897         itori=itortyp(itype(i-2))
5898         itori1=itortyp(itype(i-1))
5899         phii=phi(i)
5900         glocig=0.0D0
5901         glocit1=0.0d0
5902         glocit2=0.0d0
5903 C to avoid multiple devision by 2
5904 c        theti22=0.5d0*theta(i)
5905 C theta 12 is the theta_1 /2
5906 C theta 22 is theta_2 /2
5907 c        theti12=0.5d0*theta(i-1)
5908 C and appropriate sinus function
5909         sinthet1=dsin(theta(i-1))
5910         sinthet2=dsin(theta(i))
5911         costhet1=dcos(theta(i-1))
5912         costhet2=dcos(theta(i))
5913 C to speed up lets store its mutliplication
5914         sint1t2=sinthet2*sinthet1
5915         sint1t2n=1.0d0
5916 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5917 C +d_n*sin(n*gamma)) *
5918 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5919 C we have two sum 1) Non-Chebyshev which is with n and gamma
5920         nval=nterm_kcc_Tb(itori,itori1)
5921         c1(0)=0.0d0
5922         c2(0)=0.0d0
5923         c1(1)=1.0d0
5924         c2(1)=1.0d0
5925         do j=2,nval
5926           c1(j)=c1(j-1)*costhet1
5927           c2(j)=c2(j-1)*costhet2
5928         enddo
5929         etori=0.0d0
5930         do j=1,nterm_kcc(itori,itori1)
5931           cosphi=dcos(j*phii)
5932           sinphi=dsin(j*phii)
5933           sint1t2n1=sint1t2n
5934           sint1t2n=sint1t2n*sint1t2
5935           sumvalc=0.0d0
5936           gradvalct1=0.0d0
5937           gradvalct2=0.0d0
5938           do k=1,nval
5939             do l=1,nval
5940               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5941               gradvalct1=gradvalct1+
5942      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5943               gradvalct2=gradvalct2+
5944      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5945             enddo
5946           enddo
5947           gradvalct1=-gradvalct1*sinthet1
5948           gradvalct2=-gradvalct2*sinthet2
5949           sumvals=0.0d0
5950           gradvalst1=0.0d0
5951           gradvalst2=0.0d0
5952           do k=1,nval
5953             do l=1,nval
5954               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5955               gradvalst1=gradvalst1+
5956      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5957               gradvalst2=gradvalst2+
5958      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5959             enddo
5960           enddo
5961           gradvalst1=-gradvalst1*sinthet1
5962           gradvalst2=-gradvalst2*sinthet2
5963           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5964 C glocig is the gradient local i site in gamma
5965           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5966 C now gradient over theta_1
5967           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5968      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5969           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5970      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5971         enddo ! j
5972         etors=etors+etori
5973 C derivative over gamma
5974         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5975 C derivative over theta1
5976         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5977 C now derivative over theta2
5978         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5979         if (lprn)
5980      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5981      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5982       enddo
5983       return
5984       end
5985 c---------------------------------------------------------------------------------------------
5986       subroutine etor_constr(edihcnstr)
5987       implicit real*8 (a-h,o-z)
5988       include 'DIMENSIONS'
5989       include 'COMMON.VAR'
5990       include 'COMMON.GEO'
5991       include 'COMMON.LOCAL'
5992       include 'COMMON.TORSION'
5993       include 'COMMON.INTERACT'
5994       include 'COMMON.DERIV'
5995       include 'COMMON.CHAIN'
5996       include 'COMMON.NAMES'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.FFIELD'
5999       include 'COMMON.TORCNSTR'
6000       include 'COMMON.CONTROL'
6001 ! 6/20/98 - dihedral angle constraints
6002       edihcnstr=0.0d0
6003 c      do i=1,ndih_constr
6004 c      write (iout,*) "idihconstr_start",idihconstr_start,
6005 c     &  " idihconstr_end",idihconstr_end
6006       if (raw_psipred) then
6007         do i=idihconstr_start,idihconstr_end
6008           itori=idih_constr(i)
6009           phii=phi(itori)
6010           gaudih_i=vpsipred(1,i)
6011           gauder_i=0.0d0
6012           do j=1,2
6013             s = sdihed(j,i)
6014             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6015             dexpcos_i=dexp(-cos_i*cos_i)
6016             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6017             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6018      &            *cos_i*dexpcos_i/s**2
6019           enddo
6020           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6021           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6022           if (energy_dec)
6023      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6024      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6025      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6026      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6027      &     -wdihc*dlog(gaudih_i)
6028         enddo
6029       else
6030         do i=idihconstr_start,idihconstr_end
6031           itori=idih_constr(i)
6032           phii=phi(itori)
6033           difi=pinorm(phii-phi0(i))
6034           if (difi.gt.drange(i)) then
6035             difi=difi-drange(i)
6036             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6037             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6038           else if (difi.lt.-drange(i)) then
6039             difi=difi+drange(i)
6040             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6041             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6042           else
6043             difi=0.0
6044           endif
6045         enddo
6046       endif
6047       return
6048       end
6049 c----------------------------------------------------------------------------
6050 C The rigorous attempt to derive energy function
6051       subroutine ebend_kcc(etheta)
6052
6053       implicit real*8 (a-h,o-z)
6054       include 'DIMENSIONS'
6055       include 'COMMON.VAR'
6056       include 'COMMON.GEO'
6057       include 'COMMON.LOCAL'
6058       include 'COMMON.TORSION'
6059       include 'COMMON.INTERACT'
6060       include 'COMMON.DERIV'
6061       include 'COMMON.CHAIN'
6062       include 'COMMON.NAMES'
6063       include 'COMMON.IOUNITS'
6064       include 'COMMON.FFIELD'
6065       include 'COMMON.TORCNSTR'
6066       include 'COMMON.CONTROL'
6067       logical lprn
6068       double precision thybt1(maxang_kcc)
6069 C Set lprn=.true. for debugging
6070       lprn=energy_dec
6071 c     lprn=.true.
6072 C      print *,"wchodze kcc"
6073       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6074       etheta=0.0D0
6075       do i=ithet_start,ithet_end
6076 c        print *,i,itype(i-1),itype(i),itype(i-2)
6077         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6078      &  .or.itype(i).eq.ntyp1) cycle
6079         iti=iabs(itortyp(itype(i-1)))
6080         sinthet=dsin(theta(i))
6081         costhet=dcos(theta(i))
6082         do j=1,nbend_kcc_Tb(iti)
6083           thybt1(j)=v1bend_chyb(j,iti)
6084         enddo
6085         sumth1thyb=v1bend_chyb(0,iti)+
6086      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6087         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6088      &    sumth1thyb
6089         ihelp=nbend_kcc_Tb(iti)-1
6090         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6091         etheta=etheta+sumth1thyb
6092 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6093         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6094       enddo
6095       return
6096       end
6097 c-------------------------------------------------------------------------------------
6098       subroutine etheta_constr(ethetacnstr)
6099
6100       implicit real*8 (a-h,o-z)
6101       include 'DIMENSIONS'
6102       include 'COMMON.VAR'
6103       include 'COMMON.GEO'
6104       include 'COMMON.LOCAL'
6105       include 'COMMON.TORSION'
6106       include 'COMMON.INTERACT'
6107       include 'COMMON.DERIV'
6108       include 'COMMON.CHAIN'
6109       include 'COMMON.NAMES'
6110       include 'COMMON.IOUNITS'
6111       include 'COMMON.FFIELD'
6112       include 'COMMON.TORCNSTR'
6113       include 'COMMON.CONTROL'
6114       ethetacnstr=0.0d0
6115 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6116       do i=ithetaconstr_start,ithetaconstr_end
6117         itheta=itheta_constr(i)
6118         thetiii=theta(itheta)
6119         difi=pinorm(thetiii-theta_constr0(i))
6120         if (difi.gt.theta_drange(i)) then
6121           difi=difi-theta_drange(i)
6122           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6123           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6124      &    +for_thet_constr(i)*difi**3
6125         else if (difi.lt.-drange(i)) then
6126           difi=difi+drange(i)
6127           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6128           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6129      &    +for_thet_constr(i)*difi**3
6130         else
6131           difi=0.0
6132         endif
6133        if (energy_dec) then
6134         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6135      &    i,itheta,rad2deg*thetiii,
6136      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6137      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6138      &    gloc(itheta+nphi-2,icg)
6139         endif
6140       enddo
6141       return
6142       end
6143 c------------------------------------------------------------------------------
6144 c------------------------------------------------------------------------------
6145       subroutine eback_sc_corr(esccor)
6146 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6147 c        conformational states; temporarily implemented as differences
6148 c        between UNRES torsional potentials (dependent on three types of
6149 c        residues) and the torsional potentials dependent on all 20 types
6150 c        of residues computed from AM1 energy surfaces of terminally-blocked
6151 c        amino-acid residues.
6152       implicit real*8 (a-h,o-z)
6153       include 'DIMENSIONS'
6154       include 'COMMON.VAR'
6155       include 'COMMON.GEO'
6156       include 'COMMON.LOCAL'
6157       include 'COMMON.TORSION'
6158       include 'COMMON.SCCOR'
6159       include 'COMMON.INTERACT'
6160       include 'COMMON.DERIV'
6161       include 'COMMON.CHAIN'
6162       include 'COMMON.NAMES'
6163       include 'COMMON.IOUNITS'
6164       include 'COMMON.FFIELD'
6165       include 'COMMON.CONTROL'
6166       logical lprn
6167 C Set lprn=.true. for debugging
6168       lprn=.false.
6169 c      lprn=.true.
6170 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6171       esccor=0.0D0
6172       do i=itau_start,itau_end
6173         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6174         esccor_ii=0.0D0
6175         isccori=isccortyp(itype(i-2))
6176         isccori1=isccortyp(itype(i-1))
6177         phii=phi(i)
6178         do intertyp=1,3 !intertyp
6179 cc Added 09 May 2012 (Adasko)
6180 cc  Intertyp means interaction type of backbone mainchain correlation:
6181 c   1 = SC...Ca...Ca...Ca
6182 c   2 = Ca...Ca...Ca...SC
6183 c   3 = SC...Ca...Ca...SCi
6184         gloci=0.0D0
6185         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6186      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6187      &      (itype(i-1).eq.ntyp1)))
6188      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6189      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6190      &     .or.(itype(i).eq.ntyp1)))
6191      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6192      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6193      &      (itype(i-3).eq.ntyp1)))) cycle
6194         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6195         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6196      & cycle
6197        do j=1,nterm_sccor(isccori,isccori1)
6198           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6199           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6200           cosphi=dcos(j*tauangle(intertyp,i))
6201           sinphi=dsin(j*tauangle(intertyp,i))
6202            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6203            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6204          enddo
6205 C      write (iout,*)"EBACK_SC_COR",esccor,i
6206 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6207 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6208 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6209         if (lprn)
6210      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6211      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6212      &  (v1sccor(j,1,itori,itori1),j=1,6)
6213      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6214 c        gsccor_loc(i-3)=gloci
6215        enddo !intertyp
6216       enddo
6217       return
6218       end
6219 c------------------------------------------------------------------------------
6220       subroutine multibody(ecorr)
6221 C This subroutine calculates multi-body contributions to energy following
6222 C the idea of Skolnick et al. If side chains I and J make a contact and
6223 C at the same time side chains I+1 and J+1 make a contact, an extra
6224 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6225       implicit real*8 (a-h,o-z)
6226       include 'DIMENSIONS'
6227       include 'COMMON.IOUNITS'
6228       include 'COMMON.DERIV'
6229       include 'COMMON.INTERACT'
6230       include 'COMMON.CONTACTS'
6231       double precision gx(3),gx1(3)
6232       logical lprn
6233
6234 C Set lprn=.true. for debugging
6235       lprn=.false.
6236
6237       if (lprn) then
6238         write (iout,'(a)') 'Contact function values:'
6239         do i=nnt,nct-2
6240           write (iout,'(i2,20(1x,i2,f10.5))')
6241      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6242         enddo
6243       endif
6244       ecorr=0.0D0
6245       do i=nnt,nct
6246         do j=1,3
6247           gradcorr(j,i)=0.0D0
6248           gradxorr(j,i)=0.0D0
6249         enddo
6250       enddo
6251       do i=nnt,nct-2
6252
6253         DO ISHIFT = 3,4
6254
6255         i1=i+ishift
6256         num_conti=num_cont(i)
6257         num_conti1=num_cont(i1)
6258         do jj=1,num_conti
6259           j=jcont(jj,i)
6260           do kk=1,num_conti1
6261             j1=jcont(kk,i1)
6262             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6263 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6264 cd   &                   ' ishift=',ishift
6265 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6266 C The system gains extra energy.
6267               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6268             endif   ! j1==j+-ishift
6269           enddo     ! kk
6270         enddo       ! jj
6271
6272         ENDDO ! ISHIFT
6273
6274       enddo         ! i
6275       return
6276       end
6277 c------------------------------------------------------------------------------
6278       double precision function esccorr(i,j,k,l,jj,kk)
6279       implicit real*8 (a-h,o-z)
6280       include 'DIMENSIONS'
6281       include 'COMMON.IOUNITS'
6282       include 'COMMON.DERIV'
6283       include 'COMMON.INTERACT'
6284       include 'COMMON.CONTACTS'
6285       double precision gx(3),gx1(3)
6286       logical lprn
6287       lprn=.false.
6288       eij=facont(jj,i)
6289       ekl=facont(kk,k)
6290 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6291 C Calculate the multi-body contribution to energy.
6292 C Calculate multi-body contributions to the gradient.
6293 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6294 cd   & k,l,(gacont(m,kk,k),m=1,3)
6295       do m=1,3
6296         gx(m) =ekl*gacont(m,jj,i)
6297         gx1(m)=eij*gacont(m,kk,k)
6298         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6299         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6300         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6301         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6302       enddo
6303       do m=i,j-1
6304         do ll=1,3
6305           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6306         enddo
6307       enddo
6308       do m=k,l-1
6309         do ll=1,3
6310           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6311         enddo
6312       enddo
6313       esccorr=-eij*ekl
6314       return
6315       end
6316 c------------------------------------------------------------------------------
6317       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6318 C This subroutine calculates multi-body contributions to hydrogen-bonding
6319       implicit real*8 (a-h,o-z)
6320       include 'DIMENSIONS'
6321       include 'COMMON.IOUNITS'
6322       include 'COMMON.FFIELD'
6323       include 'COMMON.DERIV'
6324       include 'COMMON.INTERACT'
6325       include 'COMMON.CONTACTS'
6326       double precision gx(3),gx1(3)
6327       logical lprn,ldone
6328
6329 C Set lprn=.true. for debugging
6330       lprn=.false.
6331       if (lprn) then
6332         write (iout,'(a)') 'Contact function values:'
6333         do i=nnt,nct-2
6334           write (iout,'(2i3,50(1x,i2,f5.2))')
6335      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6336      &    j=1,num_cont_hb(i))
6337         enddo
6338       endif
6339       ecorr=0.0D0
6340 C Remove the loop below after debugging !!!
6341       do i=nnt,nct
6342         do j=1,3
6343           gradcorr(j,i)=0.0D0
6344           gradxorr(j,i)=0.0D0
6345         enddo
6346       enddo
6347 C Calculate the local-electrostatic correlation terms
6348       do i=iatel_s,iatel_e+1
6349         i1=i+1
6350         num_conti=num_cont_hb(i)
6351         num_conti1=num_cont_hb(i+1)
6352         do jj=1,num_conti
6353           j=jcont_hb(jj,i)
6354           do kk=1,num_conti1
6355             j1=jcont_hb(kk,i1)
6356 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6357 c     &         ' jj=',jj,' kk=',kk
6358             if (j1.eq.j+1 .or. j1.eq.j-1) then
6359 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6360 C The system gains extra energy.
6361               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6362               n_corr=n_corr+1
6363             else if (j1.eq.j) then
6364 C Contacts I-J and I-(J+1) occur simultaneously.
6365 C The system loses extra energy.
6366 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6367             endif
6368           enddo ! kk
6369           do kk=1,num_conti
6370             j1=jcont_hb(kk,i)
6371 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6372 c    &         ' jj=',jj,' kk=',kk
6373             if (j1.eq.j+1) then
6374 C Contacts I-J and (I+1)-J occur simultaneously.
6375 C The system loses extra energy.
6376 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6377             endif ! j1==j+1
6378           enddo ! kk
6379         enddo ! jj
6380       enddo ! i
6381       return
6382       end
6383 c------------------------------------------------------------------------------
6384       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6385      &  n_corr1)
6386 C This subroutine calculates multi-body contributions to hydrogen-bonding
6387       implicit real*8 (a-h,o-z)
6388       include 'DIMENSIONS'
6389       include 'COMMON.IOUNITS'
6390 #ifdef MPI
6391       include "mpif.h"
6392 #endif
6393       include 'COMMON.FFIELD'
6394       include 'COMMON.DERIV'
6395       include 'COMMON.LOCAL'
6396       include 'COMMON.INTERACT'
6397       include 'COMMON.CONTACTS'
6398       include 'COMMON.CHAIN'
6399       include 'COMMON.CONTROL'
6400       include 'COMMON.SHIELD'
6401       double precision gx(3),gx1(3)
6402       integer num_cont_hb_old(maxres)
6403       logical lprn,ldone
6404       double precision eello4,eello5,eelo6,eello_turn6
6405       external eello4,eello5,eello6,eello_turn6
6406 C Set lprn=.true. for debugging
6407       lprn=.false.
6408       eturn6=0.0d0
6409       if (lprn) then
6410         write (iout,'(a)') 'Contact function values:'
6411         do i=nnt,nct-2
6412           write (iout,'(2i3,50(1x,i2,5f6.3))')
6413      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6414      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6415         enddo
6416       endif
6417       ecorr=0.0D0
6418       ecorr5=0.0d0
6419       ecorr6=0.0d0
6420 C Remove the loop below after debugging !!!
6421       do i=nnt,nct
6422         do j=1,3
6423           gradcorr(j,i)=0.0D0
6424           gradxorr(j,i)=0.0D0
6425         enddo
6426       enddo
6427 C Calculate the dipole-dipole interaction energies
6428       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6429       do i=iatel_s,iatel_e+1
6430         num_conti=num_cont_hb(i)
6431         do jj=1,num_conti
6432           j=jcont_hb(jj,i)
6433 #ifdef MOMENT
6434           call dipole(i,j,jj)
6435 #endif
6436         enddo
6437       enddo
6438       endif
6439 C Calculate the local-electrostatic correlation terms
6440 c                write (iout,*) "gradcorr5 in eello5 before loop"
6441 c                do iii=1,nres
6442 c                  write (iout,'(i5,3f10.5)')
6443 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6444 c                enddo
6445       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6446 c        write (iout,*) "corr loop i",i
6447         i1=i+1
6448         num_conti=num_cont_hb(i)
6449         num_conti1=num_cont_hb(i+1)
6450         do jj=1,num_conti
6451           j=jcont_hb(jj,i)
6452           jp=iabs(j)
6453           do kk=1,num_conti1
6454             j1=jcont_hb(kk,i1)
6455             jp1=iabs(j1)
6456 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6457 c     &         ' jj=',jj,' kk=',kk
6458 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6459             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6460      &          .or. j.lt.0 .and. j1.gt.0) .and.
6461      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6462 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6463 C The system gains extra energy.
6464               n_corr=n_corr+1
6465               sqd1=dsqrt(d_cont(jj,i))
6466               sqd2=dsqrt(d_cont(kk,i1))
6467               sred_geom = sqd1*sqd2
6468               IF (sred_geom.lt.cutoff_corr) THEN
6469                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6470      &            ekont,fprimcont)
6471 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6472 cd     &         ' jj=',jj,' kk=',kk
6473                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6474                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6475                 do l=1,3
6476                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6477                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6478                 enddo
6479                 n_corr1=n_corr1+1
6480 cd               write (iout,*) 'sred_geom=',sred_geom,
6481 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6482 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6483 cd               write (iout,*) "g_contij",g_contij
6484 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6485 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6486                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6487                 if (wcorr4.gt.0.0d0)
6488      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6489 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6490                   if (energy_dec.and.wcorr4.gt.0.0d0)
6491      1                 write (iout,'(a6,4i5,0pf7.3)')
6492      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6493 c                write (iout,*) "gradcorr5 before eello5"
6494 c                do iii=1,nres
6495 c                  write (iout,'(i5,3f10.5)')
6496 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6497 c                enddo
6498                 if (wcorr5.gt.0.0d0)
6499      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6500 c                write (iout,*) "gradcorr5 after eello5"
6501 c                do iii=1,nres
6502 c                  write (iout,'(i5,3f10.5)')
6503 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6504 c                enddo
6505                   if (energy_dec.and.wcorr5.gt.0.0d0)
6506      1                 write (iout,'(a6,4i5,0pf7.3)')
6507      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6508 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6509 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6510                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6511      &               .or. wturn6.eq.0.0d0))then
6512 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6513                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6514                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6515      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6516 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6517 cd     &            'ecorr6=',ecorr6
6518 cd                write (iout,'(4e15.5)') sred_geom,
6519 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6520 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6521 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6522                 else if (wturn6.gt.0.0d0
6523      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6524 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6525                   eturn6=eturn6+eello_turn6(i,jj,kk)
6526                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6527      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6528 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6529                 endif
6530               ENDIF
6531 1111          continue
6532             endif
6533           enddo ! kk
6534         enddo ! jj
6535       enddo ! i
6536       do i=1,nres
6537         num_cont_hb(i)=num_cont_hb_old(i)
6538       enddo
6539 c                write (iout,*) "gradcorr5 in eello5"
6540 c                do iii=1,nres
6541 c                  write (iout,'(i5,3f10.5)')
6542 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6543 c                enddo
6544       return
6545       end
6546 c------------------------------------------------------------------------------
6547       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6548       implicit real*8 (a-h,o-z)
6549       include 'DIMENSIONS'
6550       include 'COMMON.IOUNITS'
6551       include 'COMMON.DERIV'
6552       include 'COMMON.INTERACT'
6553       include 'COMMON.CONTACTS'
6554       include 'COMMON.SHIELD'
6555       include 'COMMON.CONTROL'
6556       double precision gx(3),gx1(3)
6557       logical lprn
6558       lprn=.false.
6559 C      print *,"wchodze",fac_shield(i),shield_mode
6560       eij=facont_hb(jj,i)
6561       ekl=facont_hb(kk,k)
6562       ees0pij=ees0p(jj,i)
6563       ees0pkl=ees0p(kk,k)
6564       ees0mij=ees0m(jj,i)
6565       ees0mkl=ees0m(kk,k)
6566       ekont=eij*ekl
6567       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6568 C*
6569 C     & fac_shield(i)**2*fac_shield(j)**2
6570 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6571 C Following 4 lines for diagnostics.
6572 cd    ees0pkl=0.0D0
6573 cd    ees0pij=1.0D0
6574 cd    ees0mkl=0.0D0
6575 cd    ees0mij=1.0D0
6576 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6577 c     & 'Contacts ',i,j,
6578 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6579 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6580 c     & 'gradcorr_long'
6581 C Calculate the multi-body contribution to energy.
6582 C      ecorr=ecorr+ekont*ees
6583 C Calculate multi-body contributions to the gradient.
6584       coeffpees0pij=coeffp*ees0pij
6585       coeffmees0mij=coeffm*ees0mij
6586       coeffpees0pkl=coeffp*ees0pkl
6587       coeffmees0mkl=coeffm*ees0mkl
6588       do ll=1,3
6589 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6590         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6591      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6592      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6593         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6594      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6595      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6596 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6597         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6598      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6599      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6600         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6601      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6602      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6603         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6604      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6605      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6606         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6607         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6608         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6609      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6610      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6611         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6612         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6613 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6614       enddo
6615 c      write (iout,*)
6616 cgrad      do m=i+1,j-1
6617 cgrad        do ll=1,3
6618 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6619 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6620 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6621 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6622 cgrad        enddo
6623 cgrad      enddo
6624 cgrad      do m=k+1,l-1
6625 cgrad        do ll=1,3
6626 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6627 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6628 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6629 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6630 cgrad        enddo
6631 cgrad      enddo
6632 c      write (iout,*) "ehbcorr",ekont*ees
6633 C      print *,ekont,ees,i,k
6634       ehbcorr=ekont*ees
6635 C now gradient over shielding
6636 C      return
6637       if (shield_mode.gt.0) then
6638        j=ees0plist(jj,i)
6639        l=ees0plist(kk,k)
6640 C        print *,i,j,fac_shield(i),fac_shield(j),
6641 C     &fac_shield(k),fac_shield(l)
6642         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6643      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6644           do ilist=1,ishield_list(i)
6645            iresshield=shield_list(ilist,i)
6646            do m=1,3
6647            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6648 C     &      *2.0
6649            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6650      &              rlocshield
6651      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6652             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6653      &+rlocshield
6654            enddo
6655           enddo
6656           do ilist=1,ishield_list(j)
6657            iresshield=shield_list(ilist,j)
6658            do m=1,3
6659            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6660 C     &     *2.0
6661            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6662      &              rlocshield
6663      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6664            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6665      &     +rlocshield
6666            enddo
6667           enddo
6668
6669           do ilist=1,ishield_list(k)
6670            iresshield=shield_list(ilist,k)
6671            do m=1,3
6672            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6673 C     &     *2.0
6674            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6675      &              rlocshield
6676      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6677            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6678      &     +rlocshield
6679            enddo
6680           enddo
6681           do ilist=1,ishield_list(l)
6682            iresshield=shield_list(ilist,l)
6683            do m=1,3
6684            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6685 C     &     *2.0
6686            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6687      &              rlocshield
6688      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6689            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6690      &     +rlocshield
6691            enddo
6692           enddo
6693 C          print *,gshieldx(m,iresshield)
6694           do m=1,3
6695             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6696      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6697             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6698      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6699             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6700      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6701             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6702      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6703
6704             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6705      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6706             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6707      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6708             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6709      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6710             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6711      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6712
6713            enddo
6714       endif
6715       endif
6716       return
6717       end
6718 #ifdef MOMENT
6719 C---------------------------------------------------------------------------
6720       subroutine dipole(i,j,jj)
6721       implicit real*8 (a-h,o-z)
6722       include 'DIMENSIONS'
6723       include 'COMMON.IOUNITS'
6724       include 'COMMON.CHAIN'
6725       include 'COMMON.FFIELD'
6726       include 'COMMON.DERIV'
6727       include 'COMMON.INTERACT'
6728       include 'COMMON.CONTACTS'
6729       include 'COMMON.TORSION'
6730       include 'COMMON.VAR'
6731       include 'COMMON.GEO'
6732       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6733      &  auxmat(2,2)
6734       iti1 = itortyp(itype(i+1))
6735       if (j.lt.nres-1) then
6736         itj1 = itype2loc(itype(j+1))
6737       else
6738         itj1=nloctyp
6739       endif
6740       do iii=1,2
6741         dipi(iii,1)=Ub2(iii,i)
6742         dipderi(iii)=Ub2der(iii,i)
6743         dipi(iii,2)=b1(iii,i+1)
6744         dipj(iii,1)=Ub2(iii,j)
6745         dipderj(iii)=Ub2der(iii,j)
6746         dipj(iii,2)=b1(iii,j+1)
6747       enddo
6748       kkk=0
6749       do iii=1,2
6750         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6751         do jjj=1,2
6752           kkk=kkk+1
6753           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6754         enddo
6755       enddo
6756       do kkk=1,5
6757         do lll=1,3
6758           mmm=0
6759           do iii=1,2
6760             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6761      &        auxvec(1))
6762             do jjj=1,2
6763               mmm=mmm+1
6764               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6765             enddo
6766           enddo
6767         enddo
6768       enddo
6769       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6770       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6771       do iii=1,2
6772         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6773       enddo
6774       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6775       do iii=1,2
6776         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6777       enddo
6778       return
6779       end
6780 #endif
6781 C---------------------------------------------------------------------------
6782       subroutine calc_eello(i,j,k,l,jj,kk)
6783 C
6784 C This subroutine computes matrices and vectors needed to calculate
6785 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6786 C
6787       implicit real*8 (a-h,o-z)
6788       include 'DIMENSIONS'
6789       include 'COMMON.IOUNITS'
6790       include 'COMMON.CHAIN'
6791       include 'COMMON.DERIV'
6792       include 'COMMON.INTERACT'
6793       include 'COMMON.CONTACTS'
6794       include 'COMMON.TORSION'
6795       include 'COMMON.VAR'
6796       include 'COMMON.GEO'
6797       include 'COMMON.FFIELD'
6798       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6799      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6800       logical lprn
6801       common /kutas/ lprn
6802 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6803 cd     & ' jj=',jj,' kk=',kk
6804 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6805 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6806 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6807       do iii=1,2
6808         do jjj=1,2
6809           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6810           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6811         enddo
6812       enddo
6813       call transpose2(aa1(1,1),aa1t(1,1))
6814       call transpose2(aa2(1,1),aa2t(1,1))
6815       do kkk=1,5
6816         do lll=1,3
6817           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6818      &      aa1tder(1,1,lll,kkk))
6819           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6820      &      aa2tder(1,1,lll,kkk))
6821         enddo
6822       enddo
6823       if (l.eq.j+1) then
6824 C parallel orientation of the two CA-CA-CA frames.
6825         if (i.gt.1) then
6826           iti=itype2loc(itype(i))
6827         else
6828           iti=nloctyp
6829         endif
6830         itk1=itype2loc(itype(k+1))
6831         itj=itype2loc(itype(j))
6832         if (l.lt.nres-1) then
6833           itl1=itype2loc(itype(l+1))
6834         else
6835           itl1=nloctyp
6836         endif
6837 C A1 kernel(j+1) A2T
6838 cd        do iii=1,2
6839 cd          write (iout,'(3f10.5,5x,3f10.5)')
6840 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6841 cd        enddo
6842         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6843      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6844      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6845 C Following matrices are needed only for 6-th order cumulants
6846         IF (wcorr6.gt.0.0d0) THEN
6847         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6848      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6849      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6850         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6851      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6852      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6853      &   ADtEAderx(1,1,1,1,1,1))
6854         lprn=.false.
6855         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6856      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6857      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6858      &   ADtEA1derx(1,1,1,1,1,1))
6859         ENDIF
6860 C End 6-th order cumulants
6861 cd        lprn=.false.
6862 cd        if (lprn) then
6863 cd        write (2,*) 'In calc_eello6'
6864 cd        do iii=1,2
6865 cd          write (2,*) 'iii=',iii
6866 cd          do kkk=1,5
6867 cd            write (2,*) 'kkk=',kkk
6868 cd            do jjj=1,2
6869 cd              write (2,'(3(2f10.5),5x)')
6870 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6871 cd            enddo
6872 cd          enddo
6873 cd        enddo
6874 cd        endif
6875         call transpose2(EUgder(1,1,k),auxmat(1,1))
6876         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6877         call transpose2(EUg(1,1,k),auxmat(1,1))
6878         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6879         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6880         do iii=1,2
6881           do kkk=1,5
6882             do lll=1,3
6883               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6884      &          EAEAderx(1,1,lll,kkk,iii,1))
6885             enddo
6886           enddo
6887         enddo
6888 C A1T kernel(i+1) A2
6889         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6890      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6891      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6892 C Following matrices are needed only for 6-th order cumulants
6893         IF (wcorr6.gt.0.0d0) THEN
6894         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6895      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6896      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6897         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6898      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6899      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6900      &   ADtEAderx(1,1,1,1,1,2))
6901         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6902      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6903      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6904      &   ADtEA1derx(1,1,1,1,1,2))
6905         ENDIF
6906 C End 6-th order cumulants
6907         call transpose2(EUgder(1,1,l),auxmat(1,1))
6908         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6909         call transpose2(EUg(1,1,l),auxmat(1,1))
6910         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6911         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6912         do iii=1,2
6913           do kkk=1,5
6914             do lll=1,3
6915               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6916      &          EAEAderx(1,1,lll,kkk,iii,2))
6917             enddo
6918           enddo
6919         enddo
6920 C AEAb1 and AEAb2
6921 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6922 C They are needed only when the fifth- or the sixth-order cumulants are
6923 C indluded.
6924         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6925         call transpose2(AEA(1,1,1),auxmat(1,1))
6926         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6927         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6928         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6929         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6930         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6931         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6932         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6933         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6934         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6935         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6936         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6937         call transpose2(AEA(1,1,2),auxmat(1,1))
6938         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6939         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6940         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6941         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6942         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6943         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6944         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6945         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6946         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6947         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6948         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6949 C Calculate the Cartesian derivatives of the vectors.
6950         do iii=1,2
6951           do kkk=1,5
6952             do lll=1,3
6953               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6954               call matvec2(auxmat(1,1),b1(1,i),
6955      &          AEAb1derx(1,lll,kkk,iii,1,1))
6956               call matvec2(auxmat(1,1),Ub2(1,i),
6957      &          AEAb2derx(1,lll,kkk,iii,1,1))
6958               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6959      &          AEAb1derx(1,lll,kkk,iii,2,1))
6960               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6961      &          AEAb2derx(1,lll,kkk,iii,2,1))
6962               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6963               call matvec2(auxmat(1,1),b1(1,j),
6964      &          AEAb1derx(1,lll,kkk,iii,1,2))
6965               call matvec2(auxmat(1,1),Ub2(1,j),
6966      &          AEAb2derx(1,lll,kkk,iii,1,2))
6967               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6968      &          AEAb1derx(1,lll,kkk,iii,2,2))
6969               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6970      &          AEAb2derx(1,lll,kkk,iii,2,2))
6971             enddo
6972           enddo
6973         enddo
6974         ENDIF
6975 C End vectors
6976       else
6977 C Antiparallel orientation of the two CA-CA-CA frames.
6978         if (i.gt.1) then
6979           iti=itype2loc(itype(i))
6980         else
6981           iti=nloctyp
6982         endif
6983         itk1=itype2loc(itype(k+1))
6984         itl=itype2loc(itype(l))
6985         itj=itype2loc(itype(j))
6986         if (j.lt.nres-1) then
6987           itj1=itype2loc(itype(j+1))
6988         else
6989           itj1=nloctyp
6990         endif
6991 C A2 kernel(j-1)T A1T
6992         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6993      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6994      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6995 C Following matrices are needed only for 6-th order cumulants
6996         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6997      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6998         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6999      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7000      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7001         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7002      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7003      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7004      &   ADtEAderx(1,1,1,1,1,1))
7005         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7006      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7007      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7008      &   ADtEA1derx(1,1,1,1,1,1))
7009         ENDIF
7010 C End 6-th order cumulants
7011         call transpose2(EUgder(1,1,k),auxmat(1,1))
7012         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7013         call transpose2(EUg(1,1,k),auxmat(1,1))
7014         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7015         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7016         do iii=1,2
7017           do kkk=1,5
7018             do lll=1,3
7019               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7020      &          EAEAderx(1,1,lll,kkk,iii,1))
7021             enddo
7022           enddo
7023         enddo
7024 C A2T kernel(i+1)T A1
7025         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7026      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7027      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7028 C Following matrices are needed only for 6-th order cumulants
7029         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7030      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7031         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7032      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7033      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7034         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7035      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7036      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7037      &   ADtEAderx(1,1,1,1,1,2))
7038         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7039      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7040      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7041      &   ADtEA1derx(1,1,1,1,1,2))
7042         ENDIF
7043 C End 6-th order cumulants
7044         call transpose2(EUgder(1,1,j),auxmat(1,1))
7045         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7046         call transpose2(EUg(1,1,j),auxmat(1,1))
7047         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7048         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7049         do iii=1,2
7050           do kkk=1,5
7051             do lll=1,3
7052               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7053      &          EAEAderx(1,1,lll,kkk,iii,2))
7054             enddo
7055           enddo
7056         enddo
7057 C AEAb1 and AEAb2
7058 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7059 C They are needed only when the fifth- or the sixth-order cumulants are
7060 C indluded.
7061         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7062      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7063         call transpose2(AEA(1,1,1),auxmat(1,1))
7064         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7065         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7066         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7067         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7068         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7069         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7070         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7071         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7072         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7073         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7074         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7075         call transpose2(AEA(1,1,2),auxmat(1,1))
7076         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7077         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7078         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7079         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7080         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7081         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7082         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7083         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7084         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7085         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7086         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7087 C Calculate the Cartesian derivatives of the vectors.
7088         do iii=1,2
7089           do kkk=1,5
7090             do lll=1,3
7091               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7092               call matvec2(auxmat(1,1),b1(1,i),
7093      &          AEAb1derx(1,lll,kkk,iii,1,1))
7094               call matvec2(auxmat(1,1),Ub2(1,i),
7095      &          AEAb2derx(1,lll,kkk,iii,1,1))
7096               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7097      &          AEAb1derx(1,lll,kkk,iii,2,1))
7098               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7099      &          AEAb2derx(1,lll,kkk,iii,2,1))
7100               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7101               call matvec2(auxmat(1,1),b1(1,l),
7102      &          AEAb1derx(1,lll,kkk,iii,1,2))
7103               call matvec2(auxmat(1,1),Ub2(1,l),
7104      &          AEAb2derx(1,lll,kkk,iii,1,2))
7105               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7106      &          AEAb1derx(1,lll,kkk,iii,2,2))
7107               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7108      &          AEAb2derx(1,lll,kkk,iii,2,2))
7109             enddo
7110           enddo
7111         enddo
7112         ENDIF
7113 C End vectors
7114       endif
7115       return
7116       end
7117 C---------------------------------------------------------------------------
7118       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7119      &  KK,KKderg,AKA,AKAderg,AKAderx)
7120       implicit none
7121       integer nderg
7122       logical transp
7123       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7124      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7125      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7126       integer iii,kkk,lll
7127       integer jjj,mmm
7128       logical lprn
7129       common /kutas/ lprn
7130       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7131       do iii=1,nderg
7132         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7133      &    AKAderg(1,1,iii))
7134       enddo
7135 cd      if (lprn) write (2,*) 'In kernel'
7136       do kkk=1,5
7137 cd        if (lprn) write (2,*) 'kkk=',kkk
7138         do lll=1,3
7139           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7140      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7141 cd          if (lprn) then
7142 cd            write (2,*) 'lll=',lll
7143 cd            write (2,*) 'iii=1'
7144 cd            do jjj=1,2
7145 cd              write (2,'(3(2f10.5),5x)')
7146 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7147 cd            enddo
7148 cd          endif
7149           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7150      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7151 cd          if (lprn) then
7152 cd            write (2,*) 'lll=',lll
7153 cd            write (2,*) 'iii=2'
7154 cd            do jjj=1,2
7155 cd              write (2,'(3(2f10.5),5x)')
7156 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7157 cd            enddo
7158 cd          endif
7159         enddo
7160       enddo
7161       return
7162       end
7163 C---------------------------------------------------------------------------
7164       double precision function eello4(i,j,k,l,jj,kk)
7165       implicit real*8 (a-h,o-z)
7166       include 'DIMENSIONS'
7167       include 'COMMON.IOUNITS'
7168       include 'COMMON.CHAIN'
7169       include 'COMMON.DERIV'
7170       include 'COMMON.INTERACT'
7171       include 'COMMON.CONTACTS'
7172       include 'COMMON.TORSION'
7173       include 'COMMON.VAR'
7174       include 'COMMON.GEO'
7175       double precision pizda(2,2),ggg1(3),ggg2(3)
7176 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7177 cd        eello4=0.0d0
7178 cd        return
7179 cd      endif
7180 cd      print *,'eello4:',i,j,k,l,jj,kk
7181 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7182 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7183 cold      eij=facont_hb(jj,i)
7184 cold      ekl=facont_hb(kk,k)
7185 cold      ekont=eij*ekl
7186       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7187       if (calc_grad) then
7188 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7189       gcorr_loc(k-1)=gcorr_loc(k-1)
7190      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7191       if (l.eq.j+1) then
7192         gcorr_loc(l-1)=gcorr_loc(l-1)
7193      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7194       else
7195         gcorr_loc(j-1)=gcorr_loc(j-1)
7196      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7197       endif
7198       do iii=1,2
7199         do kkk=1,5
7200           do lll=1,3
7201             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7202      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7203 cd            derx(lll,kkk,iii)=0.0d0
7204           enddo
7205         enddo
7206       enddo
7207 cd      gcorr_loc(l-1)=0.0d0
7208 cd      gcorr_loc(j-1)=0.0d0
7209 cd      gcorr_loc(k-1)=0.0d0
7210 cd      eel4=1.0d0
7211 cd      write (iout,*)'Contacts have occurred for peptide groups',
7212 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7213 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7214       if (j.lt.nres-1) then
7215         j1=j+1
7216         j2=j-1
7217       else
7218         j1=j-1
7219         j2=j-2
7220       endif
7221       if (l.lt.nres-1) then
7222         l1=l+1
7223         l2=l-1
7224       else
7225         l1=l-1
7226         l2=l-2
7227       endif
7228       do ll=1,3
7229 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7230 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7231         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7232         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7233 cgrad        ghalf=0.5d0*ggg1(ll)
7234         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7235         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7236         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7237         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7238         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7239         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7240 cgrad        ghalf=0.5d0*ggg2(ll)
7241         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7242         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7243         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7244         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7245         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7246         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7247       enddo
7248 cgrad      do m=i+1,j-1
7249 cgrad        do ll=1,3
7250 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7251 cgrad        enddo
7252 cgrad      enddo
7253 cgrad      do m=k+1,l-1
7254 cgrad        do ll=1,3
7255 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7256 cgrad        enddo
7257 cgrad      enddo
7258 cgrad      do m=i+2,j2
7259 cgrad        do ll=1,3
7260 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7261 cgrad        enddo
7262 cgrad      enddo
7263 cgrad      do m=k+2,l2
7264 cgrad        do ll=1,3
7265 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7266 cgrad        enddo
7267 cgrad      enddo
7268 cd      do iii=1,nres-3
7269 cd        write (2,*) iii,gcorr_loc(iii)
7270 cd      enddo
7271       endif ! calc_grad
7272       eello4=ekont*eel4
7273 cd      write (2,*) 'ekont',ekont
7274 cd      write (iout,*) 'eello4',ekont*eel4
7275       return
7276       end
7277 C---------------------------------------------------------------------------
7278       double precision function eello5(i,j,k,l,jj,kk)
7279       implicit real*8 (a-h,o-z)
7280       include 'DIMENSIONS'
7281       include 'COMMON.IOUNITS'
7282       include 'COMMON.CHAIN'
7283       include 'COMMON.DERIV'
7284       include 'COMMON.INTERACT'
7285       include 'COMMON.CONTACTS'
7286       include 'COMMON.TORSION'
7287       include 'COMMON.VAR'
7288       include 'COMMON.GEO'
7289       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7290       double precision ggg1(3),ggg2(3)
7291 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7292 C                                                                              C
7293 C                            Parallel chains                                   C
7294 C                                                                              C
7295 C          o             o                   o             o                   C
7296 C         /l\           / \             \   / \           / \   /              C
7297 C        /   \         /   \             \ /   \         /   \ /               C
7298 C       j| o |l1       | o |              o| o |         | o |o                C
7299 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7300 C      \i/   \         /   \ /             /   \         /   \                 C
7301 C       o    k1             o                                                  C
7302 C         (I)          (II)                (III)          (IV)                 C
7303 C                                                                              C
7304 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7305 C                                                                              C
7306 C                            Antiparallel chains                               C
7307 C                                                                              C
7308 C          o             o                   o             o                   C
7309 C         /j\           / \             \   / \           / \   /              C
7310 C        /   \         /   \             \ /   \         /   \ /               C
7311 C      j1| o |l        | o |              o| o |         | o |o                C
7312 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7313 C      \i/   \         /   \ /             /   \         /   \                 C
7314 C       o     k1            o                                                  C
7315 C         (I)          (II)                (III)          (IV)                 C
7316 C                                                                              C
7317 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7318 C                                                                              C
7319 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7320 C                                                                              C
7321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7322 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7323 cd        eello5=0.0d0
7324 cd        return
7325 cd      endif
7326 cd      write (iout,*)
7327 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7328 cd     &   ' and',k,l
7329       itk=itype2loc(itype(k))
7330       itl=itype2loc(itype(l))
7331       itj=itype2loc(itype(j))
7332       eello5_1=0.0d0
7333       eello5_2=0.0d0
7334       eello5_3=0.0d0
7335       eello5_4=0.0d0
7336 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7337 cd     &   eel5_3_num,eel5_4_num)
7338       do iii=1,2
7339         do kkk=1,5
7340           do lll=1,3
7341             derx(lll,kkk,iii)=0.0d0
7342           enddo
7343         enddo
7344       enddo
7345 cd      eij=facont_hb(jj,i)
7346 cd      ekl=facont_hb(kk,k)
7347 cd      ekont=eij*ekl
7348 cd      write (iout,*)'Contacts have occurred for peptide groups',
7349 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7350 cd      goto 1111
7351 C Contribution from the graph I.
7352 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7353 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7354       call transpose2(EUg(1,1,k),auxmat(1,1))
7355       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7356       vv(1)=pizda(1,1)-pizda(2,2)
7357       vv(2)=pizda(1,2)+pizda(2,1)
7358       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7359      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7360       if (calc_grad) then
7361 C Explicit gradient in virtual-dihedral angles.
7362       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7363      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7364      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7365       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7366       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7367       vv(1)=pizda(1,1)-pizda(2,2)
7368       vv(2)=pizda(1,2)+pizda(2,1)
7369       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7370      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7371      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7372       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7373       vv(1)=pizda(1,1)-pizda(2,2)
7374       vv(2)=pizda(1,2)+pizda(2,1)
7375       if (l.eq.j+1) then
7376         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7377      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7378      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7379       else
7380         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7381      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7382      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7383       endif
7384 C Cartesian gradient
7385       do iii=1,2
7386         do kkk=1,5
7387           do lll=1,3
7388             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7389      &        pizda(1,1))
7390             vv(1)=pizda(1,1)-pizda(2,2)
7391             vv(2)=pizda(1,2)+pizda(2,1)
7392             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7393      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7394      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7395           enddo
7396         enddo
7397       enddo
7398       endif ! calc_grad
7399 c      goto 1112
7400 c1111  continue
7401 C Contribution from graph II
7402       call transpose2(EE(1,1,k),auxmat(1,1))
7403       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7404       vv(1)=pizda(1,1)+pizda(2,2)
7405       vv(2)=pizda(2,1)-pizda(1,2)
7406       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7407      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7408       if (calc_grad) then
7409 C Explicit gradient in virtual-dihedral angles.
7410       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7411      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7412       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7413       vv(1)=pizda(1,1)+pizda(2,2)
7414       vv(2)=pizda(2,1)-pizda(1,2)
7415       if (l.eq.j+1) then
7416         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7417      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7418      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7419       else
7420         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7421      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7422      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7423       endif
7424 C Cartesian gradient
7425       do iii=1,2
7426         do kkk=1,5
7427           do lll=1,3
7428             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7429      &        pizda(1,1))
7430             vv(1)=pizda(1,1)+pizda(2,2)
7431             vv(2)=pizda(2,1)-pizda(1,2)
7432             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7433      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7434      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7435           enddo
7436         enddo
7437       enddo
7438       endif ! calc_grad
7439 cd      goto 1112
7440 cd1111  continue
7441       if (l.eq.j+1) then
7442 cd        goto 1110
7443 C Parallel orientation
7444 C Contribution from graph III
7445         call transpose2(EUg(1,1,l),auxmat(1,1))
7446         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7447         vv(1)=pizda(1,1)-pizda(2,2)
7448         vv(2)=pizda(1,2)+pizda(2,1)
7449         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7450      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7451         if (calc_grad) then
7452 C Explicit gradient in virtual-dihedral angles.
7453         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7454      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7455      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7456         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7457         vv(1)=pizda(1,1)-pizda(2,2)
7458         vv(2)=pizda(1,2)+pizda(2,1)
7459         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7460      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7461      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7462         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7463         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7464         vv(1)=pizda(1,1)-pizda(2,2)
7465         vv(2)=pizda(1,2)+pizda(2,1)
7466         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7467      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7468      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7469 C Cartesian gradient
7470         do iii=1,2
7471           do kkk=1,5
7472             do lll=1,3
7473               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7474      &          pizda(1,1))
7475               vv(1)=pizda(1,1)-pizda(2,2)
7476               vv(2)=pizda(1,2)+pizda(2,1)
7477               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7478      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7479      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7480             enddo
7481           enddo
7482         enddo
7483 cd        goto 1112
7484 C Contribution from graph IV
7485 cd1110    continue
7486         call transpose2(EE(1,1,l),auxmat(1,1))
7487         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7488         vv(1)=pizda(1,1)+pizda(2,2)
7489         vv(2)=pizda(2,1)-pizda(1,2)
7490         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7491      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7492 C Explicit gradient in virtual-dihedral angles.
7493         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7494      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7495         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7496         vv(1)=pizda(1,1)+pizda(2,2)
7497         vv(2)=pizda(2,1)-pizda(1,2)
7498         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7499      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7500      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7501 C Cartesian gradient
7502         do iii=1,2
7503           do kkk=1,5
7504             do lll=1,3
7505               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7506      &          pizda(1,1))
7507               vv(1)=pizda(1,1)+pizda(2,2)
7508               vv(2)=pizda(2,1)-pizda(1,2)
7509               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7510      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7511      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7512             enddo
7513           enddo
7514         enddo
7515         endif ! calc_grad
7516       else
7517 C Antiparallel orientation
7518 C Contribution from graph III
7519 c        goto 1110
7520         call transpose2(EUg(1,1,j),auxmat(1,1))
7521         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7522         vv(1)=pizda(1,1)-pizda(2,2)
7523         vv(2)=pizda(1,2)+pizda(2,1)
7524         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7525      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7526         if (calc_grad) then
7527 C Explicit gradient in virtual-dihedral angles.
7528         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7529      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7530      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7531         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7532         vv(1)=pizda(1,1)-pizda(2,2)
7533         vv(2)=pizda(1,2)+pizda(2,1)
7534         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7535      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7536      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7537         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7538         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7539         vv(1)=pizda(1,1)-pizda(2,2)
7540         vv(2)=pizda(1,2)+pizda(2,1)
7541         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7542      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7544 C Cartesian gradient
7545         do iii=1,2
7546           do kkk=1,5
7547             do lll=1,3
7548               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7549      &          pizda(1,1))
7550               vv(1)=pizda(1,1)-pizda(2,2)
7551               vv(2)=pizda(1,2)+pizda(2,1)
7552               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7553      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7554      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7555             enddo
7556           enddo
7557         enddo
7558         endif ! calc_grad
7559 cd        goto 1112
7560 C Contribution from graph IV
7561 1110    continue
7562         call transpose2(EE(1,1,j),auxmat(1,1))
7563         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7564         vv(1)=pizda(1,1)+pizda(2,2)
7565         vv(2)=pizda(2,1)-pizda(1,2)
7566         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7567      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7568         if (calc_grad) then
7569 C Explicit gradient in virtual-dihedral angles.
7570         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7571      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7572         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7573         vv(1)=pizda(1,1)+pizda(2,2)
7574         vv(2)=pizda(2,1)-pizda(1,2)
7575         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7576      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7577      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7578 C Cartesian gradient
7579         do iii=1,2
7580           do kkk=1,5
7581             do lll=1,3
7582               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7583      &          pizda(1,1))
7584               vv(1)=pizda(1,1)+pizda(2,2)
7585               vv(2)=pizda(2,1)-pizda(1,2)
7586               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7587      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7588      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7589             enddo
7590           enddo
7591         enddo
7592         endif ! calc_grad
7593       endif
7594 1112  continue
7595       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7596 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7597 cd        write (2,*) 'ijkl',i,j,k,l
7598 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7599 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7600 cd      endif
7601 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7602 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7603 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7604 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7605       if (calc_grad) then
7606       if (j.lt.nres-1) then
7607         j1=j+1
7608         j2=j-1
7609       else
7610         j1=j-1
7611         j2=j-2
7612       endif
7613       if (l.lt.nres-1) then
7614         l1=l+1
7615         l2=l-1
7616       else
7617         l1=l-1
7618         l2=l-2
7619       endif
7620 cd      eij=1.0d0
7621 cd      ekl=1.0d0
7622 cd      ekont=1.0d0
7623 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7624 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7625 C        summed up outside the subrouine as for the other subroutines
7626 C        handling long-range interactions. The old code is commented out
7627 C        with "cgrad" to keep track of changes.
7628       do ll=1,3
7629 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7630 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7631         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7632         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7633 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7634 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7635 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7636 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7637 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7638 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7639 c     &   gradcorr5ij,
7640 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7641 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7642 cgrad        ghalf=0.5d0*ggg1(ll)
7643 cd        ghalf=0.0d0
7644         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7645         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7646         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7647         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7648         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7649         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7650 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7651 cgrad        ghalf=0.5d0*ggg2(ll)
7652 cd        ghalf=0.0d0
7653         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7654         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7655         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7656         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7657         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7658         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7659       enddo
7660       endif ! calc_grad
7661 cd      goto 1112
7662 cgrad      do m=i+1,j-1
7663 cgrad        do ll=1,3
7664 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7665 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7666 cgrad        enddo
7667 cgrad      enddo
7668 cgrad      do m=k+1,l-1
7669 cgrad        do ll=1,3
7670 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7671 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7672 cgrad        enddo
7673 cgrad      enddo
7674 c1112  continue
7675 cgrad      do m=i+2,j2
7676 cgrad        do ll=1,3
7677 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7678 cgrad        enddo
7679 cgrad      enddo
7680 cgrad      do m=k+2,l2
7681 cgrad        do ll=1,3
7682 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7683 cgrad        enddo
7684 cgrad      enddo
7685 cd      do iii=1,nres-3
7686 cd        write (2,*) iii,g_corr5_loc(iii)
7687 cd      enddo
7688       eello5=ekont*eel5
7689 cd      write (2,*) 'ekont',ekont
7690 cd      write (iout,*) 'eello5',ekont*eel5
7691       return
7692       end
7693 c--------------------------------------------------------------------------
7694       double precision function eello6(i,j,k,l,jj,kk)
7695       implicit real*8 (a-h,o-z)
7696       include 'DIMENSIONS'
7697       include 'COMMON.IOUNITS'
7698       include 'COMMON.CHAIN'
7699       include 'COMMON.DERIV'
7700       include 'COMMON.INTERACT'
7701       include 'COMMON.CONTACTS'
7702       include 'COMMON.TORSION'
7703       include 'COMMON.VAR'
7704       include 'COMMON.GEO'
7705       include 'COMMON.FFIELD'
7706       double precision ggg1(3),ggg2(3)
7707 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7708 cd        eello6=0.0d0
7709 cd        return
7710 cd      endif
7711 cd      write (iout,*)
7712 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7713 cd     &   ' and',k,l
7714       eello6_1=0.0d0
7715       eello6_2=0.0d0
7716       eello6_3=0.0d0
7717       eello6_4=0.0d0
7718       eello6_5=0.0d0
7719       eello6_6=0.0d0
7720 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7721 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7722       do iii=1,2
7723         do kkk=1,5
7724           do lll=1,3
7725             derx(lll,kkk,iii)=0.0d0
7726           enddo
7727         enddo
7728       enddo
7729 cd      eij=facont_hb(jj,i)
7730 cd      ekl=facont_hb(kk,k)
7731 cd      ekont=eij*ekl
7732 cd      eij=1.0d0
7733 cd      ekl=1.0d0
7734 cd      ekont=1.0d0
7735       if (l.eq.j+1) then
7736         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7737         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7738         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7739         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7740         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7741         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7742       else
7743         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7744         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7745         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7746         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7747         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7748           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7749         else
7750           eello6_5=0.0d0
7751         endif
7752         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7753       endif
7754 C If turn contributions are considered, they will be handled separately.
7755       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7756 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7757 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7758 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7759 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7760 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7761 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7762 cd      goto 1112
7763       if (calc_grad) then
7764       if (j.lt.nres-1) then
7765         j1=j+1
7766         j2=j-1
7767       else
7768         j1=j-1
7769         j2=j-2
7770       endif
7771       if (l.lt.nres-1) then
7772         l1=l+1
7773         l2=l-1
7774       else
7775         l1=l-1
7776         l2=l-2
7777       endif
7778       do ll=1,3
7779 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7780 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7781 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7782 cgrad        ghalf=0.5d0*ggg1(ll)
7783 cd        ghalf=0.0d0
7784         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7785         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7786         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7787         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7788         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7789         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7790         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7791         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7792 cgrad        ghalf=0.5d0*ggg2(ll)
7793 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7794 cd        ghalf=0.0d0
7795         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7796         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7797         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7798         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7799         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7800         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7801       enddo
7802       endif ! calc_grad
7803 cd      goto 1112
7804 cgrad      do m=i+1,j-1
7805 cgrad        do ll=1,3
7806 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7807 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7808 cgrad        enddo
7809 cgrad      enddo
7810 cgrad      do m=k+1,l-1
7811 cgrad        do ll=1,3
7812 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7813 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7814 cgrad        enddo
7815 cgrad      enddo
7816 cgrad1112  continue
7817 cgrad      do m=i+2,j2
7818 cgrad        do ll=1,3
7819 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7820 cgrad        enddo
7821 cgrad      enddo
7822 cgrad      do m=k+2,l2
7823 cgrad        do ll=1,3
7824 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7825 cgrad        enddo
7826 cgrad      enddo
7827 cd      do iii=1,nres-3
7828 cd        write (2,*) iii,g_corr6_loc(iii)
7829 cd      enddo
7830       eello6=ekont*eel6
7831 cd      write (2,*) 'ekont',ekont
7832 cd      write (iout,*) 'eello6',ekont*eel6
7833       return
7834       end
7835 c--------------------------------------------------------------------------
7836       double precision function eello6_graph1(i,j,k,l,imat,swap)
7837       implicit real*8 (a-h,o-z)
7838       include 'DIMENSIONS'
7839       include 'COMMON.IOUNITS'
7840       include 'COMMON.CHAIN'
7841       include 'COMMON.DERIV'
7842       include 'COMMON.INTERACT'
7843       include 'COMMON.CONTACTS'
7844       include 'COMMON.TORSION'
7845       include 'COMMON.VAR'
7846       include 'COMMON.GEO'
7847       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7848       logical swap
7849       logical lprn
7850       common /kutas/ lprn
7851 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7852 C                                                                              C
7853 C      Parallel       Antiparallel                                             C
7854 C                                                                              C
7855 C          o             o                                                     C
7856 C         /l\           /j\                                                    C
7857 C        /   \         /   \                                                   C
7858 C       /| o |         | o |\                                                  C
7859 C     \ j|/k\|  /   \  |/k\|l /                                                C
7860 C      \ /   \ /     \ /   \ /                                                 C
7861 C       o     o       o     o                                                  C
7862 C       i             i                                                        C
7863 C                                                                              C
7864 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7865       itk=itype2loc(itype(k))
7866       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7867       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7868       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7869       call transpose2(EUgC(1,1,k),auxmat(1,1))
7870       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7871       vv1(1)=pizda1(1,1)-pizda1(2,2)
7872       vv1(2)=pizda1(1,2)+pizda1(2,1)
7873       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7874       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7875       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7876       s5=scalar2(vv(1),Dtobr2(1,i))
7877 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7878       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7879       if (calc_grad) then
7880       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7881      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7882      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7883      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7884      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7885      & +scalar2(vv(1),Dtobr2der(1,i)))
7886       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7887       vv1(1)=pizda1(1,1)-pizda1(2,2)
7888       vv1(2)=pizda1(1,2)+pizda1(2,1)
7889       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7890       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7891       if (l.eq.j+1) then
7892         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7893      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7894      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7895      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7896      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7897       else
7898         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7899      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7900      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7901      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7902      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7903       endif
7904       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7905       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7906       vv1(1)=pizda1(1,1)-pizda1(2,2)
7907       vv1(2)=pizda1(1,2)+pizda1(2,1)
7908       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7909      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7910      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7911      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7912       do iii=1,2
7913         if (swap) then
7914           ind=3-iii
7915         else
7916           ind=iii
7917         endif
7918         do kkk=1,5
7919           do lll=1,3
7920             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7921             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7922             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7923             call transpose2(EUgC(1,1,k),auxmat(1,1))
7924             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7925      &        pizda1(1,1))
7926             vv1(1)=pizda1(1,1)-pizda1(2,2)
7927             vv1(2)=pizda1(1,2)+pizda1(2,1)
7928             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7929             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7930      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7931             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7932      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7933             s5=scalar2(vv(1),Dtobr2(1,i))
7934             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7935           enddo
7936         enddo
7937       enddo
7938       endif ! calc_grad
7939       return
7940       end
7941 c----------------------------------------------------------------------------
7942       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7943       implicit real*8 (a-h,o-z)
7944       include 'DIMENSIONS'
7945       include 'COMMON.IOUNITS'
7946       include 'COMMON.CHAIN'
7947       include 'COMMON.DERIV'
7948       include 'COMMON.INTERACT'
7949       include 'COMMON.CONTACTS'
7950       include 'COMMON.TORSION'
7951       include 'COMMON.VAR'
7952       include 'COMMON.GEO'
7953       logical swap
7954       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7955      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7956       logical lprn
7957       common /kutas/ lprn
7958 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7959 C                                                                              C
7960 C      Parallel       Antiparallel                                             C
7961 C                                                                              C
7962 C          o             o                                                     C
7963 C     \   /l\           /j\   /                                                C
7964 C      \ /   \         /   \ /                                                 C
7965 C       o| o |         | o |o                                                  C
7966 C     \ j|/k\|      \  |/k\|l                                                  C
7967 C      \ /   \       \ /   \                                                   C
7968 C       o             o                                                        C
7969 C       i             i                                                        C
7970 C                                                                              C
7971 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7972 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7973 C AL 7/4/01 s1 would occur in the sixth-order moment,
7974 C           but not in a cluster cumulant
7975 #ifdef MOMENT
7976       s1=dip(1,jj,i)*dip(1,kk,k)
7977 #endif
7978       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7979       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7980       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7981       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7982       call transpose2(EUg(1,1,k),auxmat(1,1))
7983       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7984       vv(1)=pizda(1,1)-pizda(2,2)
7985       vv(2)=pizda(1,2)+pizda(2,1)
7986       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7987 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7988 #ifdef MOMENT
7989       eello6_graph2=-(s1+s2+s3+s4)
7990 #else
7991       eello6_graph2=-(s2+s3+s4)
7992 #endif
7993 c      eello6_graph2=-s3
7994 C Derivatives in gamma(i-1)
7995       if (calc_grad) then
7996       if (i.gt.1) then
7997 #ifdef MOMENT
7998         s1=dipderg(1,jj,i)*dip(1,kk,k)
7999 #endif
8000         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8001         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8002         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8003         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8004 #ifdef MOMENT
8005         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8006 #else
8007         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8008 #endif
8009 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8010       endif
8011 C Derivatives in gamma(k-1)
8012 #ifdef MOMENT
8013       s1=dip(1,jj,i)*dipderg(1,kk,k)
8014 #endif
8015       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8016       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8017       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8018       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8019       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8020       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8021       vv(1)=pizda(1,1)-pizda(2,2)
8022       vv(2)=pizda(1,2)+pizda(2,1)
8023       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8024 #ifdef MOMENT
8025       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8026 #else
8027       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8028 #endif
8029 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8030 C Derivatives in gamma(j-1) or gamma(l-1)
8031       if (j.gt.1) then
8032 #ifdef MOMENT
8033         s1=dipderg(3,jj,i)*dip(1,kk,k)
8034 #endif
8035         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8036         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8037         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8038         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8039         vv(1)=pizda(1,1)-pizda(2,2)
8040         vv(2)=pizda(1,2)+pizda(2,1)
8041         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8042 #ifdef MOMENT
8043         if (swap) then
8044           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8045         else
8046           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8047         endif
8048 #endif
8049         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8050 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8051       endif
8052 C Derivatives in gamma(l-1) or gamma(j-1)
8053       if (l.gt.1) then
8054 #ifdef MOMENT
8055         s1=dip(1,jj,i)*dipderg(3,kk,k)
8056 #endif
8057         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8058         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8059         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8060         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8061         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8062         vv(1)=pizda(1,1)-pizda(2,2)
8063         vv(2)=pizda(1,2)+pizda(2,1)
8064         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8065 #ifdef MOMENT
8066         if (swap) then
8067           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8068         else
8069           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8070         endif
8071 #endif
8072         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8073 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8074       endif
8075 C Cartesian derivatives.
8076       if (lprn) then
8077         write (2,*) 'In eello6_graph2'
8078         do iii=1,2
8079           write (2,*) 'iii=',iii
8080           do kkk=1,5
8081             write (2,*) 'kkk=',kkk
8082             do jjj=1,2
8083               write (2,'(3(2f10.5),5x)')
8084      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8085             enddo
8086           enddo
8087         enddo
8088       endif
8089       do iii=1,2
8090         do kkk=1,5
8091           do lll=1,3
8092 #ifdef MOMENT
8093             if (iii.eq.1) then
8094               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8095             else
8096               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8097             endif
8098 #endif
8099             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8100      &        auxvec(1))
8101             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8102             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8103      &        auxvec(1))
8104             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8105             call transpose2(EUg(1,1,k),auxmat(1,1))
8106             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8107      &        pizda(1,1))
8108             vv(1)=pizda(1,1)-pizda(2,2)
8109             vv(2)=pizda(1,2)+pizda(2,1)
8110             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8111 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8112 #ifdef MOMENT
8113             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8114 #else
8115             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8116 #endif
8117             if (swap) then
8118               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8119             else
8120               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8121             endif
8122           enddo
8123         enddo
8124       enddo
8125       endif ! calc_grad
8126       return
8127       end
8128 c----------------------------------------------------------------------------
8129       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8130       implicit real*8 (a-h,o-z)
8131       include 'DIMENSIONS'
8132       include 'COMMON.IOUNITS'
8133       include 'COMMON.CHAIN'
8134       include 'COMMON.DERIV'
8135       include 'COMMON.INTERACT'
8136       include 'COMMON.CONTACTS'
8137       include 'COMMON.TORSION'
8138       include 'COMMON.VAR'
8139       include 'COMMON.GEO'
8140       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8141       logical swap
8142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8143 C                                                                              C
8144 C      Parallel       Antiparallel                                             C
8145 C                                                                              C
8146 C          o             o                                                     C
8147 C         /l\   /   \   /j\                                                    C
8148 C        /   \ /     \ /   \                                                   C
8149 C       /| o |o       o| o |\                                                  C
8150 C       j|/k\|  /      |/k\|l /                                                C
8151 C        /   \ /       /   \ /                                                 C
8152 C       /     o       /     o                                                  C
8153 C       i             i                                                        C
8154 C                                                                              C
8155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8156 C
8157 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8158 C           energy moment and not to the cluster cumulant.
8159       iti=itortyp(itype(i))
8160       if (j.lt.nres-1) then
8161         itj1=itype2loc(itype(j+1))
8162       else
8163         itj1=nloctyp
8164       endif
8165       itk=itype2loc(itype(k))
8166       itk1=itype2loc(itype(k+1))
8167       if (l.lt.nres-1) then
8168         itl1=itype2loc(itype(l+1))
8169       else
8170         itl1=nloctyp
8171       endif
8172 #ifdef MOMENT
8173       s1=dip(4,jj,i)*dip(4,kk,k)
8174 #endif
8175       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8176       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8177       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8178       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8179       call transpose2(EE(1,1,k),auxmat(1,1))
8180       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8181       vv(1)=pizda(1,1)+pizda(2,2)
8182       vv(2)=pizda(2,1)-pizda(1,2)
8183       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8184 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8185 cd     & "sum",-(s2+s3+s4)
8186 #ifdef MOMENT
8187       eello6_graph3=-(s1+s2+s3+s4)
8188 #else
8189       eello6_graph3=-(s2+s3+s4)
8190 #endif
8191 c      eello6_graph3=-s4
8192 C Derivatives in gamma(k-1)
8193       if (calc_grad) then
8194       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8195       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8196       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8197       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8198 C Derivatives in gamma(l-1)
8199       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8200       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8201       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8202       vv(1)=pizda(1,1)+pizda(2,2)
8203       vv(2)=pizda(2,1)-pizda(1,2)
8204       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8205       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8206 C Cartesian derivatives.
8207       do iii=1,2
8208         do kkk=1,5
8209           do lll=1,3
8210 #ifdef MOMENT
8211             if (iii.eq.1) then
8212               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8213             else
8214               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8215             endif
8216 #endif
8217             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8218      &        auxvec(1))
8219             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8220             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8221      &        auxvec(1))
8222             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8223             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8224      &        pizda(1,1))
8225             vv(1)=pizda(1,1)+pizda(2,2)
8226             vv(2)=pizda(2,1)-pizda(1,2)
8227             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8228 #ifdef MOMENT
8229             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8230 #else
8231             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8232 #endif
8233             if (swap) then
8234               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8235             else
8236               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8237             endif
8238 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8239           enddo
8240         enddo
8241       enddo
8242       endif ! calc_grad
8243       return
8244       end
8245 c----------------------------------------------------------------------------
8246       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8247       implicit real*8 (a-h,o-z)
8248       include 'DIMENSIONS'
8249       include 'COMMON.IOUNITS'
8250       include 'COMMON.CHAIN'
8251       include 'COMMON.DERIV'
8252       include 'COMMON.INTERACT'
8253       include 'COMMON.CONTACTS'
8254       include 'COMMON.TORSION'
8255       include 'COMMON.VAR'
8256       include 'COMMON.GEO'
8257       include 'COMMON.FFIELD'
8258       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8259      & auxvec1(2),auxmat1(2,2)
8260       logical swap
8261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8262 C                                                                              C
8263 C      Parallel       Antiparallel                                             C
8264 C                                                                              C
8265 C          o             o                                                     C
8266 C         /l\   /   \   /j\                                                    C
8267 C        /   \ /     \ /   \                                                   C
8268 C       /| o |o       o| o |\                                                  C
8269 C     \ j|/k\|      \  |/k\|l                                                  C
8270 C      \ /   \       \ /   \                                                   C
8271 C       o     \       o     \                                                  C
8272 C       i             i                                                        C
8273 C                                                                              C
8274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8275 C
8276 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8277 C           energy moment and not to the cluster cumulant.
8278 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8279       iti=itype2loc(itype(i))
8280       itj=itype2loc(itype(j))
8281       if (j.lt.nres-1) then
8282         itj1=itype2loc(itype(j+1))
8283       else
8284         itj1=nloctyp
8285       endif
8286       itk=itype2loc(itype(k))
8287       if (k.lt.nres-1) then
8288         itk1=itype2loc(itype(k+1))
8289       else
8290         itk1=nloctyp
8291       endif
8292       itl=itype2loc(itype(l))
8293       if (l.lt.nres-1) then
8294         itl1=itype2loc(itype(l+1))
8295       else
8296         itl1=nloctyp
8297       endif
8298 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8299 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8300 cd     & ' itl',itl,' itl1',itl1
8301 #ifdef MOMENT
8302       if (imat.eq.1) then
8303         s1=dip(3,jj,i)*dip(3,kk,k)
8304       else
8305         s1=dip(2,jj,j)*dip(2,kk,l)
8306       endif
8307 #endif
8308       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8309       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8310       if (j.eq.l+1) then
8311         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8312         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8313       else
8314         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8315         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8316       endif
8317       call transpose2(EUg(1,1,k),auxmat(1,1))
8318       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8319       vv(1)=pizda(1,1)-pizda(2,2)
8320       vv(2)=pizda(2,1)+pizda(1,2)
8321       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8322 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8323 #ifdef MOMENT
8324       eello6_graph4=-(s1+s2+s3+s4)
8325 #else
8326       eello6_graph4=-(s2+s3+s4)
8327 #endif
8328 C Derivatives in gamma(i-1)
8329       if (calc_grad) then
8330       if (i.gt.1) then
8331 #ifdef MOMENT
8332         if (imat.eq.1) then
8333           s1=dipderg(2,jj,i)*dip(3,kk,k)
8334         else
8335           s1=dipderg(4,jj,j)*dip(2,kk,l)
8336         endif
8337 #endif
8338         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8339         if (j.eq.l+1) then
8340           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8341           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8342         else
8343           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8344           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8345         endif
8346         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8347         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8348 cd          write (2,*) 'turn6 derivatives'
8349 #ifdef MOMENT
8350           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8351 #else
8352           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8353 #endif
8354         else
8355 #ifdef MOMENT
8356           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8357 #else
8358           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8359 #endif
8360         endif
8361       endif
8362 C Derivatives in gamma(k-1)
8363 #ifdef MOMENT
8364       if (imat.eq.1) then
8365         s1=dip(3,jj,i)*dipderg(2,kk,k)
8366       else
8367         s1=dip(2,jj,j)*dipderg(4,kk,l)
8368       endif
8369 #endif
8370       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8371       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8372       if (j.eq.l+1) then
8373         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8374         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8375       else
8376         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8377         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8378       endif
8379       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8380       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8381       vv(1)=pizda(1,1)-pizda(2,2)
8382       vv(2)=pizda(2,1)+pizda(1,2)
8383       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8384       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8385 #ifdef MOMENT
8386         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8387 #else
8388         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8389 #endif
8390       else
8391 #ifdef MOMENT
8392         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8393 #else
8394         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8395 #endif
8396       endif
8397 C Derivatives in gamma(j-1) or gamma(l-1)
8398       if (l.eq.j+1 .and. l.gt.1) then
8399         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8400         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8401         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8402         vv(1)=pizda(1,1)-pizda(2,2)
8403         vv(2)=pizda(2,1)+pizda(1,2)
8404         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8405         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8406       else if (j.gt.1) then
8407         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8408         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8409         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8410         vv(1)=pizda(1,1)-pizda(2,2)
8411         vv(2)=pizda(2,1)+pizda(1,2)
8412         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8413         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8414           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8415         else
8416           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8417         endif
8418       endif
8419 C Cartesian derivatives.
8420       do iii=1,2
8421         do kkk=1,5
8422           do lll=1,3
8423 #ifdef MOMENT
8424             if (iii.eq.1) then
8425               if (imat.eq.1) then
8426                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8427               else
8428                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8429               endif
8430             else
8431               if (imat.eq.1) then
8432                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8433               else
8434                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8435               endif
8436             endif
8437 #endif
8438             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8439      &        auxvec(1))
8440             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8441             if (j.eq.l+1) then
8442               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8443      &          b1(1,j+1),auxvec(1))
8444               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8445             else
8446               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8447      &          b1(1,l+1),auxvec(1))
8448               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8449             endif
8450             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8451      &        pizda(1,1))
8452             vv(1)=pizda(1,1)-pizda(2,2)
8453             vv(2)=pizda(2,1)+pizda(1,2)
8454             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8455             if (swap) then
8456               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8457 #ifdef MOMENT
8458                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8459      &             -(s1+s2+s4)
8460 #else
8461                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8462      &             -(s2+s4)
8463 #endif
8464                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8465               else
8466 #ifdef MOMENT
8467                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8468 #else
8469                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8470 #endif
8471                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8472               endif
8473             else
8474 #ifdef MOMENT
8475               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8476 #else
8477               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8478 #endif
8479               if (l.eq.j+1) then
8480                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8481               else
8482                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8483               endif
8484             endif
8485           enddo
8486         enddo
8487       enddo
8488       endif ! calc_grad
8489       return
8490       end
8491 c----------------------------------------------------------------------------
8492       double precision function eello_turn6(i,jj,kk)
8493       implicit real*8 (a-h,o-z)
8494       include 'DIMENSIONS'
8495       include 'COMMON.IOUNITS'
8496       include 'COMMON.CHAIN'
8497       include 'COMMON.DERIV'
8498       include 'COMMON.INTERACT'
8499       include 'COMMON.CONTACTS'
8500       include 'COMMON.TORSION'
8501       include 'COMMON.VAR'
8502       include 'COMMON.GEO'
8503       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8504      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8505      &  ggg1(3),ggg2(3)
8506       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8507      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8508 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8509 C           the respective energy moment and not to the cluster cumulant.
8510       s1=0.0d0
8511       s8=0.0d0
8512       s13=0.0d0
8513 c
8514       eello_turn6=0.0d0
8515       j=i+4
8516       k=i+1
8517       l=i+3
8518       iti=itype2loc(itype(i))
8519       itk=itype2loc(itype(k))
8520       itk1=itype2loc(itype(k+1))
8521       itl=itype2loc(itype(l))
8522       itj=itype2loc(itype(j))
8523 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8524 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8525 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8526 cd        eello6=0.0d0
8527 cd        return
8528 cd      endif
8529 cd      write (iout,*)
8530 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8531 cd     &   ' and',k,l
8532 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8533       do iii=1,2
8534         do kkk=1,5
8535           do lll=1,3
8536             derx_turn(lll,kkk,iii)=0.0d0
8537           enddo
8538         enddo
8539       enddo
8540 cd      eij=1.0d0
8541 cd      ekl=1.0d0
8542 cd      ekont=1.0d0
8543       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8544 cd      eello6_5=0.0d0
8545 cd      write (2,*) 'eello6_5',eello6_5
8546 #ifdef MOMENT
8547       call transpose2(AEA(1,1,1),auxmat(1,1))
8548       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8549       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8550       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8551 #endif
8552       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8553       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8554       s2 = scalar2(b1(1,k),vtemp1(1))
8555 #ifdef MOMENT
8556       call transpose2(AEA(1,1,2),atemp(1,1))
8557       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8558       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8559       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8560 #endif
8561       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8562       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8563       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8564 #ifdef MOMENT
8565       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8566       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8567       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8568       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8569       ss13 = scalar2(b1(1,k),vtemp4(1))
8570       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8571 #endif
8572 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8573 c      s1=0.0d0
8574 c      s2=0.0d0
8575 c      s8=0.0d0
8576 c      s12=0.0d0
8577 c      s13=0.0d0
8578       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8579 C Derivatives in gamma(i+2)
8580       if (calc_grad) then
8581       s1d =0.0d0
8582       s8d =0.0d0
8583 #ifdef MOMENT
8584       call transpose2(AEA(1,1,1),auxmatd(1,1))
8585       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8586       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8587       call transpose2(AEAderg(1,1,2),atempd(1,1))
8588       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8589       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8590 #endif
8591       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8592       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8593       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8594 c      s1d=0.0d0
8595 c      s2d=0.0d0
8596 c      s8d=0.0d0
8597 c      s12d=0.0d0
8598 c      s13d=0.0d0
8599       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8600 C Derivatives in gamma(i+3)
8601 #ifdef MOMENT
8602       call transpose2(AEA(1,1,1),auxmatd(1,1))
8603       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8604       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8605       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8606 #endif
8607       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8608       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8609       s2d = scalar2(b1(1,k),vtemp1d(1))
8610 #ifdef MOMENT
8611       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8612       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8613 #endif
8614       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8615 #ifdef MOMENT
8616       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8617       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8618       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8619 #endif
8620 c      s1d=0.0d0
8621 c      s2d=0.0d0
8622 c      s8d=0.0d0
8623 c      s12d=0.0d0
8624 c      s13d=0.0d0
8625 #ifdef MOMENT
8626       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8627      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8628 #else
8629       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8630      &               -0.5d0*ekont*(s2d+s12d)
8631 #endif
8632 C Derivatives in gamma(i+4)
8633       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8634       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8635       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8636 #ifdef MOMENT
8637       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8638       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8639       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8640 #endif
8641 c      s1d=0.0d0
8642 c      s2d=0.0d0
8643 c      s8d=0.0d0
8644 C      s12d=0.0d0
8645 c      s13d=0.0d0
8646 #ifdef MOMENT
8647       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8648 #else
8649       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8650 #endif
8651 C Derivatives in gamma(i+5)
8652 #ifdef MOMENT
8653       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8654       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8655       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8656 #endif
8657       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8658       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8659       s2d = scalar2(b1(1,k),vtemp1d(1))
8660 #ifdef MOMENT
8661       call transpose2(AEA(1,1,2),atempd(1,1))
8662       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8663       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8664 #endif
8665       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8666       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8667 #ifdef MOMENT
8668       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8669       ss13d = scalar2(b1(1,k),vtemp4d(1))
8670       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8671 #endif
8672 c      s1d=0.0d0
8673 c      s2d=0.0d0
8674 c      s8d=0.0d0
8675 c      s12d=0.0d0
8676 c      s13d=0.0d0
8677 #ifdef MOMENT
8678       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8679      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8680 #else
8681       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8682      &               -0.5d0*ekont*(s2d+s12d)
8683 #endif
8684 C Cartesian derivatives
8685       do iii=1,2
8686         do kkk=1,5
8687           do lll=1,3
8688 #ifdef MOMENT
8689             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8690             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8691             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8692 #endif
8693             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8694             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8695      &          vtemp1d(1))
8696             s2d = scalar2(b1(1,k),vtemp1d(1))
8697 #ifdef MOMENT
8698             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8699             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8700             s8d = -(atempd(1,1)+atempd(2,2))*
8701      &           scalar2(cc(1,1,l),vtemp2(1))
8702 #endif
8703             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8704      &           auxmatd(1,1))
8705             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8706             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8707 c      s1d=0.0d0
8708 c      s2d=0.0d0
8709 c      s8d=0.0d0
8710 c      s12d=0.0d0
8711 c      s13d=0.0d0
8712 #ifdef MOMENT
8713             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8714      &        - 0.5d0*(s1d+s2d)
8715 #else
8716             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8717      &        - 0.5d0*s2d
8718 #endif
8719 #ifdef MOMENT
8720             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8721      &        - 0.5d0*(s8d+s12d)
8722 #else
8723             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8724      &        - 0.5d0*s12d
8725 #endif
8726           enddo
8727         enddo
8728       enddo
8729 #ifdef MOMENT
8730       do kkk=1,5
8731         do lll=1,3
8732           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8733      &      achuj_tempd(1,1))
8734           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8735           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8736           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8737           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8738           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8739      &      vtemp4d(1))
8740           ss13d = scalar2(b1(1,k),vtemp4d(1))
8741           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8742           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8743         enddo
8744       enddo
8745 #endif
8746 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8747 cd     &  16*eel_turn6_num
8748 cd      goto 1112
8749       if (j.lt.nres-1) then
8750         j1=j+1
8751         j2=j-1
8752       else
8753         j1=j-1
8754         j2=j-2
8755       endif
8756       if (l.lt.nres-1) then
8757         l1=l+1
8758         l2=l-1
8759       else
8760         l1=l-1
8761         l2=l-2
8762       endif
8763       do ll=1,3
8764 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8765 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8766 cgrad        ghalf=0.5d0*ggg1(ll)
8767 cd        ghalf=0.0d0
8768         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8769         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8770         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8771      &    +ekont*derx_turn(ll,2,1)
8772         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8773         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8774      &    +ekont*derx_turn(ll,4,1)
8775         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8776         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8777         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8778 cgrad        ghalf=0.5d0*ggg2(ll)
8779 cd        ghalf=0.0d0
8780         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8781      &    +ekont*derx_turn(ll,2,2)
8782         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8783         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8784      &    +ekont*derx_turn(ll,4,2)
8785         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8786         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8787         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8788       enddo
8789 cd      goto 1112
8790 cgrad      do m=i+1,j-1
8791 cgrad        do ll=1,3
8792 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8793 cgrad        enddo
8794 cgrad      enddo
8795 cgrad      do m=k+1,l-1
8796 cgrad        do ll=1,3
8797 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8798 cgrad        enddo
8799 cgrad      enddo
8800 cgrad1112  continue
8801 cgrad      do m=i+2,j2
8802 cgrad        do ll=1,3
8803 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8804 cgrad        enddo
8805 cgrad      enddo
8806 cgrad      do m=k+2,l2
8807 cgrad        do ll=1,3
8808 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8809 cgrad        enddo
8810 cgrad      enddo
8811 cd      do iii=1,nres-3
8812 cd        write (2,*) iii,g_corr6_loc(iii)
8813 cd      enddo
8814       endif ! calc_grad
8815       eello_turn6=ekont*eel_turn6
8816 cd      write (2,*) 'ekont',ekont
8817 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8818       return
8819       end
8820
8821 crc-------------------------------------------------
8822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8823       subroutine Eliptransfer(eliptran)
8824       implicit real*8 (a-h,o-z)
8825       include 'DIMENSIONS'
8826       include 'COMMON.GEO'
8827       include 'COMMON.VAR'
8828       include 'COMMON.LOCAL'
8829       include 'COMMON.CHAIN'
8830       include 'COMMON.DERIV'
8831       include 'COMMON.INTERACT'
8832       include 'COMMON.IOUNITS'
8833       include 'COMMON.CALC'
8834       include 'COMMON.CONTROL'
8835       include 'COMMON.SPLITELE'
8836       include 'COMMON.SBRIDGE'
8837 C this is done by Adasko
8838 C      print *,"wchodze"
8839 C structure of box:
8840 C      water
8841 C--bordliptop-- buffore starts
8842 C--bufliptop--- here true lipid starts
8843 C      lipid
8844 C--buflipbot--- lipid ends buffore starts
8845 C--bordlipbot--buffore ends
8846       eliptran=0.0
8847       do i=1,nres
8848 C       do i=1,1
8849         if (itype(i).eq.ntyp1) cycle
8850
8851         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8852         if (positi.le.0) positi=positi+boxzsize
8853 C        print *,i
8854 C first for peptide groups
8855 c for each residue check if it is in lipid or lipid water border area
8856        if ((positi.gt.bordlipbot)
8857      &.and.(positi.lt.bordliptop)) then
8858 C the energy transfer exist
8859         if (positi.lt.buflipbot) then
8860 C what fraction I am in
8861          fracinbuf=1.0d0-
8862      &        ((positi-bordlipbot)/lipbufthick)
8863 C lipbufthick is thickenes of lipid buffore
8864          sslip=sscalelip(fracinbuf)
8865          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8866          eliptran=eliptran+sslip*pepliptran
8867          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8868          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8869 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8870         elseif (positi.gt.bufliptop) then
8871          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8872          sslip=sscalelip(fracinbuf)
8873          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8874          eliptran=eliptran+sslip*pepliptran
8875          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8876          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8877 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8878 C          print *, "doing sscalefor top part"
8879 C         print *,i,sslip,fracinbuf,ssgradlip
8880         else
8881          eliptran=eliptran+pepliptran
8882 C         print *,"I am in true lipid"
8883         endif
8884 C       else
8885 C       eliptran=elpitran+0.0 ! I am in water
8886        endif
8887        enddo
8888 C       print *, "nic nie bylo w lipidzie?"
8889 C now multiply all by the peptide group transfer factor
8890 C       eliptran=eliptran*pepliptran
8891 C now the same for side chains
8892 CV       do i=1,1
8893        do i=1,nres
8894         if (itype(i).eq.ntyp1) cycle
8895         positi=(mod(c(3,i+nres),boxzsize))
8896         if (positi.le.0) positi=positi+boxzsize
8897 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8898 c for each residue check if it is in lipid or lipid water border area
8899 C       respos=mod(c(3,i+nres),boxzsize)
8900 C       print *,positi,bordlipbot,buflipbot
8901        if ((positi.gt.bordlipbot)
8902      & .and.(positi.lt.bordliptop)) then
8903 C the energy transfer exist
8904         if (positi.lt.buflipbot) then
8905          fracinbuf=1.0d0-
8906      &     ((positi-bordlipbot)/lipbufthick)
8907 C lipbufthick is thickenes of lipid buffore
8908          sslip=sscalelip(fracinbuf)
8909          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8910          eliptran=eliptran+sslip*liptranene(itype(i))
8911          gliptranx(3,i)=gliptranx(3,i)
8912      &+ssgradlip*liptranene(itype(i))
8913          gliptranc(3,i-1)= gliptranc(3,i-1)
8914      &+ssgradlip*liptranene(itype(i))
8915 C         print *,"doing sccale for lower part"
8916         elseif (positi.gt.bufliptop) then
8917          fracinbuf=1.0d0-
8918      &((bordliptop-positi)/lipbufthick)
8919          sslip=sscalelip(fracinbuf)
8920          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8921          eliptran=eliptran+sslip*liptranene(itype(i))
8922          gliptranx(3,i)=gliptranx(3,i)
8923      &+ssgradlip*liptranene(itype(i))
8924          gliptranc(3,i-1)= gliptranc(3,i-1)
8925      &+ssgradlip*liptranene(itype(i))
8926 C          print *, "doing sscalefor top part",sslip,fracinbuf
8927         else
8928          eliptran=eliptran+liptranene(itype(i))
8929 C         print *,"I am in true lipid"
8930         endif
8931         endif ! if in lipid or buffor
8932 C       else
8933 C       eliptran=elpitran+0.0 ! I am in water
8934        enddo
8935        return
8936        end
8937
8938
8939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8940
8941       SUBROUTINE MATVEC2(A1,V1,V2)
8942       implicit real*8 (a-h,o-z)
8943       include 'DIMENSIONS'
8944       DIMENSION A1(2,2),V1(2),V2(2)
8945 c      DO 1 I=1,2
8946 c        VI=0.0
8947 c        DO 3 K=1,2
8948 c    3     VI=VI+A1(I,K)*V1(K)
8949 c        Vaux(I)=VI
8950 c    1 CONTINUE
8951
8952       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8953       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8954
8955       v2(1)=vaux1
8956       v2(2)=vaux2
8957       END
8958 C---------------------------------------
8959       SUBROUTINE MATMAT2(A1,A2,A3)
8960       implicit real*8 (a-h,o-z)
8961       include 'DIMENSIONS'
8962       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8963 c      DIMENSION AI3(2,2)
8964 c        DO  J=1,2
8965 c          A3IJ=0.0
8966 c          DO K=1,2
8967 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8968 c          enddo
8969 c          A3(I,J)=A3IJ
8970 c       enddo
8971 c      enddo
8972
8973       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8974       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8975       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8976       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8977
8978       A3(1,1)=AI3_11
8979       A3(2,1)=AI3_21
8980       A3(1,2)=AI3_12
8981       A3(2,2)=AI3_22
8982       END
8983
8984 c-------------------------------------------------------------------------
8985       double precision function scalar2(u,v)
8986       implicit none
8987       double precision u(2),v(2)
8988       double precision sc
8989       integer i
8990       scalar2=u(1)*v(1)+u(2)*v(2)
8991       return
8992       end
8993
8994 C-----------------------------------------------------------------------------
8995
8996       subroutine transpose2(a,at)
8997       implicit none
8998       double precision a(2,2),at(2,2)
8999       at(1,1)=a(1,1)
9000       at(1,2)=a(2,1)
9001       at(2,1)=a(1,2)
9002       at(2,2)=a(2,2)
9003       return
9004       end
9005 c--------------------------------------------------------------------------
9006       subroutine transpose(n,a,at)
9007       implicit none
9008       integer n,i,j
9009       double precision a(n,n),at(n,n)
9010       do i=1,n
9011         do j=1,n
9012           at(j,i)=a(i,j)
9013         enddo
9014       enddo
9015       return
9016       end
9017 C---------------------------------------------------------------------------
9018       subroutine prodmat3(a1,a2,kk,transp,prod)
9019       implicit none
9020       integer i,j
9021       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9022       logical transp
9023 crc      double precision auxmat(2,2),prod_(2,2)
9024
9025       if (transp) then
9026 crc        call transpose2(kk(1,1),auxmat(1,1))
9027 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9028 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9029
9030            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9031      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9032            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9033      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9034            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9035      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9036            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9037      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9038
9039       else
9040 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9041 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9042
9043            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9044      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9045            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9046      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9047            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9048      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9049            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9050      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9051
9052       endif
9053 c      call transpose2(a2(1,1),a2t(1,1))
9054
9055 crc      print *,transp
9056 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9057 crc      print *,((prod(i,j),i=1,2),j=1,2)
9058
9059       return
9060       end
9061 C-----------------------------------------------------------------------------
9062       double precision function scalar(u,v)
9063       implicit none
9064       double precision u(3),v(3)
9065       double precision sc
9066       integer i
9067       sc=0.0d0
9068       do i=1,3
9069         sc=sc+u(i)*v(i)
9070       enddo
9071       scalar=sc
9072       return
9073       end
9074 C-----------------------------------------------------------------------
9075       double precision function sscale(r)
9076       double precision r,gamm
9077       include "COMMON.SPLITELE"
9078       if(r.lt.r_cut-rlamb) then
9079         sscale=1.0d0
9080       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9081         gamm=(r-(r_cut-rlamb))/rlamb
9082         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9083       else
9084         sscale=0d0
9085       endif
9086       return
9087       end
9088 C-----------------------------------------------------------------------
9089 C-----------------------------------------------------------------------
9090       double precision function sscagrad(r)
9091       double precision r,gamm
9092       include "COMMON.SPLITELE"
9093       if(r.lt.r_cut-rlamb) then
9094         sscagrad=0.0d0
9095       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9096         gamm=(r-(r_cut-rlamb))/rlamb
9097         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9098       else
9099         sscagrad=0.0d0
9100       endif
9101       return
9102       end
9103 C-----------------------------------------------------------------------
9104 C-----------------------------------------------------------------------
9105       double precision function sscalelip(r)
9106       double precision r,gamm
9107       include "COMMON.SPLITELE"
9108 C      if(r.lt.r_cut-rlamb) then
9109 C        sscale=1.0d0
9110 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9111 C        gamm=(r-(r_cut-rlamb))/rlamb
9112         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9113 C      else
9114 C        sscale=0d0
9115 C      endif
9116       return
9117       end
9118 C-----------------------------------------------------------------------
9119       double precision function sscagradlip(r)
9120       double precision r,gamm
9121       include "COMMON.SPLITELE"
9122 C     if(r.lt.r_cut-rlamb) then
9123 C        sscagrad=0.0d0
9124 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9125 C        gamm=(r-(r_cut-rlamb))/rlamb
9126         sscagradlip=r*(6*r-6.0d0)
9127 C      else
9128 C        sscagrad=0.0d0
9129 C      endif
9130       return
9131       end
9132
9133 C-----------------------------------------------------------------------
9134        subroutine set_shield_fac
9135       implicit real*8 (a-h,o-z)
9136       include 'DIMENSIONS'
9137       include 'COMMON.CHAIN'
9138       include 'COMMON.DERIV'
9139       include 'COMMON.IOUNITS'
9140       include 'COMMON.SHIELD'
9141       include 'COMMON.INTERACT'
9142 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9143       double precision div77_81/0.974996043d0/,
9144      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9145
9146 C the vector between center of side_chain and peptide group
9147        double precision pep_side(3),long,side_calf(3),
9148      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9149      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9150 C the line belowe needs to be changed for FGPROC>1
9151       do i=1,nres-1
9152       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9153       ishield_list(i)=0
9154 Cif there two consequtive dummy atoms there is no peptide group between them
9155 C the line below has to be changed for FGPROC>1
9156       VolumeTotal=0.0
9157       do k=1,nres
9158        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9159        dist_pep_side=0.0
9160        dist_side_calf=0.0
9161        do j=1,3
9162 C first lets set vector conecting the ithe side-chain with kth side-chain
9163       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9164 C      pep_side(j)=2.0d0
9165 C and vector conecting the side-chain with its proper calfa
9166       side_calf(j)=c(j,k+nres)-c(j,k)
9167 C      side_calf(j)=2.0d0
9168       pept_group(j)=c(j,i)-c(j,i+1)
9169 C lets have their lenght
9170       dist_pep_side=pep_side(j)**2+dist_pep_side
9171       dist_side_calf=dist_side_calf+side_calf(j)**2
9172       dist_pept_group=dist_pept_group+pept_group(j)**2
9173       enddo
9174        dist_pep_side=dsqrt(dist_pep_side)
9175        dist_pept_group=dsqrt(dist_pept_group)
9176        dist_side_calf=dsqrt(dist_side_calf)
9177       do j=1,3
9178         pep_side_norm(j)=pep_side(j)/dist_pep_side
9179         side_calf_norm(j)=dist_side_calf
9180       enddo
9181 C now sscale fraction
9182        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9183 C       print *,buff_shield,"buff"
9184 C now sscale
9185         if (sh_frac_dist.le.0.0) cycle
9186 C If we reach here it means that this side chain reaches the shielding sphere
9187 C Lets add him to the list for gradient
9188         ishield_list(i)=ishield_list(i)+1
9189 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9190 C this list is essential otherwise problem would be O3
9191         shield_list(ishield_list(i),i)=k
9192 C Lets have the sscale value
9193         if (sh_frac_dist.gt.1.0) then
9194          scale_fac_dist=1.0d0
9195          do j=1,3
9196          sh_frac_dist_grad(j)=0.0d0
9197          enddo
9198         else
9199          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9200      &                   *(2.0*sh_frac_dist-3.0d0)
9201          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9202      &                  /dist_pep_side/buff_shield*0.5
9203 C remember for the final gradient multiply sh_frac_dist_grad(j)
9204 C for side_chain by factor -2 !
9205          do j=1,3
9206          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9207 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9208 C     &                    sh_frac_dist_grad(j)
9209          enddo
9210         endif
9211 C        if ((i.eq.3).and.(k.eq.2)) then
9212 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9213 C     & ,"TU"
9214 C        endif
9215
9216 C this is what is now we have the distance scaling now volume...
9217       short=short_r_sidechain(itype(k))
9218       long=long_r_sidechain(itype(k))
9219       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9220 C now costhet_grad
9221 C       costhet=0.0d0
9222        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9223 C       costhet_fac=0.0d0
9224        do j=1,3
9225          costhet_grad(j)=costhet_fac*pep_side(j)
9226        enddo
9227 C remember for the final gradient multiply costhet_grad(j)
9228 C for side_chain by factor -2 !
9229 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9230 C pep_side0pept_group is vector multiplication
9231       pep_side0pept_group=0.0
9232       do j=1,3
9233       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9234       enddo
9235       cosalfa=(pep_side0pept_group/
9236      & (dist_pep_side*dist_side_calf))
9237       fac_alfa_sin=1.0-cosalfa**2
9238       fac_alfa_sin=dsqrt(fac_alfa_sin)
9239       rkprim=fac_alfa_sin*(long-short)+short
9240 C now costhet_grad
9241        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9242        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9243
9244        do j=1,3
9245          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9246      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9247      &*(long-short)/fac_alfa_sin*cosalfa/
9248      &((dist_pep_side*dist_side_calf))*
9249      &((side_calf(j))-cosalfa*
9250      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9251
9252         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9253      &*(long-short)/fac_alfa_sin*cosalfa
9254      &/((dist_pep_side*dist_side_calf))*
9255      &(pep_side(j)-
9256      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9257        enddo
9258
9259       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9260      &                    /VSolvSphere_div
9261      &                    *wshield
9262 C now the gradient...
9263 C grad_shield is gradient of Calfa for peptide groups
9264 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9265 C     &               costhet,cosphi
9266 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9267 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9268       do j=1,3
9269       grad_shield(j,i)=grad_shield(j,i)
9270 C gradient po skalowaniu
9271      &                +(sh_frac_dist_grad(j)
9272 C  gradient po costhet
9273      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9274      &-scale_fac_dist*(cosphi_grad_long(j))
9275      &/(1.0-cosphi) )*div77_81
9276      &*VofOverlap
9277 C grad_shield_side is Cbeta sidechain gradient
9278       grad_shield_side(j,ishield_list(i),i)=
9279      &        (sh_frac_dist_grad(j)*(-2.0d0)
9280      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9281      &       +scale_fac_dist*(cosphi_grad_long(j))
9282      &        *2.0d0/(1.0-cosphi))
9283      &        *div77_81*VofOverlap
9284
9285        grad_shield_loc(j,ishield_list(i),i)=
9286      &   scale_fac_dist*cosphi_grad_loc(j)
9287      &        *2.0d0/(1.0-cosphi)
9288      &        *div77_81*VofOverlap
9289       enddo
9290       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9291       enddo
9292       fac_shield(i)=VolumeTotal*div77_81+div4_81
9293 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9294       enddo
9295       return
9296       end
9297 C--------------------------------------------------------------------------
9298 C first for shielding is setting of function of side-chains
9299        subroutine set_shield_fac2
9300       implicit real*8 (a-h,o-z)
9301       include 'DIMENSIONS'
9302       include 'COMMON.CHAIN'
9303       include 'COMMON.DERIV'
9304       include 'COMMON.IOUNITS'
9305       include 'COMMON.SHIELD'
9306       include 'COMMON.INTERACT'
9307 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9308       double precision div77_81/0.974996043d0/,
9309      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9310
9311 C the vector between center of side_chain and peptide group
9312        double precision pep_side(3),long,side_calf(3),
9313      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9314      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9315 C the line belowe needs to be changed for FGPROC>1
9316       do i=1,nres-1
9317       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9318       ishield_list(i)=0
9319 Cif there two consequtive dummy atoms there is no peptide group between them
9320 C the line below has to be changed for FGPROC>1
9321       VolumeTotal=0.0
9322       do k=1,nres
9323        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9324        dist_pep_side=0.0
9325        dist_side_calf=0.0
9326        do j=1,3
9327 C first lets set vector conecting the ithe side-chain with kth side-chain
9328       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9329 C      pep_side(j)=2.0d0
9330 C and vector conecting the side-chain with its proper calfa
9331       side_calf(j)=c(j,k+nres)-c(j,k)
9332 C      side_calf(j)=2.0d0
9333       pept_group(j)=c(j,i)-c(j,i+1)
9334 C lets have their lenght
9335       dist_pep_side=pep_side(j)**2+dist_pep_side
9336       dist_side_calf=dist_side_calf+side_calf(j)**2
9337       dist_pept_group=dist_pept_group+pept_group(j)**2
9338       enddo
9339        dist_pep_side=dsqrt(dist_pep_side)
9340        dist_pept_group=dsqrt(dist_pept_group)
9341        dist_side_calf=dsqrt(dist_side_calf)
9342       do j=1,3
9343         pep_side_norm(j)=pep_side(j)/dist_pep_side
9344         side_calf_norm(j)=dist_side_calf
9345       enddo
9346 C now sscale fraction
9347        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9348 C       print *,buff_shield,"buff"
9349 C now sscale
9350         if (sh_frac_dist.le.0.0) cycle
9351 C If we reach here it means that this side chain reaches the shielding sphere
9352 C Lets add him to the list for gradient
9353         ishield_list(i)=ishield_list(i)+1
9354 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9355 C this list is essential otherwise problem would be O3
9356         shield_list(ishield_list(i),i)=k
9357 C Lets have the sscale value
9358         if (sh_frac_dist.gt.1.0) then
9359          scale_fac_dist=1.0d0
9360          do j=1,3
9361          sh_frac_dist_grad(j)=0.0d0
9362          enddo
9363         else
9364          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9365      &                   *(2.0d0*sh_frac_dist-3.0d0)
9366          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9367      &                  /dist_pep_side/buff_shield*0.5d0
9368 C remember for the final gradient multiply sh_frac_dist_grad(j)
9369 C for side_chain by factor -2 !
9370          do j=1,3
9371          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9372 C         sh_frac_dist_grad(j)=0.0d0
9373 C         scale_fac_dist=1.0d0
9374 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9375 C     &                    sh_frac_dist_grad(j)
9376          enddo
9377         endif
9378 C this is what is now we have the distance scaling now volume...
9379       short=short_r_sidechain(itype(k))
9380       long=long_r_sidechain(itype(k))
9381       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9382       sinthet=short/dist_pep_side*costhet
9383 C now costhet_grad
9384 C       costhet=0.6d0
9385 C       sinthet=0.8
9386        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9387 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9388 C     &             -short/dist_pep_side**2/costhet)
9389 C       costhet_fac=0.0d0
9390        do j=1,3
9391          costhet_grad(j)=costhet_fac*pep_side(j)
9392        enddo
9393 C remember for the final gradient multiply costhet_grad(j)
9394 C for side_chain by factor -2 !
9395 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9396 C pep_side0pept_group is vector multiplication
9397       pep_side0pept_group=0.0d0
9398       do j=1,3
9399       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9400       enddo
9401       cosalfa=(pep_side0pept_group/
9402      & (dist_pep_side*dist_side_calf))
9403       fac_alfa_sin=1.0d0-cosalfa**2
9404       fac_alfa_sin=dsqrt(fac_alfa_sin)
9405       rkprim=fac_alfa_sin*(long-short)+short
9406 C      rkprim=short
9407
9408 C now costhet_grad
9409        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9410 C       cosphi=0.6
9411        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9412        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9413      &      dist_pep_side**2)
9414 C       sinphi=0.8
9415        do j=1,3
9416          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9417      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9418      &*(long-short)/fac_alfa_sin*cosalfa/
9419      &((dist_pep_side*dist_side_calf))*
9420      &((side_calf(j))-cosalfa*
9421      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9422 C       cosphi_grad_long(j)=0.0d0
9423         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9424      &*(long-short)/fac_alfa_sin*cosalfa
9425      &/((dist_pep_side*dist_side_calf))*
9426      &(pep_side(j)-
9427      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9428 C       cosphi_grad_loc(j)=0.0d0
9429        enddo
9430 C      print *,sinphi,sinthet
9431       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9432      &                    /VSolvSphere_div
9433 C     &                    *wshield
9434 C now the gradient...
9435       do j=1,3
9436       grad_shield(j,i)=grad_shield(j,i)
9437 C gradient po skalowaniu
9438      &                +(sh_frac_dist_grad(j)*VofOverlap
9439 C  gradient po costhet
9440      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9441      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9442      &       sinphi/sinthet*costhet*costhet_grad(j)
9443      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9444      & )*wshield
9445 C grad_shield_side is Cbeta sidechain gradient
9446       grad_shield_side(j,ishield_list(i),i)=
9447      &        (sh_frac_dist_grad(j)*(-2.0d0)
9448      &        *VofOverlap
9449      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9450      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9451      &       sinphi/sinthet*costhet*costhet_grad(j)
9452      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9453      &       )*wshield
9454
9455        grad_shield_loc(j,ishield_list(i),i)=
9456      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9457      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9458      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9459      &        ))
9460      &        *wshield
9461       enddo
9462       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9463       enddo
9464       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9465 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9466 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9467       enddo
9468       return
9469       end
9470 C--------------------------------------------------------------------------
9471       double precision function tschebyshev(m,n,x,y)
9472       implicit none
9473       include "DIMENSIONS"
9474       integer i,m,n
9475       double precision x(n),y,yy(0:maxvar),aux
9476 c Tschebyshev polynomial. Note that the first term is omitted
9477 c m=0: the constant term is included
9478 c m=1: the constant term is not included
9479       yy(0)=1.0d0
9480       yy(1)=y
9481       do i=2,n
9482         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9483       enddo
9484       aux=0.0d0
9485       do i=m,n
9486         aux=aux+x(i)*yy(i)
9487       enddo
9488       tschebyshev=aux
9489       return
9490       end
9491 C--------------------------------------------------------------------------
9492       double precision function gradtschebyshev(m,n,x,y)
9493       implicit none
9494       include "DIMENSIONS"
9495       integer i,m,n
9496       double precision x(n+1),y,yy(0:maxvar),aux
9497 c Tschebyshev polynomial. Note that the first term is omitted
9498 c m=0: the constant term is included
9499 c m=1: the constant term is not included
9500       yy(0)=1.0d0
9501       yy(1)=2.0d0*y
9502       do i=2,n
9503         yy(i)=2*y*yy(i-1)-yy(i-2)
9504       enddo
9505       aux=0.0d0
9506       do i=m,n
9507         aux=aux+x(i+1)*yy(i)*(i+1)
9508 C        print *, x(i+1),yy(i),i
9509       enddo
9510       gradtschebyshev=aux
9511       return
9512       end
9513 c----------------------------------------------------------------------------
9514       double precision function sscale2(r,r_cut,r0,rlamb)
9515       implicit none
9516       double precision r,gamm,r_cut,r0,rlamb,rr
9517       rr = dabs(r-r0)
9518 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9519 c      write (2,*) "rr",rr
9520       if(rr.lt.r_cut-rlamb) then
9521         sscale2=1.0d0
9522       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9523         gamm=(rr-(r_cut-rlamb))/rlamb
9524         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9525       else
9526         sscale2=0d0
9527       endif
9528       return
9529       end
9530 C-----------------------------------------------------------------------
9531       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9532       implicit none
9533       double precision r,gamm,r_cut,r0,rlamb,rr
9534       rr = dabs(r-r0)
9535       if(rr.lt.r_cut-rlamb) then
9536         sscalgrad2=0.0d0
9537       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9538         gamm=(rr-(r_cut-rlamb))/rlamb
9539         if (r.ge.r0) then
9540           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9541         else
9542           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9543         endif
9544       else
9545         sscalgrad2=0.0d0
9546       endif
9547       return
9548       end
9549 c----------------------------------------------------------------------------
9550       subroutine e_saxs(Esaxs_constr)
9551       implicit none
9552       include 'DIMENSIONS'
9553 #ifdef MPI
9554       include "mpif.h"
9555       include "COMMON.SETUP"
9556       integer IERR
9557 #endif
9558       include 'COMMON.SBRIDGE'
9559       include 'COMMON.CHAIN'
9560       include 'COMMON.GEO'
9561       include 'COMMON.LOCAL'
9562       include 'COMMON.INTERACT'
9563       include 'COMMON.VAR'
9564       include 'COMMON.IOUNITS'
9565       include 'COMMON.DERIV'
9566       include 'COMMON.CONTROL'
9567       include 'COMMON.NAMES'
9568       include 'COMMON.FFIELD'
9569       include 'COMMON.LANGEVIN'
9570 c
9571       double precision Esaxs_constr
9572       integer i,iint,j,k,l
9573       double precision PgradC(maxSAXS,3,maxres),
9574      &  PgradX(maxSAXS,3,maxres)
9575 #ifdef MPI
9576       double precision PgradC_(maxSAXS,3,maxres),
9577      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9578 #endif
9579       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9580      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9581      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9582      & auxX,auxX1,CACAgrad,Cnorm
9583       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9584       double precision dist
9585       external dist
9586 c  SAXS restraint penalty function
9587 #ifdef DEBUG
9588       write(iout,*) "------- SAXS penalty function start -------"
9589       write (iout,*) "nsaxs",nsaxs
9590       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9591       write (iout,*) "Psaxs"
9592       do i=1,nsaxs
9593         write (iout,'(i5,e15.5)') i, Psaxs(i)
9594       enddo
9595 #endif
9596       Esaxs_constr = 0.0d0
9597       do k=1,nsaxs
9598         Pcalc(k)=0.0d0
9599         do j=1,nres
9600           do l=1,3
9601             PgradC(k,l,j)=0.0d0
9602             PgradX(k,l,j)=0.0d0
9603           enddo
9604         enddo
9605       enddo
9606       do i=iatsc_s,iatsc_e
9607        if (itype(i).eq.ntyp1) cycle
9608        do iint=1,nint_gr(i)
9609          do j=istart(i,iint),iend(i,iint)
9610            if (itype(j).eq.ntyp1) cycle
9611 #ifdef ALLSAXS
9612            dijCACA=dist(i,j)
9613            dijCASC=dist(i,j+nres)
9614            dijSCCA=dist(i+nres,j)
9615            dijSCSC=dist(i+nres,j+nres)
9616            sigma2CACA=2.0d0/(pstok**2)
9617            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9618            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9619            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9620            do k=1,nsaxs
9621              dk = distsaxs(k)
9622              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9623              if (itype(j).ne.10) then
9624              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9625              else
9626              endif
9627              expCASC = 0.0d0
9628              if (itype(i).ne.10) then
9629              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9630              else
9631              expSCCA = 0.0d0
9632              endif
9633              if (itype(i).ne.10 .and. itype(j).ne.10) then
9634              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9635              else
9636              expSCSC = 0.0d0
9637              endif
9638              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9639 #ifdef DEBUG
9640              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9641 #endif
9642              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9643              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9644              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9645              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9646              do l=1,3
9647 c CA CA
9648                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9649                PgradC(k,l,i) = PgradC(k,l,i)-aux
9650                PgradC(k,l,j) = PgradC(k,l,j)+aux
9651 c CA SC
9652                if (itype(j).ne.10) then
9653                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9654                PgradC(k,l,i) = PgradC(k,l,i)-aux
9655                PgradC(k,l,j) = PgradC(k,l,j)+aux
9656                PgradX(k,l,j) = PgradX(k,l,j)+aux
9657                endif
9658 c SC CA
9659                if (itype(i).ne.10) then
9660                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9661                PgradX(k,l,i) = PgradX(k,l,i)-aux
9662                PgradC(k,l,i) = PgradC(k,l,i)-aux
9663                PgradC(k,l,j) = PgradC(k,l,j)+aux
9664                endif
9665 c SC SC
9666                if (itype(i).ne.10 .and. itype(j).ne.10) then
9667                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9668                PgradC(k,l,i) = PgradC(k,l,i)-aux
9669                PgradC(k,l,j) = PgradC(k,l,j)+aux
9670                PgradX(k,l,i) = PgradX(k,l,i)-aux
9671                PgradX(k,l,j) = PgradX(k,l,j)+aux
9672                endif
9673              enddo ! l
9674            enddo ! k
9675 #else
9676            dijCACA=dist(i,j)
9677            sigma2CACA=scal_rad**2*0.25d0/
9678      &        (restok(itype(j))**2+restok(itype(i))**2)
9679
9680            IF (saxs_cutoff.eq.0) THEN
9681            do k=1,nsaxs
9682              dk = distsaxs(k)
9683              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9684              Pcalc(k) = Pcalc(k)+expCACA
9685              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9686              do l=1,3
9687                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9688                PgradC(k,l,i) = PgradC(k,l,i)-aux
9689                PgradC(k,l,j) = PgradC(k,l,j)+aux
9690              enddo ! l
9691            enddo ! k
9692            ELSE
9693            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9694            do k=1,nsaxs
9695              dk = distsaxs(k)
9696 c             write (2,*) "ijk",i,j,k
9697              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9698              if (sss2.eq.0.0d0) cycle
9699              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9700              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9701              Pcalc(k) = Pcalc(k)+expCACA
9702 #ifdef DEBUG
9703              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9704 #endif
9705              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9706      &             ssgrad2*expCACA/sss2
9707              do l=1,3
9708 c CA CA
9709                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9710                PgradC(k,l,i) = PgradC(k,l,i)+aux
9711                PgradC(k,l,j) = PgradC(k,l,j)-aux
9712              enddo ! l
9713            enddo ! k
9714            ENDIF
9715 #endif
9716          enddo ! j
9717        enddo ! iint
9718       enddo ! i
9719 #ifdef MPI
9720       if (nfgtasks.gt.1) then
9721         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9722      &    MPI_SUM,king,FG_COMM,IERR)
9723         if (fg_rank.eq.king) then
9724           do k=1,nsaxs
9725             Pcalc(k) = Pcalc_(k)
9726           enddo
9727         endif
9728         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9729      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9730         if (fg_rank.eq.king) then
9731           do i=1,nres
9732             do l=1,3
9733               do k=1,nsaxs
9734                 PgradC(k,l,i) = PgradC_(k,l,i)
9735               enddo
9736             enddo
9737           enddo
9738         endif
9739 #ifdef ALLSAXS
9740         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9742         if (fg_rank.eq.king) then
9743           do i=1,nres
9744             do l=1,3
9745               do k=1,nsaxs
9746                 PgradX(k,l,i) = PgradX_(k,l,i)
9747               enddo
9748             enddo
9749           enddo
9750         endif
9751 #endif
9752       endif
9753 #endif
9754 #ifdef MPI
9755       if (fg_rank.eq.king) then
9756 #endif
9757       Cnorm = 0.0d0
9758       do k=1,nsaxs
9759         Cnorm = Cnorm + Pcalc(k)
9760       enddo
9761       Esaxs_constr = dlog(Cnorm)-wsaxs0
9762       do k=1,nsaxs
9763         if (Pcalc(k).gt.0.0d0)
9764      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9765 #ifdef DEBUG
9766         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9767 #endif
9768       enddo
9769 #ifdef DEBUG
9770       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9771 #endif
9772       do i=nnt,nct
9773         do l=1,3
9774           auxC=0.0d0
9775           auxC1=0.0d0
9776           auxX=0.0d0
9777           auxX1=0.d0
9778           do k=1,nsaxs
9779             if (Pcalc(k).gt.0)
9780      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9781             auxC1 = auxC1+PgradC(k,l,i)
9782 #ifdef ALLSAXS
9783             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9784             auxX1 = auxX1+PgradX(k,l,i)
9785 #endif
9786           enddo
9787           gsaxsC(l,i) = auxC - auxC1/Cnorm
9788 #ifdef ALLSAXS
9789           gsaxsX(l,i) = auxX - auxX1/Cnorm
9790 #endif
9791 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9792 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9793         enddo
9794       enddo
9795 #ifdef MPI
9796       endif
9797 #endif
9798       return
9799       end
9800 c----------------------------------------------------------------------------
9801       subroutine e_saxsC(Esaxs_constr)
9802       implicit none
9803       include 'DIMENSIONS'
9804 #ifdef MPI
9805       include "mpif.h"
9806       include "COMMON.SETUP"
9807       integer IERR
9808 #endif
9809       include 'COMMON.SBRIDGE'
9810       include 'COMMON.CHAIN'
9811       include 'COMMON.GEO'
9812       include 'COMMON.LOCAL'
9813       include 'COMMON.INTERACT'
9814       include 'COMMON.VAR'
9815       include 'COMMON.IOUNITS'
9816       include 'COMMON.DERIV'
9817       include 'COMMON.CONTROL'
9818       include 'COMMON.NAMES'
9819       include 'COMMON.FFIELD'
9820       include 'COMMON.LANGEVIN'
9821 c
9822       double precision Esaxs_constr
9823       integer i,iint,j,k,l
9824       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9825 #ifdef MPI
9826       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9827 #endif
9828       double precision dk,dijCASPH,dijSCSPH,
9829      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9830      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9831      & auxX,auxX1,Cnorm
9832 c  SAXS restraint penalty function
9833 #ifdef DEBUG
9834       write(iout,*) "------- SAXS penalty function start -------"
9835       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9836      & " isaxs_end",isaxs_end
9837       write (iout,*) "nnt",nnt," ntc",nct
9838       do i=nnt,nct
9839         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9840      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9841       enddo
9842       do i=nnt,nct
9843         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9844       enddo
9845 #endif
9846       Esaxs_constr = 0.0d0
9847       logPtot=0.0d0
9848       do j=isaxs_start,isaxs_end
9849         Pcalc_=0.0d0
9850         do i=1,nres
9851           do l=1,3
9852             PgradC(l,i)=0.0d0
9853             PgradX(l,i)=0.0d0
9854           enddo
9855         enddo
9856         do i=nnt,nct
9857           dijCASPH=0.0d0
9858           dijSCSPH=0.0d0
9859           do l=1,3
9860             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9861           enddo
9862           if (itype(i).ne.10) then
9863           do l=1,3
9864             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9865           enddo
9866           endif
9867           sigma2CA=2.0d0/pstok**2
9868           sigma2SC=4.0d0/restok(itype(i))**2
9869           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9870           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9871           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9872 #ifdef DEBUG
9873           write(*,*) "processor i j Pcalc",
9874      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9875 #endif
9876           CASPHgrad = sigma2CA*expCASPH
9877           SCSPHgrad = sigma2SC*expSCSPH
9878           do l=1,3
9879             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9880             PgradX(l,i) = PgradX(l,i) + aux
9881             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9882           enddo ! l
9883         enddo ! i
9884         do i=nnt,nct
9885           do l=1,3
9886             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9887             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9888           enddo
9889         enddo
9890         logPtot = logPtot - dlog(Pcalc_)
9891 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9892 c     &    " logPtot",logPtot
9893       enddo ! j
9894 #ifdef MPI
9895       if (nfgtasks.gt.1) then
9896 c        write (iout,*) "logPtot before reduction",logPtot
9897         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9898      &    MPI_SUM,king,FG_COMM,IERR)
9899         logPtot = logPtot_
9900 c        write (iout,*) "logPtot after reduction",logPtot
9901         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9902      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9903         if (fg_rank.eq.king) then
9904           do i=1,nres
9905             do l=1,3
9906               gsaxsC(l,i) = gsaxsC_(l,i)
9907             enddo
9908           enddo
9909         endif
9910         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9911      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9912         if (fg_rank.eq.king) then
9913           do i=1,nres
9914             do l=1,3
9915               gsaxsX(l,i) = gsaxsX_(l,i)
9916             enddo
9917           enddo
9918         endif
9919       endif
9920 #endif
9921       Esaxs_constr = logPtot
9922       return
9923       end