source/cluster/wham/src-M-SAXS.safe/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,100)
4044       ehpb=0.0D0
4045       ggg=0.0d0
4046 C      write (iout,*) ,"link_end",link_end,constr_dist
4047 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4048 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4049 c     &  " constr_dist",constr_dist
4050       if (link_end.eq.0.and.link_end_peak.eq.0) return
4051       do i=link_start_peak,link_end_peak
4052         ehpb_peak=0.0d0
4053 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4054 c     &   ipeak(1,i),ipeak(2,i)
4055         do ip=ipeak(1,i),ipeak(2,i)
4056           ii=ihpb_peak(ip)
4057           jj=jhpb_peak(ip)
4058           dd=dist(ii,jj)
4059           iip=ip-ipeak(1,i)+1
4060 C iii and jjj point to the residues for which the distance is assigned.
4061           if (ii.gt.nres) then
4062             iii=ii-nres
4063             jjj=jj-nres
4064           else
4065             iii=ii
4066             jjj=jj
4067           endif
4068           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4069           aux=dexp(-scal_peak*aux)
4070           ehpb_peak=ehpb_peak+aux
4071           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4072      &      forcon_peak(ip))*aux/dd
4073           do j=1,3
4074             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4075           enddo
4076           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4077      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4078      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4079         enddo
4080 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4081         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4082         do ip=ipeak(1,i),ipeak(2,i)
4083           iip=ip-ipeak(1,i)+1
4084           do j=1,3
4085             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4086           enddo
4087           ii=ihpb_peak(ip)
4088           jj=jhpb_peak(ip)
4089 C iii and jjj point to the residues for which the distance is assigned.
4090           if (ii.gt.nres) then
4091             iii=ii-nres
4092             jjj=jj-nres
4093           else
4094             iii=ii
4095             jjj=jj
4096           endif
4097           if (iii.lt.ii) then
4098             do j=1,3
4099               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4100               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4101             enddo
4102           endif
4103           do k=1,3
4104             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4105             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4106           enddo
4107         enddo
4108       enddo
4109       do i=link_start,link_end
4110 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4111 C CA-CA distance used in regularization of structure.
4112         ii=ihpb(i)
4113         jj=jhpb(i)
4114 C iii and jjj point to the residues for which the distance is assigned.
4115         if (ii.gt.nres) then
4116           iii=ii-nres
4117           jjj=jj-nres
4118         else
4119           iii=ii
4120           jjj=jj
4121         endif
4122 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4123 c     &    dhpb(i),dhpb1(i),forcon(i)
4124 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4125 C    distance and angle dependent SS bond potential.
4126 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4127 C     & iabs(itype(jjj)).eq.1) then
4128 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4129 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4130         if (.not.dyn_ss .and. i.le.nss) then
4131 C 15/02/13 CC dynamic SSbond - additional check
4132           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4133      &        iabs(itype(jjj)).eq.1) then
4134            call ssbond_ene(iii,jjj,eij)
4135            ehpb=ehpb+2*eij
4136          endif
4137 cd          write (iout,*) "eij",eij
4138 cd   &   ' waga=',waga,' fac=',fac
4139 !        else if (ii.gt.nres .and. jj.gt.nres) then
4140         else
4141 C Calculate the distance between the two points and its difference from the
4142 C target distance.
4143           dd=dist(ii,jj)
4144           if (irestr_type(i).eq.11) then
4145             ehpb=ehpb+fordepth(i)!**4.0d0
4146      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4147             fac=fordepth(i)!**4.0d0
4148      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4149             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4150      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4151      &        ehpb,irestr_type(i)
4152           else if (irestr_type(i).eq.10) then
4153 c AL 6//19/2018 cross-link restraints
4154             xdis = 0.5d0*(dd/forcon(i))**2
4155             expdis = dexp(-xdis)
4156 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4157             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4158 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4159 c     &          " wboltzd",wboltzd
4160             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4161 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4162             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4163      &           *expdis/(aux*forcon(i)**2)
4164             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4165      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4166      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4167           else if (irestr_type(i).eq.2) then
4168 c Quartic restraints
4169             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4170             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4171      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4172      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4173             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4174           else
4175 c Quadratic restraints
4176             rdis=dd-dhpb(i)
4177 C Get the force constant corresponding to this distance.
4178             waga=forcon(i)
4179 C Calculate the contribution to energy.
4180             ehpb=ehpb+0.5d0*waga*rdis*rdis
4181             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4182      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4183      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4184 C
4185 C Evaluate gradient.
4186 C
4187             fac=waga*rdis/dd
4188           endif
4189 c Calculate Cartesian gradient
4190           do j=1,3
4191             ggg(j)=fac*(c(j,jj)-c(j,ii))
4192           enddo
4193 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4194 C If this is a SC-SC distance, we need to calculate the contributions to the
4195 C Cartesian gradient in the SC vectors (ghpbx).
4196           if (iii.lt.ii) then
4197             do j=1,3
4198               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4199               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4200             enddo
4201           endif
4202           do k=1,3
4203             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4204             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4205           enddo
4206         endif
4207       enddo
4208       return
4209       end
4210 C--------------------------------------------------------------------------
4211       subroutine ssbond_ene(i,j,eij)
4212 C
4213 C Calculate the distance and angle dependent SS-bond potential energy
4214 C using a free-energy function derived based on RHF/6-31G** ab initio
4215 C calculations of diethyl disulfide.
4216 C
4217 C A. Liwo and U. Kozlowska, 11/24/03
4218 C
4219       implicit real*8 (a-h,o-z)
4220       include 'DIMENSIONS'
4221       include 'COMMON.SBRIDGE'
4222       include 'COMMON.CHAIN'
4223       include 'COMMON.DERIV'
4224       include 'COMMON.LOCAL'
4225       include 'COMMON.INTERACT'
4226       include 'COMMON.VAR'
4227       include 'COMMON.IOUNITS'
4228       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4229       itypi=iabs(itype(i))
4230       xi=c(1,nres+i)
4231       yi=c(2,nres+i)
4232       zi=c(3,nres+i)
4233       dxi=dc_norm(1,nres+i)
4234       dyi=dc_norm(2,nres+i)
4235       dzi=dc_norm(3,nres+i)
4236       dsci_inv=dsc_inv(itypi)
4237       itypj=iabs(itype(j))
4238       dscj_inv=dsc_inv(itypj)
4239       xj=c(1,nres+j)-xi
4240       yj=c(2,nres+j)-yi
4241       zj=c(3,nres+j)-zi
4242       dxj=dc_norm(1,nres+j)
4243       dyj=dc_norm(2,nres+j)
4244       dzj=dc_norm(3,nres+j)
4245       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4246       rij=dsqrt(rrij)
4247       erij(1)=xj*rij
4248       erij(2)=yj*rij
4249       erij(3)=zj*rij
4250       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4251       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4252       om12=dxi*dxj+dyi*dyj+dzi*dzj
4253       do k=1,3
4254         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4255         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4256       enddo
4257       rij=1.0d0/rij
4258       deltad=rij-d0cm
4259       deltat1=1.0d0-om1
4260       deltat2=1.0d0+om2
4261       deltat12=om2-om1+2.0d0
4262       cosphi=om12-om1*om2
4263       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4264      &  +akct*deltad*deltat12
4265      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4266 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4267 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4268 c     &  " deltat12",deltat12," eij",eij
4269       ed=2*akcm*deltad+akct*deltat12
4270       pom1=akct*deltad
4271       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4272       eom1=-2*akth*deltat1-pom1-om2*pom2
4273       eom2= 2*akth*deltat2+pom1-om1*pom2
4274       eom12=pom2
4275       do k=1,3
4276         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4277       enddo
4278       do k=1,3
4279         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4280      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4281         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4282      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4283       enddo
4284 C
4285 C Calculate the components of the gradient in DC and X
4286 C
4287       do k=i,j-1
4288         do l=1,3
4289           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4290         enddo
4291       enddo
4292       return
4293       end
4294 C--------------------------------------------------------------------------
4295       subroutine ebond(estr)
4296 c
4297 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4298 c
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.GEO'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.VAR'
4306       include 'COMMON.CHAIN'
4307       include 'COMMON.IOUNITS'
4308       include 'COMMON.NAMES'
4309       include 'COMMON.FFIELD'
4310       include 'COMMON.CONTROL'
4311       double precision u(3),ud(3)
4312       estr=0.0d0
4313       estr1=0.0d0
4314 c      write (iout,*) "distchainmax",distchainmax
4315       do i=nnt+1,nct
4316         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4317 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4318 C          do j=1,3
4319 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4320 C     &      *dc(j,i-1)/vbld(i)
4321 C          enddo
4322 C          if (energy_dec) write(iout,*)
4323 C     &       "estr1",i,vbld(i),distchainmax,
4324 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4325 C        else
4326          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4327         diff = vbld(i)-vbldpDUM
4328 C         write(iout,*) i,diff
4329          else
4330           diff = vbld(i)-vbldp0
4331 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4332          endif
4333           estr=estr+diff*diff
4334           do j=1,3
4335             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4336           enddo
4337 C        endif
4338 C        write (iout,'(a7,i5,4f7.3)')
4339 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4340       enddo
4341       estr=0.5d0*AKP*estr+estr1
4342 c
4343 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4344 c
4345       do i=nnt,nct
4346         iti=iabs(itype(i))
4347         if (iti.ne.10 .and. iti.ne.ntyp1) then
4348           nbi=nbondterm(iti)
4349           if (nbi.eq.1) then
4350             diff=vbld(i+nres)-vbldsc0(1,iti)
4351 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4352 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4353             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4354             do j=1,3
4355               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4356             enddo
4357           else
4358             do j=1,nbi
4359               diff=vbld(i+nres)-vbldsc0(j,iti)
4360               ud(j)=aksc(j,iti)*diff
4361               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4362             enddo
4363             uprod=u(1)
4364             do j=2,nbi
4365               uprod=uprod*u(j)
4366             enddo
4367             usum=0.0d0
4368             usumsqder=0.0d0
4369             do j=1,nbi
4370               uprod1=1.0d0
4371               uprod2=1.0d0
4372               do k=1,nbi
4373                 if (k.ne.j) then
4374                   uprod1=uprod1*u(k)
4375                   uprod2=uprod2*u(k)*u(k)
4376                 endif
4377               enddo
4378               usum=usum+uprod1
4379               usumsqder=usumsqder+ud(j)*uprod2
4380             enddo
4381 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4382 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4383             estr=estr+uprod/usum
4384             do j=1,3
4385              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4386             enddo
4387           endif
4388         endif
4389       enddo
4390       return
4391       end
4392 #ifdef CRYST_THETA
4393 C--------------------------------------------------------------------------
4394       subroutine ebend(etheta,ethetacnstr)
4395 C
4396 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4397 C angles gamma and its derivatives in consecutive thetas and gammas.
4398 C
4399       implicit real*8 (a-h,o-z)
4400       include 'DIMENSIONS'
4401       include 'COMMON.LOCAL'
4402       include 'COMMON.GEO'
4403       include 'COMMON.INTERACT'
4404       include 'COMMON.DERIV'
4405       include 'COMMON.VAR'
4406       include 'COMMON.CHAIN'
4407       include 'COMMON.IOUNITS'
4408       include 'COMMON.NAMES'
4409       include 'COMMON.FFIELD'
4410       include 'COMMON.TORCNSTR'
4411       common /calcthet/ term1,term2,termm,diffak,ratak,
4412      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4413      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4414       double precision y(2),z(2)
4415       delta=0.02d0*pi
4416 c      time11=dexp(-2*time)
4417 c      time12=1.0d0
4418       etheta=0.0D0
4419 c      write (iout,*) "nres",nres
4420 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4421 c      write (iout,*) ithet_start,ithet_end
4422       do i=ithet_start,ithet_end
4423 C        if (itype(i-1).eq.ntyp1) cycle
4424         if (i.le.2) cycle
4425         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4426      &  .or.itype(i).eq.ntyp1) cycle
4427 C Zero the energy function and its derivative at 0 or pi.
4428         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4429         it=itype(i-1)
4430         ichir1=isign(1,itype(i-2))
4431         ichir2=isign(1,itype(i))
4432          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4433          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4434          if (itype(i-1).eq.10) then
4435           itype1=isign(10,itype(i-2))
4436           ichir11=isign(1,itype(i-2))
4437           ichir12=isign(1,itype(i-2))
4438           itype2=isign(10,itype(i))
4439           ichir21=isign(1,itype(i))
4440           ichir22=isign(1,itype(i))
4441          endif
4442          if (i.eq.3) then
4443           y(1)=0.0D0
4444           y(2)=0.0D0
4445           else
4446
4447         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4448 #ifdef OSF
4449           phii=phi(i)
4450 c          icrc=0
4451 c          call proc_proc(phii,icrc)
4452           if (icrc.eq.1) phii=150.0
4453 #else
4454           phii=phi(i)
4455 #endif
4456           y(1)=dcos(phii)
4457           y(2)=dsin(phii)
4458         else
4459           y(1)=0.0D0
4460           y(2)=0.0D0
4461         endif
4462         endif
4463         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4464 #ifdef OSF
4465           phii1=phi(i+1)
4466 c          icrc=0
4467 c          call proc_proc(phii1,icrc)
4468           if (icrc.eq.1) phii1=150.0
4469           phii1=pinorm(phii1)
4470           z(1)=cos(phii1)
4471 #else
4472           phii1=phi(i+1)
4473           z(1)=dcos(phii1)
4474 #endif
4475           z(2)=dsin(phii1)
4476         else
4477           z(1)=0.0D0
4478           z(2)=0.0D0
4479         endif
4480 C Calculate the "mean" value of theta from the part of the distribution
4481 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4482 C In following comments this theta will be referred to as t_c.
4483         thet_pred_mean=0.0d0
4484         do k=1,2
4485             athetk=athet(k,it,ichir1,ichir2)
4486             bthetk=bthet(k,it,ichir1,ichir2)
4487           if (it.eq.10) then
4488              athetk=athet(k,itype1,ichir11,ichir12)
4489              bthetk=bthet(k,itype2,ichir21,ichir22)
4490           endif
4491           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4492         enddo
4493 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4494         dthett=thet_pred_mean*ssd
4495         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4496 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4497 C Derivatives of the "mean" values in gamma1 and gamma2.
4498         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4499      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4500          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4501      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4502          if (it.eq.10) then
4503       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4504      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4505         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4506      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4507          endif
4508         if (theta(i).gt.pi-delta) then
4509           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4510      &         E_tc0)
4511           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4512           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4513           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4514      &        E_theta)
4515           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4516      &        E_tc)
4517         else if (theta(i).lt.delta) then
4518           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4519           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4520           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4521      &        E_theta)
4522           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4523           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4524      &        E_tc)
4525         else
4526           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4527      &        E_theta,E_tc)
4528         endif
4529         etheta=etheta+ethetai
4530 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4531 c     &      'ebend',i,ethetai,theta(i),itype(i)
4532 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4533 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4534         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4535         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4536         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4537 c 1215   continue
4538       enddo
4539       ethetacnstr=0.0d0
4540 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4541       do i=1,ntheta_constr
4542         itheta=itheta_constr(i)
4543         thetiii=theta(itheta)
4544         difi=pinorm(thetiii-theta_constr0(i))
4545         if (difi.gt.theta_drange(i)) then
4546           difi=difi-theta_drange(i)
4547           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4548           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4549      &    +for_thet_constr(i)*difi**3
4550         else if (difi.lt.-drange(i)) then
4551           difi=difi+drange(i)
4552           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4553           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4554      &    +for_thet_constr(i)*difi**3
4555         else
4556           difi=0.0
4557         endif
4558 C       if (energy_dec) then
4559 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4560 C     &    i,itheta,rad2deg*thetiii,
4561 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4562 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4563 C     &    gloc(itheta+nphi-2,icg)
4564 C        endif
4565       enddo
4566 C Ufff.... We've done all this!!!
4567       return
4568       end
4569 C---------------------------------------------------------------------------
4570       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4571      &     E_tc)
4572       implicit real*8 (a-h,o-z)
4573       include 'DIMENSIONS'
4574       include 'COMMON.LOCAL'
4575       include 'COMMON.IOUNITS'
4576       common /calcthet/ term1,term2,termm,diffak,ratak,
4577      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4578      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4579 C Calculate the contributions to both Gaussian lobes.
4580 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4581 C The "polynomial part" of the "standard deviation" of this part of
4582 C the distribution.
4583         sig=polthet(3,it)
4584         do j=2,0,-1
4585           sig=sig*thet_pred_mean+polthet(j,it)
4586         enddo
4587 C Derivative of the "interior part" of the "standard deviation of the"
4588 C gamma-dependent Gaussian lobe in t_c.
4589         sigtc=3*polthet(3,it)
4590         do j=2,1,-1
4591           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4592         enddo
4593         sigtc=sig*sigtc
4594 C Set the parameters of both Gaussian lobes of the distribution.
4595 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4596         fac=sig*sig+sigc0(it)
4597         sigcsq=fac+fac
4598         sigc=1.0D0/sigcsq
4599 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4600         sigsqtc=-4.0D0*sigcsq*sigtc
4601 c       print *,i,sig,sigtc,sigsqtc
4602 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4603         sigtc=-sigtc/(fac*fac)
4604 C Following variable is sigma(t_c)**(-2)
4605         sigcsq=sigcsq*sigcsq
4606         sig0i=sig0(it)
4607         sig0inv=1.0D0/sig0i**2
4608         delthec=thetai-thet_pred_mean
4609         delthe0=thetai-theta0i
4610         term1=-0.5D0*sigcsq*delthec*delthec
4611         term2=-0.5D0*sig0inv*delthe0*delthe0
4612 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4613 C NaNs in taking the logarithm. We extract the largest exponent which is added
4614 C to the energy (this being the log of the distribution) at the end of energy
4615 C term evaluation for this virtual-bond angle.
4616         if (term1.gt.term2) then
4617           termm=term1
4618           term2=dexp(term2-termm)
4619           term1=1.0d0
4620         else
4621           termm=term2
4622           term1=dexp(term1-termm)
4623           term2=1.0d0
4624         endif
4625 C The ratio between the gamma-independent and gamma-dependent lobes of
4626 C the distribution is a Gaussian function of thet_pred_mean too.
4627         diffak=gthet(2,it)-thet_pred_mean
4628         ratak=diffak/gthet(3,it)**2
4629         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4630 C Let's differentiate it in thet_pred_mean NOW.
4631         aktc=ak*ratak
4632 C Now put together the distribution terms to make complete distribution.
4633         termexp=term1+ak*term2
4634         termpre=sigc+ak*sig0i
4635 C Contribution of the bending energy from this theta is just the -log of
4636 C the sum of the contributions from the two lobes and the pre-exponential
4637 C factor. Simple enough, isn't it?
4638         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4639 C NOW the derivatives!!!
4640 C 6/6/97 Take into account the deformation.
4641         E_theta=(delthec*sigcsq*term1
4642      &       +ak*delthe0*sig0inv*term2)/termexp
4643         E_tc=((sigtc+aktc*sig0i)/termpre
4644      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4645      &       aktc*term2)/termexp)
4646       return
4647       end
4648 c-----------------------------------------------------------------------------
4649       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4650       implicit real*8 (a-h,o-z)
4651       include 'DIMENSIONS'
4652       include 'COMMON.LOCAL'
4653       include 'COMMON.IOUNITS'
4654       common /calcthet/ term1,term2,termm,diffak,ratak,
4655      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4656      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4657       delthec=thetai-thet_pred_mean
4658       delthe0=thetai-theta0i
4659 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4660       t3 = thetai-thet_pred_mean
4661       t6 = t3**2
4662       t9 = term1
4663       t12 = t3*sigcsq
4664       t14 = t12+t6*sigsqtc
4665       t16 = 1.0d0
4666       t21 = thetai-theta0i
4667       t23 = t21**2
4668       t26 = term2
4669       t27 = t21*t26
4670       t32 = termexp
4671       t40 = t32**2
4672       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4673      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4674      & *(-t12*t9-ak*sig0inv*t27)
4675       return
4676       end
4677 #else
4678 C--------------------------------------------------------------------------
4679       subroutine ebend(etheta)
4680 C
4681 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4682 C angles gamma and its derivatives in consecutive thetas and gammas.
4683 C ab initio-derived potentials from
4684 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4685 C
4686       implicit real*8 (a-h,o-z)
4687       include 'DIMENSIONS'
4688       include 'COMMON.LOCAL'
4689       include 'COMMON.GEO'
4690       include 'COMMON.INTERACT'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.VAR'
4693       include 'COMMON.CHAIN'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.NAMES'
4696       include 'COMMON.FFIELD'
4697       include 'COMMON.CONTROL'
4698       include 'COMMON.TORCNSTR'
4699       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4700      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4701      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4702      & sinph1ph2(maxdouble,maxdouble)
4703       logical lprn /.false./, lprn1 /.false./
4704       etheta=0.0D0
4705 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4706       do i=ithet_start,ithet_end
4707 C         if (i.eq.2) cycle
4708 C        if (itype(i-1).eq.ntyp1) cycle
4709         if (i.le.2) cycle
4710         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4711      &  .or.itype(i).eq.ntyp1) cycle
4712         if (iabs(itype(i+1)).eq.20) iblock=2
4713         if (iabs(itype(i+1)).ne.20) iblock=1
4714         dethetai=0.0d0
4715         dephii=0.0d0
4716         dephii1=0.0d0
4717         theti2=0.5d0*theta(i)
4718         ityp2=ithetyp((itype(i-1)))
4719         do k=1,nntheterm
4720           coskt(k)=dcos(k*theti2)
4721           sinkt(k)=dsin(k*theti2)
4722         enddo
4723         if (i.eq.3) then
4724           phii=0.0d0
4725           ityp1=nthetyp+1
4726           do k=1,nsingle
4727             cosph1(k)=0.0d0
4728             sinph1(k)=0.0d0
4729           enddo
4730         else
4731         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4732 #ifdef OSF
4733           phii=phi(i)
4734           if (phii.ne.phii) phii=150.0
4735 #else
4736           phii=phi(i)
4737 #endif
4738           ityp1=ithetyp((itype(i-2)))
4739           do k=1,nsingle
4740             cosph1(k)=dcos(k*phii)
4741             sinph1(k)=dsin(k*phii)
4742           enddo
4743         else
4744           phii=0.0d0
4745 c          ityp1=nthetyp+1
4746           do k=1,nsingle
4747             ityp1=ithetyp((itype(i-2)))
4748             cosph1(k)=0.0d0
4749             sinph1(k)=0.0d0
4750           enddo
4751         endif
4752         endif
4753         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4754 #ifdef OSF
4755           phii1=phi(i+1)
4756           if (phii1.ne.phii1) phii1=150.0
4757           phii1=pinorm(phii1)
4758 #else
4759           phii1=phi(i+1)
4760 #endif
4761           ityp3=ithetyp((itype(i)))
4762           do k=1,nsingle
4763             cosph2(k)=dcos(k*phii1)
4764             sinph2(k)=dsin(k*phii1)
4765           enddo
4766         else
4767           phii1=0.0d0
4768 c          ityp3=nthetyp+1
4769           ityp3=ithetyp((itype(i)))
4770           do k=1,nsingle
4771             cosph2(k)=0.0d0
4772             sinph2(k)=0.0d0
4773           enddo
4774         endif
4775 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4776 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4777 c        call flush(iout)
4778         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4779         do k=1,ndouble
4780           do l=1,k-1
4781             ccl=cosph1(l)*cosph2(k-l)
4782             ssl=sinph1(l)*sinph2(k-l)
4783             scl=sinph1(l)*cosph2(k-l)
4784             csl=cosph1(l)*sinph2(k-l)
4785             cosph1ph2(l,k)=ccl-ssl
4786             cosph1ph2(k,l)=ccl+ssl
4787             sinph1ph2(l,k)=scl+csl
4788             sinph1ph2(k,l)=scl-csl
4789           enddo
4790         enddo
4791         if (lprn) then
4792         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4793      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4794         write (iout,*) "coskt and sinkt"
4795         do k=1,nntheterm
4796           write (iout,*) k,coskt(k),sinkt(k)
4797         enddo
4798         endif
4799         do k=1,ntheterm
4800           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4801           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4802      &      *coskt(k)
4803           if (lprn)
4804      &    write (iout,*) "k",k,"
4805      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4806      &     " ethetai",ethetai
4807         enddo
4808         if (lprn) then
4809         write (iout,*) "cosph and sinph"
4810         do k=1,nsingle
4811           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4812         enddo
4813         write (iout,*) "cosph1ph2 and sinph2ph2"
4814         do k=2,ndouble
4815           do l=1,k-1
4816             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4817      &         sinph1ph2(l,k),sinph1ph2(k,l)
4818           enddo
4819         enddo
4820         write(iout,*) "ethetai",ethetai
4821         endif
4822         do m=1,ntheterm2
4823           do k=1,nsingle
4824             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4825      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4826      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4827      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4828             ethetai=ethetai+sinkt(m)*aux
4829             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4830             dephii=dephii+k*sinkt(m)*(
4831      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4832      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4833             dephii1=dephii1+k*sinkt(m)*(
4834      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4835      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4836             if (lprn)
4837      &      write (iout,*) "m",m," k",k," bbthet",
4838      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4839      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4840      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4841      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4842           enddo
4843         enddo
4844         if (lprn)
4845      &  write(iout,*) "ethetai",ethetai
4846         do m=1,ntheterm3
4847           do k=2,ndouble
4848             do l=1,k-1
4849               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4850      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4851      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4852      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4853               ethetai=ethetai+sinkt(m)*aux
4854               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4855               dephii=dephii+l*sinkt(m)*(
4856      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4857      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4858      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4859      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4860               dephii1=dephii1+(k-l)*sinkt(m)*(
4861      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4862      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4863      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4864      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4865               if (lprn) then
4866               write (iout,*) "m",m," k",k," l",l," ffthet",
4867      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4868      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4869      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4870      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4871      &            " ethetai",ethetai
4872               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4873      &            cosph1ph2(k,l)*sinkt(m),
4874      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4875               endif
4876             enddo
4877           enddo
4878         enddo
4879 10      continue
4880         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4881      &   i,theta(i)*rad2deg,phii*rad2deg,
4882      &   phii1*rad2deg,ethetai
4883         etheta=etheta+ethetai
4884         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4885         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4886 c        gloc(nphi+i-2,icg)=wang*dethetai
4887         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4888       enddo
4889       return
4890       end
4891 #endif
4892 #ifdef CRYST_SC
4893 c-----------------------------------------------------------------------------
4894       subroutine esc(escloc)
4895 C Calculate the local energy of a side chain and its derivatives in the
4896 C corresponding virtual-bond valence angles THETA and the spherical angles
4897 C ALPHA and OMEGA.
4898       implicit real*8 (a-h,o-z)
4899       include 'DIMENSIONS'
4900       include 'COMMON.GEO'
4901       include 'COMMON.LOCAL'
4902       include 'COMMON.VAR'
4903       include 'COMMON.INTERACT'
4904       include 'COMMON.DERIV'
4905       include 'COMMON.CHAIN'
4906       include 'COMMON.IOUNITS'
4907       include 'COMMON.NAMES'
4908       include 'COMMON.FFIELD'
4909       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4910      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4911       common /sccalc/ time11,time12,time112,theti,it,nlobit
4912       delta=0.02d0*pi
4913       escloc=0.0D0
4914 C      write (iout,*) 'ESC'
4915       do i=loc_start,loc_end
4916         it=itype(i)
4917         if (it.eq.ntyp1) cycle
4918         if (it.eq.10) goto 1
4919         nlobit=nlob(iabs(it))
4920 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4921 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4922         theti=theta(i+1)-pipol
4923         x(1)=dtan(theti)
4924         x(2)=alph(i)
4925         x(3)=omeg(i)
4926 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4927
4928         if (x(2).gt.pi-delta) then
4929           xtemp(1)=x(1)
4930           xtemp(2)=pi-delta
4931           xtemp(3)=x(3)
4932           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4933           xtemp(2)=pi
4934           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4935           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4936      &        escloci,dersc(2))
4937           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4938      &        ddersc0(1),dersc(1))
4939           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4940      &        ddersc0(3),dersc(3))
4941           xtemp(2)=pi-delta
4942           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4943           xtemp(2)=pi
4944           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4945           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4946      &            dersc0(2),esclocbi,dersc02)
4947           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4948      &            dersc12,dersc01)
4949           call splinthet(x(2),0.5d0*delta,ss,ssd)
4950           dersc0(1)=dersc01
4951           dersc0(2)=dersc02
4952           dersc0(3)=0.0d0
4953           do k=1,3
4954             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4955           enddo
4956           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4957           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4958      &             esclocbi,ss,ssd
4959           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4960 c         escloci=esclocbi
4961 c         write (iout,*) escloci
4962         else if (x(2).lt.delta) then
4963           xtemp(1)=x(1)
4964           xtemp(2)=delta
4965           xtemp(3)=x(3)
4966           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4967           xtemp(2)=0.0d0
4968           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4969           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4970      &        escloci,dersc(2))
4971           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4972      &        ddersc0(1),dersc(1))
4973           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4974      &        ddersc0(3),dersc(3))
4975           xtemp(2)=delta
4976           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4977           xtemp(2)=0.0d0
4978           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4979           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4980      &            dersc0(2),esclocbi,dersc02)
4981           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4982      &            dersc12,dersc01)
4983           dersc0(1)=dersc01
4984           dersc0(2)=dersc02
4985           dersc0(3)=0.0d0
4986           call splinthet(x(2),0.5d0*delta,ss,ssd)
4987           do k=1,3
4988             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4989           enddo
4990           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4991 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4992 c     &             esclocbi,ss,ssd
4993           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4994 C         write (iout,*) 'i=',i, escloci
4995         else
4996           call enesc(x,escloci,dersc,ddummy,.false.)
4997         endif
4998
4999         escloc=escloc+escloci
5000 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5001             write (iout,'(a6,i5,0pf7.3)')
5002      &     'escloc',i,escloci
5003
5004         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5005      &   wscloc*dersc(1)
5006         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5007         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5008     1   continue
5009       enddo
5010       return
5011       end
5012 C---------------------------------------------------------------------------
5013       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5014       implicit real*8 (a-h,o-z)
5015       include 'DIMENSIONS'
5016       include 'COMMON.GEO'
5017       include 'COMMON.LOCAL'
5018       include 'COMMON.IOUNITS'
5019       common /sccalc/ time11,time12,time112,theti,it,nlobit
5020       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5021       double precision contr(maxlob,-1:1)
5022       logical mixed
5023 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5024         escloc_i=0.0D0
5025         do j=1,3
5026           dersc(j)=0.0D0
5027           if (mixed) ddersc(j)=0.0d0
5028         enddo
5029         x3=x(3)
5030
5031 C Because of periodicity of the dependence of the SC energy in omega we have
5032 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5033 C To avoid underflows, first compute & store the exponents.
5034
5035         do iii=-1,1
5036
5037           x(3)=x3+iii*dwapi
5038
5039           do j=1,nlobit
5040             do k=1,3
5041               z(k)=x(k)-censc(k,j,it)
5042             enddo
5043             do k=1,3
5044               Axk=0.0D0
5045               do l=1,3
5046                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5047               enddo
5048               Ax(k,j,iii)=Axk
5049             enddo
5050             expfac=0.0D0
5051             do k=1,3
5052               expfac=expfac+Ax(k,j,iii)*z(k)
5053             enddo
5054             contr(j,iii)=expfac
5055           enddo ! j
5056
5057         enddo ! iii
5058
5059         x(3)=x3
5060 C As in the case of ebend, we want to avoid underflows in exponentiation and
5061 C subsequent NaNs and INFs in energy calculation.
5062 C Find the largest exponent
5063         emin=contr(1,-1)
5064         do iii=-1,1
5065           do j=1,nlobit
5066             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5067           enddo
5068         enddo
5069         emin=0.5D0*emin
5070 cd      print *,'it=',it,' emin=',emin
5071
5072 C Compute the contribution to SC energy and derivatives
5073         do iii=-1,1
5074
5075           do j=1,nlobit
5076             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5077 cd          print *,'j=',j,' expfac=',expfac
5078             escloc_i=escloc_i+expfac
5079             do k=1,3
5080               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5081             enddo
5082             if (mixed) then
5083               do k=1,3,2
5084                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5085      &            +gaussc(k,2,j,it))*expfac
5086               enddo
5087             endif
5088           enddo
5089
5090         enddo ! iii
5091
5092         dersc(1)=dersc(1)/cos(theti)**2
5093         ddersc(1)=ddersc(1)/cos(theti)**2
5094         ddersc(3)=ddersc(3)
5095
5096         escloci=-(dlog(escloc_i)-emin)
5097         do j=1,3
5098           dersc(j)=dersc(j)/escloc_i
5099         enddo
5100         if (mixed) then
5101           do j=1,3,2
5102             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5103           enddo
5104         endif
5105       return
5106       end
5107 C------------------------------------------------------------------------------
5108       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5109       implicit real*8 (a-h,o-z)
5110       include 'DIMENSIONS'
5111       include 'COMMON.GEO'
5112       include 'COMMON.LOCAL'
5113       include 'COMMON.IOUNITS'
5114       common /sccalc/ time11,time12,time112,theti,it,nlobit
5115       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5116       double precision contr(maxlob)
5117       logical mixed
5118
5119       escloc_i=0.0D0
5120
5121       do j=1,3
5122         dersc(j)=0.0D0
5123       enddo
5124
5125       do j=1,nlobit
5126         do k=1,2
5127           z(k)=x(k)-censc(k,j,it)
5128         enddo
5129         z(3)=dwapi
5130         do k=1,3
5131           Axk=0.0D0
5132           do l=1,3
5133             Axk=Axk+gaussc(l,k,j,it)*z(l)
5134           enddo
5135           Ax(k,j)=Axk
5136         enddo
5137         expfac=0.0D0
5138         do k=1,3
5139           expfac=expfac+Ax(k,j)*z(k)
5140         enddo
5141         contr(j)=expfac
5142       enddo ! j
5143
5144 C As in the case of ebend, we want to avoid underflows in exponentiation and
5145 C subsequent NaNs and INFs in energy calculation.
5146 C Find the largest exponent
5147       emin=contr(1)
5148       do j=1,nlobit
5149         if (emin.gt.contr(j)) emin=contr(j)
5150       enddo
5151       emin=0.5D0*emin
5152
5153 C Compute the contribution to SC energy and derivatives
5154
5155       dersc12=0.0d0
5156       do j=1,nlobit
5157         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5158         escloc_i=escloc_i+expfac
5159         do k=1,2
5160           dersc(k)=dersc(k)+Ax(k,j)*expfac
5161         enddo
5162         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5163      &            +gaussc(1,2,j,it))*expfac
5164         dersc(3)=0.0d0
5165       enddo
5166
5167       dersc(1)=dersc(1)/cos(theti)**2
5168       dersc12=dersc12/cos(theti)**2
5169       escloci=-(dlog(escloc_i)-emin)
5170       do j=1,2
5171         dersc(j)=dersc(j)/escloc_i
5172       enddo
5173       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5174       return
5175       end
5176 #else
5177 c----------------------------------------------------------------------------------
5178       subroutine esc(escloc)
5179 C Calculate the local energy of a side chain and its derivatives in the
5180 C corresponding virtual-bond valence angles THETA and the spherical angles
5181 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5182 C added by Urszula Kozlowska. 07/11/2007
5183 C
5184       implicit real*8 (a-h,o-z)
5185       include 'DIMENSIONS'
5186       include 'COMMON.GEO'
5187       include 'COMMON.LOCAL'
5188       include 'COMMON.VAR'
5189       include 'COMMON.SCROT'
5190       include 'COMMON.INTERACT'
5191       include 'COMMON.DERIV'
5192       include 'COMMON.CHAIN'
5193       include 'COMMON.IOUNITS'
5194       include 'COMMON.NAMES'
5195       include 'COMMON.FFIELD'
5196       include 'COMMON.CONTROL'
5197       include 'COMMON.VECTORS'
5198       double precision x_prime(3),y_prime(3),z_prime(3)
5199      &    , sumene,dsc_i,dp2_i,x(65),
5200      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5201      &    de_dxx,de_dyy,de_dzz,de_dt
5202       double precision s1_t,s1_6_t,s2_t,s2_6_t
5203       double precision
5204      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5205      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5206      & dt_dCi(3),dt_dCi1(3)
5207       common /sccalc/ time11,time12,time112,theti,it,nlobit
5208       delta=0.02d0*pi
5209       escloc=0.0D0
5210       do i=loc_start,loc_end
5211         if (itype(i).eq.ntyp1) cycle
5212         costtab(i+1) =dcos(theta(i+1))
5213         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5214         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5215         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5216         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5217         cosfac=dsqrt(cosfac2)
5218         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5219         sinfac=dsqrt(sinfac2)
5220         it=iabs(itype(i))
5221         if (it.eq.10) goto 1
5222 c
5223 C  Compute the axes of tghe local cartesian coordinates system; store in
5224 c   x_prime, y_prime and z_prime
5225 c
5226         do j=1,3
5227           x_prime(j) = 0.00
5228           y_prime(j) = 0.00
5229           z_prime(j) = 0.00
5230         enddo
5231 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5232 C     &   dc_norm(3,i+nres)
5233         do j = 1,3
5234           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5235           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5236         enddo
5237         do j = 1,3
5238           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5239         enddo
5240 c       write (2,*) "i",i
5241 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5242 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5243 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5244 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5245 c      & " xy",scalar(x_prime(1),y_prime(1)),
5246 c      & " xz",scalar(x_prime(1),z_prime(1)),
5247 c      & " yy",scalar(y_prime(1),y_prime(1)),
5248 c      & " yz",scalar(y_prime(1),z_prime(1)),
5249 c      & " zz",scalar(z_prime(1),z_prime(1))
5250 c
5251 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5252 C to local coordinate system. Store in xx, yy, zz.
5253 c
5254         xx=0.0d0
5255         yy=0.0d0
5256         zz=0.0d0
5257         do j = 1,3
5258           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5259           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5260           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5261         enddo
5262
5263         xxtab(i)=xx
5264         yytab(i)=yy
5265         zztab(i)=zz
5266 C
5267 C Compute the energy of the ith side cbain
5268 C
5269 c        write (2,*) "xx",xx," yy",yy," zz",zz
5270         it=iabs(itype(i))
5271         do j = 1,65
5272           x(j) = sc_parmin(j,it)
5273         enddo
5274 #ifdef CHECK_COORD
5275 Cc diagnostics - remove later
5276         xx1 = dcos(alph(2))
5277         yy1 = dsin(alph(2))*dcos(omeg(2))
5278         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5279         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5280      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5281      &    xx1,yy1,zz1
5282 C,"  --- ", xx_w,yy_w,zz_w
5283 c end diagnostics
5284 #endif
5285         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5286      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5287      &   + x(10)*yy*zz
5288         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5289      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5290      & + x(20)*yy*zz
5291         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5292      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5293      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5294      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5295      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5296      &  +x(40)*xx*yy*zz
5297         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5298      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5299      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5300      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5301      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5302      &  +x(60)*xx*yy*zz
5303         dsc_i   = 0.743d0+x(61)
5304         dp2_i   = 1.9d0+x(62)
5305         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5306      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5307         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5308      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5309         s1=(1+x(63))/(0.1d0 + dscp1)
5310         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5311         s2=(1+x(65))/(0.1d0 + dscp2)
5312         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5313         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5314      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5315 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5316 c     &   sumene4,
5317 c     &   dscp1,dscp2,sumene
5318 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5319         escloc = escloc + sumene
5320 c        write (2,*) "escloc",escloc
5321 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5322 c     &  zz,xx,yy
5323         if (.not. calc_grad) goto 1
5324 #ifdef DEBUG
5325 C
5326 C This section to check the numerical derivatives of the energy of ith side
5327 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5328 C #define DEBUG in the code to turn it on.
5329 C
5330         write (2,*) "sumene               =",sumene
5331         aincr=1.0d-7
5332         xxsave=xx
5333         xx=xx+aincr
5334         write (2,*) xx,yy,zz
5335         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5336         de_dxx_num=(sumenep-sumene)/aincr
5337         xx=xxsave
5338         write (2,*) "xx+ sumene from enesc=",sumenep
5339         yysave=yy
5340         yy=yy+aincr
5341         write (2,*) xx,yy,zz
5342         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5343         de_dyy_num=(sumenep-sumene)/aincr
5344         yy=yysave
5345         write (2,*) "yy+ sumene from enesc=",sumenep
5346         zzsave=zz
5347         zz=zz+aincr
5348         write (2,*) xx,yy,zz
5349         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5350         de_dzz_num=(sumenep-sumene)/aincr
5351         zz=zzsave
5352         write (2,*) "zz+ sumene from enesc=",sumenep
5353         costsave=cost2tab(i+1)
5354         sintsave=sint2tab(i+1)
5355         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5356         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5357         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5358         de_dt_num=(sumenep-sumene)/aincr
5359         write (2,*) " t+ sumene from enesc=",sumenep
5360         cost2tab(i+1)=costsave
5361         sint2tab(i+1)=sintsave
5362 C End of diagnostics section.
5363 #endif
5364 C
5365 C Compute the gradient of esc
5366 C
5367         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5368         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5369         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5370         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5371         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5372         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5373         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5374         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5375         pom1=(sumene3*sint2tab(i+1)+sumene1)
5376      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5377         pom2=(sumene4*cost2tab(i+1)+sumene2)
5378      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5379         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5380         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5381      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5382      &  +x(40)*yy*zz
5383         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5384         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5385      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5386      &  +x(60)*yy*zz
5387         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5388      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5389      &        +(pom1+pom2)*pom_dx
5390 #ifdef DEBUG
5391         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5392 #endif
5393 C
5394         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5395         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5396      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5397      &  +x(40)*xx*zz
5398         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5399         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5400      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5401      &  +x(59)*zz**2 +x(60)*xx*zz
5402         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5403      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5404      &        +(pom1-pom2)*pom_dy
5405 #ifdef DEBUG
5406         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5407 #endif
5408 C
5409         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5410      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5411      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5412      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5413      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5414      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5415      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5416      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5417 #ifdef DEBUG
5418         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5419 #endif
5420 C
5421         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5422      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5423      &  +pom1*pom_dt1+pom2*pom_dt2
5424 #ifdef DEBUG
5425         write(2,*), "de_dt = ", de_dt,de_dt_num
5426 #endif
5427 c
5428 C
5429        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5430        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5431        cosfac2xx=cosfac2*xx
5432        sinfac2yy=sinfac2*yy
5433        do k = 1,3
5434          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5435      &      vbld_inv(i+1)
5436          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5437      &      vbld_inv(i)
5438          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5439          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5440 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5441 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5442 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5443 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5444          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5445          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5446          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5447          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5448          dZZ_Ci1(k)=0.0d0
5449          dZZ_Ci(k)=0.0d0
5450          do j=1,3
5451            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5452      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5453            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5454      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5455          enddo
5456
5457          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5458          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5459          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5460 c
5461          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5462          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5463        enddo
5464
5465        do k=1,3
5466          dXX_Ctab(k,i)=dXX_Ci(k)
5467          dXX_C1tab(k,i)=dXX_Ci1(k)
5468          dYY_Ctab(k,i)=dYY_Ci(k)
5469          dYY_C1tab(k,i)=dYY_Ci1(k)
5470          dZZ_Ctab(k,i)=dZZ_Ci(k)
5471          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5472          dXX_XYZtab(k,i)=dXX_XYZ(k)
5473          dYY_XYZtab(k,i)=dYY_XYZ(k)
5474          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5475        enddo
5476
5477        do k = 1,3
5478 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5479 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5480 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5481 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5482 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5483 c     &    dt_dci(k)
5484 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5485 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5486          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5487      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5488          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5489      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5490          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5491      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5492        enddo
5493 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5494 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5495
5496 C to check gradient call subroutine check_grad
5497
5498     1 continue
5499       enddo
5500       return
5501       end
5502 #endif
5503 c------------------------------------------------------------------------------
5504       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5505 C
5506 C This procedure calculates two-body contact function g(rij) and its derivative:
5507 C
5508 C           eps0ij                                     !       x < -1
5509 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5510 C            0                                         !       x > 1
5511 C
5512 C where x=(rij-r0ij)/delta
5513 C
5514 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5515 C
5516       implicit none
5517       double precision rij,r0ij,eps0ij,fcont,fprimcont
5518       double precision x,x2,x4,delta
5519 c     delta=0.02D0*r0ij
5520 c      delta=0.2D0*r0ij
5521       x=(rij-r0ij)/delta
5522       if (x.lt.-1.0D0) then
5523         fcont=eps0ij
5524         fprimcont=0.0D0
5525       else if (x.le.1.0D0) then
5526         x2=x*x
5527         x4=x2*x2
5528         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5529         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5530       else
5531         fcont=0.0D0
5532         fprimcont=0.0D0
5533       endif
5534       return
5535       end
5536 c------------------------------------------------------------------------------
5537       subroutine splinthet(theti,delta,ss,ssder)
5538       implicit real*8 (a-h,o-z)
5539       include 'DIMENSIONS'
5540       include 'COMMON.VAR'
5541       include 'COMMON.GEO'
5542       thetup=pi-delta
5543       thetlow=delta
5544       if (theti.gt.pipol) then
5545         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5546       else
5547         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5548         ssder=-ssder
5549       endif
5550       return
5551       end
5552 c------------------------------------------------------------------------------
5553       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5554       implicit none
5555       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5556       double precision ksi,ksi2,ksi3,a1,a2,a3
5557       a1=fprim0*delta/(f1-f0)
5558       a2=3.0d0-2.0d0*a1
5559       a3=a1-2.0d0
5560       ksi=(x-x0)/delta
5561       ksi2=ksi*ksi
5562       ksi3=ksi2*ksi
5563       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5564       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5565       return
5566       end
5567 c------------------------------------------------------------------------------
5568       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5569       implicit none
5570       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5571       double precision ksi,ksi2,ksi3,a1,a2,a3
5572       ksi=(x-x0)/delta
5573       ksi2=ksi*ksi
5574       ksi3=ksi2*ksi
5575       a1=fprim0x*delta
5576       a2=3*(f1x-f0x)-2*fprim0x*delta
5577       a3=fprim0x*delta-2*(f1x-f0x)
5578       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5579       return
5580       end
5581 C-----------------------------------------------------------------------------
5582 #ifdef CRYST_TOR
5583 C-----------------------------------------------------------------------------
5584       subroutine etor(etors,fact)
5585       implicit real*8 (a-h,o-z)
5586       include 'DIMENSIONS'
5587       include 'COMMON.VAR'
5588       include 'COMMON.GEO'
5589       include 'COMMON.LOCAL'
5590       include 'COMMON.TORSION'
5591       include 'COMMON.INTERACT'
5592       include 'COMMON.DERIV'
5593       include 'COMMON.CHAIN'
5594       include 'COMMON.NAMES'
5595       include 'COMMON.IOUNITS'
5596       include 'COMMON.FFIELD'
5597       include 'COMMON.TORCNSTR'
5598       logical lprn
5599 C Set lprn=.true. for debugging
5600       lprn=.false.
5601 c      lprn=.true.
5602       etors=0.0D0
5603       do i=iphi_start,iphi_end
5604         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5605      &      .or. itype(i).eq.ntyp1) cycle
5606         itori=itortyp(itype(i-2))
5607         itori1=itortyp(itype(i-1))
5608         phii=phi(i)
5609         gloci=0.0D0
5610 C Proline-Proline pair is a special case...
5611         if (itori.eq.3 .and. itori1.eq.3) then
5612           if (phii.gt.-dwapi3) then
5613             cosphi=dcos(3*phii)
5614             fac=1.0D0/(1.0D0-cosphi)
5615             etorsi=v1(1,3,3)*fac
5616             etorsi=etorsi+etorsi
5617             etors=etors+etorsi-v1(1,3,3)
5618             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5619           endif
5620           do j=1,3
5621             v1ij=v1(j+1,itori,itori1)
5622             v2ij=v2(j+1,itori,itori1)
5623             cosphi=dcos(j*phii)
5624             sinphi=dsin(j*phii)
5625             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5626             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5627           enddo
5628         else
5629           do j=1,nterm_old
5630             v1ij=v1(j,itori,itori1)
5631             v2ij=v2(j,itori,itori1)
5632             cosphi=dcos(j*phii)
5633             sinphi=dsin(j*phii)
5634             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5635             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5636           enddo
5637         endif
5638         if (lprn)
5639      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5640      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5641      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5642         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5643 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5644       enddo
5645       return
5646       end
5647 c------------------------------------------------------------------------------
5648 #else
5649       subroutine etor(etors,fact)
5650       implicit real*8 (a-h,o-z)
5651       include 'DIMENSIONS'
5652       include 'COMMON.VAR'
5653       include 'COMMON.GEO'
5654       include 'COMMON.LOCAL'
5655       include 'COMMON.TORSION'
5656       include 'COMMON.INTERACT'
5657       include 'COMMON.DERIV'
5658       include 'COMMON.CHAIN'
5659       include 'COMMON.NAMES'
5660       include 'COMMON.IOUNITS'
5661       include 'COMMON.FFIELD'
5662       include 'COMMON.TORCNSTR'
5663       logical lprn
5664 C Set lprn=.true. for debugging
5665       lprn=.false.
5666 c      lprn=.true.
5667       etors=0.0D0
5668       do i=iphi_start,iphi_end
5669         if (i.le.2) cycle
5670         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5671      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5672 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5673 C     &       .or. itype(i).eq.ntyp1) cycle
5674         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5675          if (iabs(itype(i)).eq.20) then
5676          iblock=2
5677          else
5678          iblock=1
5679          endif
5680         itori=itortyp(itype(i-2))
5681         itori1=itortyp(itype(i-1))
5682         phii=phi(i)
5683         gloci=0.0D0
5684 C Regular cosine and sine terms
5685         do j=1,nterm(itori,itori1,iblock)
5686           v1ij=v1(j,itori,itori1,iblock)
5687           v2ij=v2(j,itori,itori1,iblock)
5688           cosphi=dcos(j*phii)
5689           sinphi=dsin(j*phii)
5690           etors=etors+v1ij*cosphi+v2ij*sinphi
5691           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5692         enddo
5693 C Lorentz terms
5694 C                         v1
5695 C  E = SUM ----------------------------------- - v1
5696 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5697 C
5698         cosphi=dcos(0.5d0*phii)
5699         sinphi=dsin(0.5d0*phii)
5700         do j=1,nlor(itori,itori1,iblock)
5701           vl1ij=vlor1(j,itori,itori1)
5702           vl2ij=vlor2(j,itori,itori1)
5703           vl3ij=vlor3(j,itori,itori1)
5704           pom=vl2ij*cosphi+vl3ij*sinphi
5705           pom1=1.0d0/(pom*pom+1.0d0)
5706           etors=etors+vl1ij*pom1
5707 c          if (energy_dec) etors_ii=etors_ii+
5708 c     &                vl1ij*pom1
5709           pom=-pom*pom1*pom1
5710           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5711         enddo
5712 C Subtract the constant term
5713         etors=etors-v0(itori,itori1,iblock)
5714         if (lprn)
5715      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5716      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5717      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5718         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5719 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5720  1215   continue
5721       enddo
5722       return
5723       end
5724 c----------------------------------------------------------------------------
5725       subroutine etor_d(etors_d,fact2)
5726 C 6/23/01 Compute double torsional energy
5727       implicit real*8 (a-h,o-z)
5728       include 'DIMENSIONS'
5729       include 'COMMON.VAR'
5730       include 'COMMON.GEO'
5731       include 'COMMON.LOCAL'
5732       include 'COMMON.TORSION'
5733       include 'COMMON.INTERACT'
5734       include 'COMMON.DERIV'
5735       include 'COMMON.CHAIN'
5736       include 'COMMON.NAMES'
5737       include 'COMMON.IOUNITS'
5738       include 'COMMON.FFIELD'
5739       include 'COMMON.TORCNSTR'
5740       logical lprn
5741 C Set lprn=.true. for debugging
5742       lprn=.false.
5743 c     lprn=.true.
5744       etors_d=0.0D0
5745       do i=iphi_start,iphi_end-1
5746         if (i.le.3) cycle
5747 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5748 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5749          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5750      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5751      &  (itype(i+1).eq.ntyp1)) cycle
5752         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5753      &     goto 1215
5754         itori=itortyp(itype(i-2))
5755         itori1=itortyp(itype(i-1))
5756         itori2=itortyp(itype(i))
5757         phii=phi(i)
5758         phii1=phi(i+1)
5759         gloci1=0.0D0
5760         gloci2=0.0D0
5761         iblock=1
5762         if (iabs(itype(i+1)).eq.20) iblock=2
5763 C Regular cosine and sine terms
5764         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5765           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5766           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5767           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5768           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5769           cosphi1=dcos(j*phii)
5770           sinphi1=dsin(j*phii)
5771           cosphi2=dcos(j*phii1)
5772           sinphi2=dsin(j*phii1)
5773           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5774      &     v2cij*cosphi2+v2sij*sinphi2
5775           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5776           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5777         enddo
5778         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5779           do l=1,k-1
5780             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5781             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5782             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5783             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5784             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5785             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5786             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5787             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5788             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5789      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5790             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5791      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5792             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5793      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5794           enddo
5795         enddo
5796         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5797         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5798  1215   continue
5799       enddo
5800       return
5801       end
5802 #endif
5803 c---------------------------------------------------------------------------
5804 C The rigorous attempt to derive energy function
5805       subroutine etor_kcc(etors,fact)
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.VAR'
5809       include 'COMMON.GEO'
5810       include 'COMMON.LOCAL'
5811       include 'COMMON.TORSION'
5812       include 'COMMON.INTERACT'
5813       include 'COMMON.DERIV'
5814       include 'COMMON.CHAIN'
5815       include 'COMMON.NAMES'
5816       include 'COMMON.IOUNITS'
5817       include 'COMMON.FFIELD'
5818       include 'COMMON.TORCNSTR'
5819       include 'COMMON.CONTROL'
5820       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5821       logical lprn
5822 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5823 C Set lprn=.true. for debugging
5824       lprn=energy_dec
5825 c     lprn=.true.
5826 C      print *,"wchodze kcc"
5827       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5828       etors=0.0D0
5829       do i=iphi_start,iphi_end
5830 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5831 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5832 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5833 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5834         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5835      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5836         itori=itortyp(itype(i-2))
5837         itori1=itortyp(itype(i-1))
5838         phii=phi(i)
5839         glocig=0.0D0
5840         glocit1=0.0d0
5841         glocit2=0.0d0
5842 C to avoid multiple devision by 2
5843 c        theti22=0.5d0*theta(i)
5844 C theta 12 is the theta_1 /2
5845 C theta 22 is theta_2 /2
5846 c        theti12=0.5d0*theta(i-1)
5847 C and appropriate sinus function
5848         sinthet1=dsin(theta(i-1))
5849         sinthet2=dsin(theta(i))
5850         costhet1=dcos(theta(i-1))
5851         costhet2=dcos(theta(i))
5852 C to speed up lets store its mutliplication
5853         sint1t2=sinthet2*sinthet1
5854         sint1t2n=1.0d0
5855 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5856 C +d_n*sin(n*gamma)) *
5857 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5858 C we have two sum 1) Non-Chebyshev which is with n and gamma
5859         nval=nterm_kcc_Tb(itori,itori1)
5860         c1(0)=0.0d0
5861         c2(0)=0.0d0
5862         c1(1)=1.0d0
5863         c2(1)=1.0d0
5864         do j=2,nval
5865           c1(j)=c1(j-1)*costhet1
5866           c2(j)=c2(j-1)*costhet2
5867         enddo
5868         etori=0.0d0
5869         do j=1,nterm_kcc(itori,itori1)
5870           cosphi=dcos(j*phii)
5871           sinphi=dsin(j*phii)
5872           sint1t2n1=sint1t2n
5873           sint1t2n=sint1t2n*sint1t2
5874           sumvalc=0.0d0
5875           gradvalct1=0.0d0
5876           gradvalct2=0.0d0
5877           do k=1,nval
5878             do l=1,nval
5879               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5880               gradvalct1=gradvalct1+
5881      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5882               gradvalct2=gradvalct2+
5883      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5884             enddo
5885           enddo
5886           gradvalct1=-gradvalct1*sinthet1
5887           gradvalct2=-gradvalct2*sinthet2
5888           sumvals=0.0d0
5889           gradvalst1=0.0d0
5890           gradvalst2=0.0d0
5891           do k=1,nval
5892             do l=1,nval
5893               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5894               gradvalst1=gradvalst1+
5895      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5896               gradvalst2=gradvalst2+
5897      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5898             enddo
5899           enddo
5900           gradvalst1=-gradvalst1*sinthet1
5901           gradvalst2=-gradvalst2*sinthet2
5902           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5903 C glocig is the gradient local i site in gamma
5904           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5905 C now gradient over theta_1
5906           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5907      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5908           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5909      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5910         enddo ! j
5911         etors=etors+etori
5912 C derivative over gamma
5913         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5914 C derivative over theta1
5915         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5916 C now derivative over theta2
5917         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5918         if (lprn)
5919      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5920      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5921       enddo
5922       return
5923       end
5924 c---------------------------------------------------------------------------------------------
5925       subroutine etor_constr(edihcnstr)
5926       implicit real*8 (a-h,o-z)
5927       include 'DIMENSIONS'
5928       include 'COMMON.VAR'
5929       include 'COMMON.GEO'
5930       include 'COMMON.LOCAL'
5931       include 'COMMON.TORSION'
5932       include 'COMMON.INTERACT'
5933       include 'COMMON.DERIV'
5934       include 'COMMON.CHAIN'
5935       include 'COMMON.NAMES'
5936       include 'COMMON.IOUNITS'
5937       include 'COMMON.FFIELD'
5938       include 'COMMON.TORCNSTR'
5939       include 'COMMON.CONTROL'
5940 ! 6/20/98 - dihedral angle constraints
5941       edihcnstr=0.0d0
5942 c      do i=1,ndih_constr
5943 c      write (iout,*) "idihconstr_start",idihconstr_start,
5944 c     &  " idihconstr_end",idihconstr_end
5945       if (raw_psipred) then
5946         do i=idihconstr_start,idihconstr_end
5947           itori=idih_constr(i)
5948           phii=phi(itori)
5949           gaudih_i=vpsipred(1,i)
5950           gauder_i=0.0d0
5951           do j=1,2
5952             s = sdihed(j,i)
5953             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
5954             dexpcos_i=dexp(-cos_i*cos_i)
5955             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
5956             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
5957      &            *cos_i*dexpcos_i/s**2
5958           enddo
5959           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
5960           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
5961           if (energy_dec)
5962      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
5963      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
5964      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
5965      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
5966      &     -wdihc*dlog(gaudih_i)
5967         enddo
5968       else
5969         do i=idihconstr_start,idihconstr_end
5970           itori=idih_constr(i)
5971           phii=phi(itori)
5972           difi=pinorm(phii-phi0(i))
5973           if (difi.gt.drange(i)) then
5974             difi=difi-drange(i)
5975             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5976             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5977           else if (difi.lt.-drange(i)) then
5978             difi=difi+drange(i)
5979             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5980             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5981           else
5982             difi=0.0
5983           endif
5984         enddo
5985       endif
5986       return
5987       end
5988 c----------------------------------------------------------------------------
5989 C The rigorous attempt to derive energy function
5990       subroutine ebend_kcc(etheta)
5991
5992       implicit real*8 (a-h,o-z)
5993       include 'DIMENSIONS'
5994       include 'COMMON.VAR'
5995       include 'COMMON.GEO'
5996       include 'COMMON.LOCAL'
5997       include 'COMMON.TORSION'
5998       include 'COMMON.INTERACT'
5999       include 'COMMON.DERIV'
6000       include 'COMMON.CHAIN'
6001       include 'COMMON.NAMES'
6002       include 'COMMON.IOUNITS'
6003       include 'COMMON.FFIELD'
6004       include 'COMMON.TORCNSTR'
6005       include 'COMMON.CONTROL'
6006       logical lprn
6007       double precision thybt1(maxang_kcc)
6008 C Set lprn=.true. for debugging
6009       lprn=energy_dec
6010 c     lprn=.true.
6011 C      print *,"wchodze kcc"
6012       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6013       etheta=0.0D0
6014       do i=ithet_start,ithet_end
6015 c        print *,i,itype(i-1),itype(i),itype(i-2)
6016         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6017      &  .or.itype(i).eq.ntyp1) cycle
6018         iti=iabs(itortyp(itype(i-1)))
6019         sinthet=dsin(theta(i))
6020         costhet=dcos(theta(i))
6021         do j=1,nbend_kcc_Tb(iti)
6022           thybt1(j)=v1bend_chyb(j,iti)
6023         enddo
6024         sumth1thyb=v1bend_chyb(0,iti)+
6025      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6026         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6027      &    sumth1thyb
6028         ihelp=nbend_kcc_Tb(iti)-1
6029         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6030         etheta=etheta+sumth1thyb
6031 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6032         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6033       enddo
6034       return
6035       end
6036 c-------------------------------------------------------------------------------------
6037       subroutine etheta_constr(ethetacnstr)
6038
6039       implicit real*8 (a-h,o-z)
6040       include 'DIMENSIONS'
6041       include 'COMMON.VAR'
6042       include 'COMMON.GEO'
6043       include 'COMMON.LOCAL'
6044       include 'COMMON.TORSION'
6045       include 'COMMON.INTERACT'
6046       include 'COMMON.DERIV'
6047       include 'COMMON.CHAIN'
6048       include 'COMMON.NAMES'
6049       include 'COMMON.IOUNITS'
6050       include 'COMMON.FFIELD'
6051       include 'COMMON.TORCNSTR'
6052       include 'COMMON.CONTROL'
6053       ethetacnstr=0.0d0
6054 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6055       do i=ithetaconstr_start,ithetaconstr_end
6056         itheta=itheta_constr(i)
6057         thetiii=theta(itheta)
6058         difi=pinorm(thetiii-theta_constr0(i))
6059         if (difi.gt.theta_drange(i)) then
6060           difi=difi-theta_drange(i)
6061           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6062           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6063      &    +for_thet_constr(i)*difi**3
6064         else if (difi.lt.-drange(i)) then
6065           difi=difi+drange(i)
6066           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6067           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6068      &    +for_thet_constr(i)*difi**3
6069         else
6070           difi=0.0
6071         endif
6072        if (energy_dec) then
6073         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6074      &    i,itheta,rad2deg*thetiii,
6075      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6076      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6077      &    gloc(itheta+nphi-2,icg)
6078         endif
6079       enddo
6080       return
6081       end
6082 c------------------------------------------------------------------------------
6083 c------------------------------------------------------------------------------
6084       subroutine eback_sc_corr(esccor)
6085 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6086 c        conformational states; temporarily implemented as differences
6087 c        between UNRES torsional potentials (dependent on three types of
6088 c        residues) and the torsional potentials dependent on all 20 types
6089 c        of residues computed from AM1 energy surfaces of terminally-blocked
6090 c        amino-acid residues.
6091       implicit real*8 (a-h,o-z)
6092       include 'DIMENSIONS'
6093       include 'COMMON.VAR'
6094       include 'COMMON.GEO'
6095       include 'COMMON.LOCAL'
6096       include 'COMMON.TORSION'
6097       include 'COMMON.SCCOR'
6098       include 'COMMON.INTERACT'
6099       include 'COMMON.DERIV'
6100       include 'COMMON.CHAIN'
6101       include 'COMMON.NAMES'
6102       include 'COMMON.IOUNITS'
6103       include 'COMMON.FFIELD'
6104       include 'COMMON.CONTROL'
6105       logical lprn
6106 C Set lprn=.true. for debugging
6107       lprn=.false.
6108 c      lprn=.true.
6109 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6110       esccor=0.0D0
6111       do i=itau_start,itau_end
6112         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6113         esccor_ii=0.0D0
6114         isccori=isccortyp(itype(i-2))
6115         isccori1=isccortyp(itype(i-1))
6116         phii=phi(i)
6117         do intertyp=1,3 !intertyp
6118 cc Added 09 May 2012 (Adasko)
6119 cc  Intertyp means interaction type of backbone mainchain correlation:
6120 c   1 = SC...Ca...Ca...Ca
6121 c   2 = Ca...Ca...Ca...SC
6122 c   3 = SC...Ca...Ca...SCi
6123         gloci=0.0D0
6124         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6125      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6126      &      (itype(i-1).eq.ntyp1)))
6127      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6128      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6129      &     .or.(itype(i).eq.ntyp1)))
6130      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6131      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6132      &      (itype(i-3).eq.ntyp1)))) cycle
6133         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6134         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6135      & cycle
6136        do j=1,nterm_sccor(isccori,isccori1)
6137           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6138           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6139           cosphi=dcos(j*tauangle(intertyp,i))
6140           sinphi=dsin(j*tauangle(intertyp,i))
6141            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6142            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6143          enddo
6144 C      write (iout,*)"EBACK_SC_COR",esccor,i
6145 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6146 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6147 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6148         if (lprn)
6149      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6150      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6151      &  (v1sccor(j,1,itori,itori1),j=1,6)
6152      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6153 c        gsccor_loc(i-3)=gloci
6154        enddo !intertyp
6155       enddo
6156       return
6157       end
6158 c------------------------------------------------------------------------------
6159       subroutine multibody(ecorr)
6160 C This subroutine calculates multi-body contributions to energy following
6161 C the idea of Skolnick et al. If side chains I and J make a contact and
6162 C at the same time side chains I+1 and J+1 make a contact, an extra
6163 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6164       implicit real*8 (a-h,o-z)
6165       include 'DIMENSIONS'
6166       include 'COMMON.IOUNITS'
6167       include 'COMMON.DERIV'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.CONTACTS'
6170       double precision gx(3),gx1(3)
6171       logical lprn
6172
6173 C Set lprn=.true. for debugging
6174       lprn=.false.
6175
6176       if (lprn) then
6177         write (iout,'(a)') 'Contact function values:'
6178         do i=nnt,nct-2
6179           write (iout,'(i2,20(1x,i2,f10.5))')
6180      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6181         enddo
6182       endif
6183       ecorr=0.0D0
6184       do i=nnt,nct
6185         do j=1,3
6186           gradcorr(j,i)=0.0D0
6187           gradxorr(j,i)=0.0D0
6188         enddo
6189       enddo
6190       do i=nnt,nct-2
6191
6192         DO ISHIFT = 3,4
6193
6194         i1=i+ishift
6195         num_conti=num_cont(i)
6196         num_conti1=num_cont(i1)
6197         do jj=1,num_conti
6198           j=jcont(jj,i)
6199           do kk=1,num_conti1
6200             j1=jcont(kk,i1)
6201             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6202 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6203 cd   &                   ' ishift=',ishift
6204 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6205 C The system gains extra energy.
6206               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6207             endif   ! j1==j+-ishift
6208           enddo     ! kk
6209         enddo       ! jj
6210
6211         ENDDO ! ISHIFT
6212
6213       enddo         ! i
6214       return
6215       end
6216 c------------------------------------------------------------------------------
6217       double precision function esccorr(i,j,k,l,jj,kk)
6218       implicit real*8 (a-h,o-z)
6219       include 'DIMENSIONS'
6220       include 'COMMON.IOUNITS'
6221       include 'COMMON.DERIV'
6222       include 'COMMON.INTERACT'
6223       include 'COMMON.CONTACTS'
6224       double precision gx(3),gx1(3)
6225       logical lprn
6226       lprn=.false.
6227       eij=facont(jj,i)
6228       ekl=facont(kk,k)
6229 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6230 C Calculate the multi-body contribution to energy.
6231 C Calculate multi-body contributions to the gradient.
6232 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6233 cd   & k,l,(gacont(m,kk,k),m=1,3)
6234       do m=1,3
6235         gx(m) =ekl*gacont(m,jj,i)
6236         gx1(m)=eij*gacont(m,kk,k)
6237         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6238         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6239         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6240         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6241       enddo
6242       do m=i,j-1
6243         do ll=1,3
6244           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6245         enddo
6246       enddo
6247       do m=k,l-1
6248         do ll=1,3
6249           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6250         enddo
6251       enddo
6252       esccorr=-eij*ekl
6253       return
6254       end
6255 c------------------------------------------------------------------------------
6256       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6257 C This subroutine calculates multi-body contributions to hydrogen-bonding
6258       implicit real*8 (a-h,o-z)
6259       include 'DIMENSIONS'
6260       include 'COMMON.IOUNITS'
6261       include 'COMMON.FFIELD'
6262       include 'COMMON.DERIV'
6263       include 'COMMON.INTERACT'
6264       include 'COMMON.CONTACTS'
6265       double precision gx(3),gx1(3)
6266       logical lprn,ldone
6267
6268 C Set lprn=.true. for debugging
6269       lprn=.false.
6270       if (lprn) then
6271         write (iout,'(a)') 'Contact function values:'
6272         do i=nnt,nct-2
6273           write (iout,'(2i3,50(1x,i2,f5.2))')
6274      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6275      &    j=1,num_cont_hb(i))
6276         enddo
6277       endif
6278       ecorr=0.0D0
6279 C Remove the loop below after debugging !!!
6280       do i=nnt,nct
6281         do j=1,3
6282           gradcorr(j,i)=0.0D0
6283           gradxorr(j,i)=0.0D0
6284         enddo
6285       enddo
6286 C Calculate the local-electrostatic correlation terms
6287       do i=iatel_s,iatel_e+1
6288         i1=i+1
6289         num_conti=num_cont_hb(i)
6290         num_conti1=num_cont_hb(i+1)
6291         do jj=1,num_conti
6292           j=jcont_hb(jj,i)
6293           do kk=1,num_conti1
6294             j1=jcont_hb(kk,i1)
6295 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6296 c     &         ' jj=',jj,' kk=',kk
6297             if (j1.eq.j+1 .or. j1.eq.j-1) then
6298 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6299 C The system gains extra energy.
6300               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6301               n_corr=n_corr+1
6302             else if (j1.eq.j) then
6303 C Contacts I-J and I-(J+1) occur simultaneously.
6304 C The system loses extra energy.
6305 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6306             endif
6307           enddo ! kk
6308           do kk=1,num_conti
6309             j1=jcont_hb(kk,i)
6310 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6311 c    &         ' jj=',jj,' kk=',kk
6312             if (j1.eq.j+1) then
6313 C Contacts I-J and (I+1)-J occur simultaneously.
6314 C The system loses extra energy.
6315 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6316             endif ! j1==j+1
6317           enddo ! kk
6318         enddo ! jj
6319       enddo ! i
6320       return
6321       end
6322 c------------------------------------------------------------------------------
6323       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6324      &  n_corr1)
6325 C This subroutine calculates multi-body contributions to hydrogen-bonding
6326       implicit real*8 (a-h,o-z)
6327       include 'DIMENSIONS'
6328       include 'COMMON.IOUNITS'
6329 #ifdef MPI
6330       include "mpif.h"
6331 #endif
6332       include 'COMMON.FFIELD'
6333       include 'COMMON.DERIV'
6334       include 'COMMON.LOCAL'
6335       include 'COMMON.INTERACT'
6336       include 'COMMON.CONTACTS'
6337       include 'COMMON.CHAIN'
6338       include 'COMMON.CONTROL'
6339       include 'COMMON.SHIELD'
6340       double precision gx(3),gx1(3)
6341       integer num_cont_hb_old(maxres)
6342       logical lprn,ldone
6343       double precision eello4,eello5,eelo6,eello_turn6
6344       external eello4,eello5,eello6,eello_turn6
6345 C Set lprn=.true. for debugging
6346       lprn=.false.
6347       eturn6=0.0d0
6348       if (lprn) then
6349         write (iout,'(a)') 'Contact function values:'
6350         do i=nnt,nct-2
6351           write (iout,'(2i3,50(1x,i2,5f6.3))')
6352      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6353      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6354         enddo
6355       endif
6356       ecorr=0.0D0
6357       ecorr5=0.0d0
6358       ecorr6=0.0d0
6359 C Remove the loop below after debugging !!!
6360       do i=nnt,nct
6361         do j=1,3
6362           gradcorr(j,i)=0.0D0
6363           gradxorr(j,i)=0.0D0
6364         enddo
6365       enddo
6366 C Calculate the dipole-dipole interaction energies
6367       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6368       do i=iatel_s,iatel_e+1
6369         num_conti=num_cont_hb(i)
6370         do jj=1,num_conti
6371           j=jcont_hb(jj,i)
6372 #ifdef MOMENT
6373           call dipole(i,j,jj)
6374 #endif
6375         enddo
6376       enddo
6377       endif
6378 C Calculate the local-electrostatic correlation terms
6379 c                write (iout,*) "gradcorr5 in eello5 before loop"
6380 c                do iii=1,nres
6381 c                  write (iout,'(i5,3f10.5)')
6382 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6383 c                enddo
6384       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6385 c        write (iout,*) "corr loop i",i
6386         i1=i+1
6387         num_conti=num_cont_hb(i)
6388         num_conti1=num_cont_hb(i+1)
6389         do jj=1,num_conti
6390           j=jcont_hb(jj,i)
6391           jp=iabs(j)
6392           do kk=1,num_conti1
6393             j1=jcont_hb(kk,i1)
6394             jp1=iabs(j1)
6395 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6396 c     &         ' jj=',jj,' kk=',kk
6397 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6398             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6399      &          .or. j.lt.0 .and. j1.gt.0) .and.
6400      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6401 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6402 C The system gains extra energy.
6403               n_corr=n_corr+1
6404               sqd1=dsqrt(d_cont(jj,i))
6405               sqd2=dsqrt(d_cont(kk,i1))
6406               sred_geom = sqd1*sqd2
6407               IF (sred_geom.lt.cutoff_corr) THEN
6408                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6409      &            ekont,fprimcont)
6410 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6411 cd     &         ' jj=',jj,' kk=',kk
6412                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6413                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6414                 do l=1,3
6415                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6416                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6417                 enddo
6418                 n_corr1=n_corr1+1
6419 cd               write (iout,*) 'sred_geom=',sred_geom,
6420 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6421 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6422 cd               write (iout,*) "g_contij",g_contij
6423 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6424 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6425                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6426                 if (wcorr4.gt.0.0d0)
6427      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6428 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6429                   if (energy_dec.and.wcorr4.gt.0.0d0)
6430      1                 write (iout,'(a6,4i5,0pf7.3)')
6431      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6432 c                write (iout,*) "gradcorr5 before eello5"
6433 c                do iii=1,nres
6434 c                  write (iout,'(i5,3f10.5)')
6435 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6436 c                enddo
6437                 if (wcorr5.gt.0.0d0)
6438      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6439 c                write (iout,*) "gradcorr5 after eello5"
6440 c                do iii=1,nres
6441 c                  write (iout,'(i5,3f10.5)')
6442 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6443 c                enddo
6444                   if (energy_dec.and.wcorr5.gt.0.0d0)
6445      1                 write (iout,'(a6,4i5,0pf7.3)')
6446      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6447 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6448 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6449                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6450      &               .or. wturn6.eq.0.0d0))then
6451 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6452                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6453                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6454      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6455 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6456 cd     &            'ecorr6=',ecorr6
6457 cd                write (iout,'(4e15.5)') sred_geom,
6458 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6459 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6460 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6461                 else if (wturn6.gt.0.0d0
6462      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6463 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6464                   eturn6=eturn6+eello_turn6(i,jj,kk)
6465                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6466      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6467 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6468                 endif
6469               ENDIF
6470 1111          continue
6471             endif
6472           enddo ! kk
6473         enddo ! jj
6474       enddo ! i
6475       do i=1,nres
6476         num_cont_hb(i)=num_cont_hb_old(i)
6477       enddo
6478 c                write (iout,*) "gradcorr5 in eello5"
6479 c                do iii=1,nres
6480 c                  write (iout,'(i5,3f10.5)')
6481 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6482 c                enddo
6483       return
6484       end
6485 c------------------------------------------------------------------------------
6486       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6487       implicit real*8 (a-h,o-z)
6488       include 'DIMENSIONS'
6489       include 'COMMON.IOUNITS'
6490       include 'COMMON.DERIV'
6491       include 'COMMON.INTERACT'
6492       include 'COMMON.CONTACTS'
6493       include 'COMMON.SHIELD'
6494       include 'COMMON.CONTROL'
6495       double precision gx(3),gx1(3)
6496       logical lprn
6497       lprn=.false.
6498 C      print *,"wchodze",fac_shield(i),shield_mode
6499       eij=facont_hb(jj,i)
6500       ekl=facont_hb(kk,k)
6501       ees0pij=ees0p(jj,i)
6502       ees0pkl=ees0p(kk,k)
6503       ees0mij=ees0m(jj,i)
6504       ees0mkl=ees0m(kk,k)
6505       ekont=eij*ekl
6506       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6507 C*
6508 C     & fac_shield(i)**2*fac_shield(j)**2
6509 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6510 C Following 4 lines for diagnostics.
6511 cd    ees0pkl=0.0D0
6512 cd    ees0pij=1.0D0
6513 cd    ees0mkl=0.0D0
6514 cd    ees0mij=1.0D0
6515 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6516 c     & 'Contacts ',i,j,
6517 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6518 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6519 c     & 'gradcorr_long'
6520 C Calculate the multi-body contribution to energy.
6521 C      ecorr=ecorr+ekont*ees
6522 C Calculate multi-body contributions to the gradient.
6523       coeffpees0pij=coeffp*ees0pij
6524       coeffmees0mij=coeffm*ees0mij
6525       coeffpees0pkl=coeffp*ees0pkl
6526       coeffmees0mkl=coeffm*ees0mkl
6527       do ll=1,3
6528 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6529         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6530      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6531      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6532         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6533      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6534      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6535 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6536         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6537      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6538      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6539         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6540      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6541      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6542         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6543      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6544      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6545         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6546         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6547         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6548      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6549      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6550         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6551         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6552 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6553       enddo
6554 c      write (iout,*)
6555 cgrad      do m=i+1,j-1
6556 cgrad        do ll=1,3
6557 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6558 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6559 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6560 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6561 cgrad        enddo
6562 cgrad      enddo
6563 cgrad      do m=k+1,l-1
6564 cgrad        do ll=1,3
6565 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6566 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6567 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6568 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6569 cgrad        enddo
6570 cgrad      enddo
6571 c      write (iout,*) "ehbcorr",ekont*ees
6572 C      print *,ekont,ees,i,k
6573       ehbcorr=ekont*ees
6574 C now gradient over shielding
6575 C      return
6576       if (shield_mode.gt.0) then
6577        j=ees0plist(jj,i)
6578        l=ees0plist(kk,k)
6579 C        print *,i,j,fac_shield(i),fac_shield(j),
6580 C     &fac_shield(k),fac_shield(l)
6581         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6582      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6583           do ilist=1,ishield_list(i)
6584            iresshield=shield_list(ilist,i)
6585            do m=1,3
6586            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6587 C     &      *2.0
6588            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6589      &              rlocshield
6590      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6591             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6592      &+rlocshield
6593            enddo
6594           enddo
6595           do ilist=1,ishield_list(j)
6596            iresshield=shield_list(ilist,j)
6597            do m=1,3
6598            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6599 C     &     *2.0
6600            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6601      &              rlocshield
6602      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6603            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6604      &     +rlocshield
6605            enddo
6606           enddo
6607
6608           do ilist=1,ishield_list(k)
6609            iresshield=shield_list(ilist,k)
6610            do m=1,3
6611            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6612 C     &     *2.0
6613            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6614      &              rlocshield
6615      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6616            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6617      &     +rlocshield
6618            enddo
6619           enddo
6620           do ilist=1,ishield_list(l)
6621            iresshield=shield_list(ilist,l)
6622            do m=1,3
6623            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6624 C     &     *2.0
6625            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6626      &              rlocshield
6627      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6628            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6629      &     +rlocshield
6630            enddo
6631           enddo
6632 C          print *,gshieldx(m,iresshield)
6633           do m=1,3
6634             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6635      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6636             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6637      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6638             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6639      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6640             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6641      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6642
6643             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6644      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6645             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6646      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6647             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6648      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6649             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6650      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6651
6652            enddo
6653       endif
6654       endif
6655       return
6656       end
6657 #ifdef MOMENT
6658 C---------------------------------------------------------------------------
6659       subroutine dipole(i,j,jj)
6660       implicit real*8 (a-h,o-z)
6661       include 'DIMENSIONS'
6662       include 'COMMON.IOUNITS'
6663       include 'COMMON.CHAIN'
6664       include 'COMMON.FFIELD'
6665       include 'COMMON.DERIV'
6666       include 'COMMON.INTERACT'
6667       include 'COMMON.CONTACTS'
6668       include 'COMMON.TORSION'
6669       include 'COMMON.VAR'
6670       include 'COMMON.GEO'
6671       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6672      &  auxmat(2,2)
6673       iti1 = itortyp(itype(i+1))
6674       if (j.lt.nres-1) then
6675         itj1 = itype2loc(itype(j+1))
6676       else
6677         itj1=nloctyp
6678       endif
6679       do iii=1,2
6680         dipi(iii,1)=Ub2(iii,i)
6681         dipderi(iii)=Ub2der(iii,i)
6682         dipi(iii,2)=b1(iii,i+1)
6683         dipj(iii,1)=Ub2(iii,j)
6684         dipderj(iii)=Ub2der(iii,j)
6685         dipj(iii,2)=b1(iii,j+1)
6686       enddo
6687       kkk=0
6688       do iii=1,2
6689         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6690         do jjj=1,2
6691           kkk=kkk+1
6692           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6693         enddo
6694       enddo
6695       do kkk=1,5
6696         do lll=1,3
6697           mmm=0
6698           do iii=1,2
6699             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6700      &        auxvec(1))
6701             do jjj=1,2
6702               mmm=mmm+1
6703               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6704             enddo
6705           enddo
6706         enddo
6707       enddo
6708       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6709       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6710       do iii=1,2
6711         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6712       enddo
6713       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6714       do iii=1,2
6715         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6716       enddo
6717       return
6718       end
6719 #endif
6720 C---------------------------------------------------------------------------
6721       subroutine calc_eello(i,j,k,l,jj,kk)
6722 C
6723 C This subroutine computes matrices and vectors needed to calculate
6724 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6725 C
6726       implicit real*8 (a-h,o-z)
6727       include 'DIMENSIONS'
6728       include 'COMMON.IOUNITS'
6729       include 'COMMON.CHAIN'
6730       include 'COMMON.DERIV'
6731       include 'COMMON.INTERACT'
6732       include 'COMMON.CONTACTS'
6733       include 'COMMON.TORSION'
6734       include 'COMMON.VAR'
6735       include 'COMMON.GEO'
6736       include 'COMMON.FFIELD'
6737       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6738      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6739       logical lprn
6740       common /kutas/ lprn
6741 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6742 cd     & ' jj=',jj,' kk=',kk
6743 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6744 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6745 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6746       do iii=1,2
6747         do jjj=1,2
6748           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6749           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6750         enddo
6751       enddo
6752       call transpose2(aa1(1,1),aa1t(1,1))
6753       call transpose2(aa2(1,1),aa2t(1,1))
6754       do kkk=1,5
6755         do lll=1,3
6756           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6757      &      aa1tder(1,1,lll,kkk))
6758           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6759      &      aa2tder(1,1,lll,kkk))
6760         enddo
6761       enddo
6762       if (l.eq.j+1) then
6763 C parallel orientation of the two CA-CA-CA frames.
6764         if (i.gt.1) then
6765           iti=itype2loc(itype(i))
6766         else
6767           iti=nloctyp
6768         endif
6769         itk1=itype2loc(itype(k+1))
6770         itj=itype2loc(itype(j))
6771         if (l.lt.nres-1) then
6772           itl1=itype2loc(itype(l+1))
6773         else
6774           itl1=nloctyp
6775         endif
6776 C A1 kernel(j+1) A2T
6777 cd        do iii=1,2
6778 cd          write (iout,'(3f10.5,5x,3f10.5)')
6779 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6780 cd        enddo
6781         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6782      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6783      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6784 C Following matrices are needed only for 6-th order cumulants
6785         IF (wcorr6.gt.0.0d0) THEN
6786         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6787      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6788      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6789         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6790      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6791      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6792      &   ADtEAderx(1,1,1,1,1,1))
6793         lprn=.false.
6794         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6795      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6796      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6797      &   ADtEA1derx(1,1,1,1,1,1))
6798         ENDIF
6799 C End 6-th order cumulants
6800 cd        lprn=.false.
6801 cd        if (lprn) then
6802 cd        write (2,*) 'In calc_eello6'
6803 cd        do iii=1,2
6804 cd          write (2,*) 'iii=',iii
6805 cd          do kkk=1,5
6806 cd            write (2,*) 'kkk=',kkk
6807 cd            do jjj=1,2
6808 cd              write (2,'(3(2f10.5),5x)')
6809 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6810 cd            enddo
6811 cd          enddo
6812 cd        enddo
6813 cd        endif
6814         call transpose2(EUgder(1,1,k),auxmat(1,1))
6815         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6816         call transpose2(EUg(1,1,k),auxmat(1,1))
6817         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6818         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6819         do iii=1,2
6820           do kkk=1,5
6821             do lll=1,3
6822               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6823      &          EAEAderx(1,1,lll,kkk,iii,1))
6824             enddo
6825           enddo
6826         enddo
6827 C A1T kernel(i+1) A2
6828         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6829      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6830      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6831 C Following matrices are needed only for 6-th order cumulants
6832         IF (wcorr6.gt.0.0d0) THEN
6833         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6834      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6835      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6836         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6837      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6838      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6839      &   ADtEAderx(1,1,1,1,1,2))
6840         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6841      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6842      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6843      &   ADtEA1derx(1,1,1,1,1,2))
6844         ENDIF
6845 C End 6-th order cumulants
6846         call transpose2(EUgder(1,1,l),auxmat(1,1))
6847         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6848         call transpose2(EUg(1,1,l),auxmat(1,1))
6849         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6850         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6851         do iii=1,2
6852           do kkk=1,5
6853             do lll=1,3
6854               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6855      &          EAEAderx(1,1,lll,kkk,iii,2))
6856             enddo
6857           enddo
6858         enddo
6859 C AEAb1 and AEAb2
6860 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6861 C They are needed only when the fifth- or the sixth-order cumulants are
6862 C indluded.
6863         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6864         call transpose2(AEA(1,1,1),auxmat(1,1))
6865         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6866         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6867         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6868         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6869         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6870         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6871         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6872         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6873         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6874         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6875         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6876         call transpose2(AEA(1,1,2),auxmat(1,1))
6877         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6878         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6879         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6880         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6881         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6882         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6883         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6884         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6885         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6886         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6887         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6888 C Calculate the Cartesian derivatives of the vectors.
6889         do iii=1,2
6890           do kkk=1,5
6891             do lll=1,3
6892               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6893               call matvec2(auxmat(1,1),b1(1,i),
6894      &          AEAb1derx(1,lll,kkk,iii,1,1))
6895               call matvec2(auxmat(1,1),Ub2(1,i),
6896      &          AEAb2derx(1,lll,kkk,iii,1,1))
6897               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6898      &          AEAb1derx(1,lll,kkk,iii,2,1))
6899               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6900      &          AEAb2derx(1,lll,kkk,iii,2,1))
6901               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6902               call matvec2(auxmat(1,1),b1(1,j),
6903      &          AEAb1derx(1,lll,kkk,iii,1,2))
6904               call matvec2(auxmat(1,1),Ub2(1,j),
6905      &          AEAb2derx(1,lll,kkk,iii,1,2))
6906               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6907      &          AEAb1derx(1,lll,kkk,iii,2,2))
6908               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6909      &          AEAb2derx(1,lll,kkk,iii,2,2))
6910             enddo
6911           enddo
6912         enddo
6913         ENDIF
6914 C End vectors
6915       else
6916 C Antiparallel orientation of the two CA-CA-CA frames.
6917         if (i.gt.1) then
6918           iti=itype2loc(itype(i))
6919         else
6920           iti=nloctyp
6921         endif
6922         itk1=itype2loc(itype(k+1))
6923         itl=itype2loc(itype(l))
6924         itj=itype2loc(itype(j))
6925         if (j.lt.nres-1) then
6926           itj1=itype2loc(itype(j+1))
6927         else
6928           itj1=nloctyp
6929         endif
6930 C A2 kernel(j-1)T A1T
6931         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6932      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6933      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6934 C Following matrices are needed only for 6-th order cumulants
6935         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6936      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6937         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6938      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6939      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6940         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6941      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6942      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6943      &   ADtEAderx(1,1,1,1,1,1))
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6945      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6946      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6947      &   ADtEA1derx(1,1,1,1,1,1))
6948         ENDIF
6949 C End 6-th order cumulants
6950         call transpose2(EUgder(1,1,k),auxmat(1,1))
6951         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6952         call transpose2(EUg(1,1,k),auxmat(1,1))
6953         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6954         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6955         do iii=1,2
6956           do kkk=1,5
6957             do lll=1,3
6958               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6959      &          EAEAderx(1,1,lll,kkk,iii,1))
6960             enddo
6961           enddo
6962         enddo
6963 C A2T kernel(i+1)T A1
6964         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6965      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6966      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6967 C Following matrices are needed only for 6-th order cumulants
6968         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6969      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6970         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6971      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6972      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6973         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6974      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6975      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6976      &   ADtEAderx(1,1,1,1,1,2))
6977         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6978      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6979      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6980      &   ADtEA1derx(1,1,1,1,1,2))
6981         ENDIF
6982 C End 6-th order cumulants
6983         call transpose2(EUgder(1,1,j),auxmat(1,1))
6984         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6985         call transpose2(EUg(1,1,j),auxmat(1,1))
6986         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6987         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6988         do iii=1,2
6989           do kkk=1,5
6990             do lll=1,3
6991               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6992      &          EAEAderx(1,1,lll,kkk,iii,2))
6993             enddo
6994           enddo
6995         enddo
6996 C AEAb1 and AEAb2
6997 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6998 C They are needed only when the fifth- or the sixth-order cumulants are
6999 C indluded.
7000         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7001      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7002         call transpose2(AEA(1,1,1),auxmat(1,1))
7003         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7005         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7006         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7007         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7008         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7009         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7010         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7011         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7012         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7013         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7014         call transpose2(AEA(1,1,2),auxmat(1,1))
7015         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7016         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7017         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7018         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7019         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7020         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7021         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7022         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7023         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7024         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7025         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7026 C Calculate the Cartesian derivatives of the vectors.
7027         do iii=1,2
7028           do kkk=1,5
7029             do lll=1,3
7030               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7031               call matvec2(auxmat(1,1),b1(1,i),
7032      &          AEAb1derx(1,lll,kkk,iii,1,1))
7033               call matvec2(auxmat(1,1),Ub2(1,i),
7034      &          AEAb2derx(1,lll,kkk,iii,1,1))
7035               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7036      &          AEAb1derx(1,lll,kkk,iii,2,1))
7037               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7038      &          AEAb2derx(1,lll,kkk,iii,2,1))
7039               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7040               call matvec2(auxmat(1,1),b1(1,l),
7041      &          AEAb1derx(1,lll,kkk,iii,1,2))
7042               call matvec2(auxmat(1,1),Ub2(1,l),
7043      &          AEAb2derx(1,lll,kkk,iii,1,2))
7044               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7045      &          AEAb1derx(1,lll,kkk,iii,2,2))
7046               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7047      &          AEAb2derx(1,lll,kkk,iii,2,2))
7048             enddo
7049           enddo
7050         enddo
7051         ENDIF
7052 C End vectors
7053       endif
7054       return
7055       end
7056 C---------------------------------------------------------------------------
7057       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7058      &  KK,KKderg,AKA,AKAderg,AKAderx)
7059       implicit none
7060       integer nderg
7061       logical transp
7062       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7063      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7064      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7065       integer iii,kkk,lll
7066       integer jjj,mmm
7067       logical lprn
7068       common /kutas/ lprn
7069       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7070       do iii=1,nderg
7071         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7072      &    AKAderg(1,1,iii))
7073       enddo
7074 cd      if (lprn) write (2,*) 'In kernel'
7075       do kkk=1,5
7076 cd        if (lprn) write (2,*) 'kkk=',kkk
7077         do lll=1,3
7078           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7079      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7080 cd          if (lprn) then
7081 cd            write (2,*) 'lll=',lll
7082 cd            write (2,*) 'iii=1'
7083 cd            do jjj=1,2
7084 cd              write (2,'(3(2f10.5),5x)')
7085 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7086 cd            enddo
7087 cd          endif
7088           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7089      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7090 cd          if (lprn) then
7091 cd            write (2,*) 'lll=',lll
7092 cd            write (2,*) 'iii=2'
7093 cd            do jjj=1,2
7094 cd              write (2,'(3(2f10.5),5x)')
7095 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7096 cd            enddo
7097 cd          endif
7098         enddo
7099       enddo
7100       return
7101       end
7102 C---------------------------------------------------------------------------
7103       double precision function eello4(i,j,k,l,jj,kk)
7104       implicit real*8 (a-h,o-z)
7105       include 'DIMENSIONS'
7106       include 'COMMON.IOUNITS'
7107       include 'COMMON.CHAIN'
7108       include 'COMMON.DERIV'
7109       include 'COMMON.INTERACT'
7110       include 'COMMON.CONTACTS'
7111       include 'COMMON.TORSION'
7112       include 'COMMON.VAR'
7113       include 'COMMON.GEO'
7114       double precision pizda(2,2),ggg1(3),ggg2(3)
7115 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7116 cd        eello4=0.0d0
7117 cd        return
7118 cd      endif
7119 cd      print *,'eello4:',i,j,k,l,jj,kk
7120 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7121 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7122 cold      eij=facont_hb(jj,i)
7123 cold      ekl=facont_hb(kk,k)
7124 cold      ekont=eij*ekl
7125       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7126       if (calc_grad) then
7127 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7128       gcorr_loc(k-1)=gcorr_loc(k-1)
7129      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7130       if (l.eq.j+1) then
7131         gcorr_loc(l-1)=gcorr_loc(l-1)
7132      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7133       else
7134         gcorr_loc(j-1)=gcorr_loc(j-1)
7135      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7136       endif
7137       do iii=1,2
7138         do kkk=1,5
7139           do lll=1,3
7140             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7141      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7142 cd            derx(lll,kkk,iii)=0.0d0
7143           enddo
7144         enddo
7145       enddo
7146 cd      gcorr_loc(l-1)=0.0d0
7147 cd      gcorr_loc(j-1)=0.0d0
7148 cd      gcorr_loc(k-1)=0.0d0
7149 cd      eel4=1.0d0
7150 cd      write (iout,*)'Contacts have occurred for peptide groups',
7151 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7152 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7153       if (j.lt.nres-1) then
7154         j1=j+1
7155         j2=j-1
7156       else
7157         j1=j-1
7158         j2=j-2
7159       endif
7160       if (l.lt.nres-1) then
7161         l1=l+1
7162         l2=l-1
7163       else
7164         l1=l-1
7165         l2=l-2
7166       endif
7167       do ll=1,3
7168 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7169 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7170         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7171         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7172 cgrad        ghalf=0.5d0*ggg1(ll)
7173         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7174         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7175         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7176         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7177         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7178         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7179 cgrad        ghalf=0.5d0*ggg2(ll)
7180         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7181         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7182         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7183         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7184         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7185         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7186       enddo
7187 cgrad      do m=i+1,j-1
7188 cgrad        do ll=1,3
7189 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7190 cgrad        enddo
7191 cgrad      enddo
7192 cgrad      do m=k+1,l-1
7193 cgrad        do ll=1,3
7194 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7195 cgrad        enddo
7196 cgrad      enddo
7197 cgrad      do m=i+2,j2
7198 cgrad        do ll=1,3
7199 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7200 cgrad        enddo
7201 cgrad      enddo
7202 cgrad      do m=k+2,l2
7203 cgrad        do ll=1,3
7204 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7205 cgrad        enddo
7206 cgrad      enddo
7207 cd      do iii=1,nres-3
7208 cd        write (2,*) iii,gcorr_loc(iii)
7209 cd      enddo
7210       endif ! calc_grad
7211       eello4=ekont*eel4
7212 cd      write (2,*) 'ekont',ekont
7213 cd      write (iout,*) 'eello4',ekont*eel4
7214       return
7215       end
7216 C---------------------------------------------------------------------------
7217       double precision function eello5(i,j,k,l,jj,kk)
7218       implicit real*8 (a-h,o-z)
7219       include 'DIMENSIONS'
7220       include 'COMMON.IOUNITS'
7221       include 'COMMON.CHAIN'
7222       include 'COMMON.DERIV'
7223       include 'COMMON.INTERACT'
7224       include 'COMMON.CONTACTS'
7225       include 'COMMON.TORSION'
7226       include 'COMMON.VAR'
7227       include 'COMMON.GEO'
7228       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7229       double precision ggg1(3),ggg2(3)
7230 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7231 C                                                                              C
7232 C                            Parallel chains                                   C
7233 C                                                                              C
7234 C          o             o                   o             o                   C
7235 C         /l\           / \             \   / \           / \   /              C
7236 C        /   \         /   \             \ /   \         /   \ /               C
7237 C       j| o |l1       | o |              o| o |         | o |o                C
7238 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7239 C      \i/   \         /   \ /             /   \         /   \                 C
7240 C       o    k1             o                                                  C
7241 C         (I)          (II)                (III)          (IV)                 C
7242 C                                                                              C
7243 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7244 C                                                                              C
7245 C                            Antiparallel chains                               C
7246 C                                                                              C
7247 C          o             o                   o             o                   C
7248 C         /j\           / \             \   / \           / \   /              C
7249 C        /   \         /   \             \ /   \         /   \ /               C
7250 C      j1| o |l        | o |              o| o |         | o |o                C
7251 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7252 C      \i/   \         /   \ /             /   \         /   \                 C
7253 C       o     k1            o                                                  C
7254 C         (I)          (II)                (III)          (IV)                 C
7255 C                                                                              C
7256 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7257 C                                                                              C
7258 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7259 C                                                                              C
7260 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7261 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7262 cd        eello5=0.0d0
7263 cd        return
7264 cd      endif
7265 cd      write (iout,*)
7266 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7267 cd     &   ' and',k,l
7268       itk=itype2loc(itype(k))
7269       itl=itype2loc(itype(l))
7270       itj=itype2loc(itype(j))
7271       eello5_1=0.0d0
7272       eello5_2=0.0d0
7273       eello5_3=0.0d0
7274       eello5_4=0.0d0
7275 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7276 cd     &   eel5_3_num,eel5_4_num)
7277       do iii=1,2
7278         do kkk=1,5
7279           do lll=1,3
7280             derx(lll,kkk,iii)=0.0d0
7281           enddo
7282         enddo
7283       enddo
7284 cd      eij=facont_hb(jj,i)
7285 cd      ekl=facont_hb(kk,k)
7286 cd      ekont=eij*ekl
7287 cd      write (iout,*)'Contacts have occurred for peptide groups',
7288 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7289 cd      goto 1111
7290 C Contribution from the graph I.
7291 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7292 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7293       call transpose2(EUg(1,1,k),auxmat(1,1))
7294       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7295       vv(1)=pizda(1,1)-pizda(2,2)
7296       vv(2)=pizda(1,2)+pizda(2,1)
7297       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7298      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7299       if (calc_grad) then
7300 C Explicit gradient in virtual-dihedral angles.
7301       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7302      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7303      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7304       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7305       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7306       vv(1)=pizda(1,1)-pizda(2,2)
7307       vv(2)=pizda(1,2)+pizda(2,1)
7308       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7309      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7310      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7311       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7312       vv(1)=pizda(1,1)-pizda(2,2)
7313       vv(2)=pizda(1,2)+pizda(2,1)
7314       if (l.eq.j+1) then
7315         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7316      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7317      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7318       else
7319         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7320      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7321      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7322       endif
7323 C Cartesian gradient
7324       do iii=1,2
7325         do kkk=1,5
7326           do lll=1,3
7327             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7328      &        pizda(1,1))
7329             vv(1)=pizda(1,1)-pizda(2,2)
7330             vv(2)=pizda(1,2)+pizda(2,1)
7331             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7332      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7333      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7334           enddo
7335         enddo
7336       enddo
7337       endif ! calc_grad
7338 c      goto 1112
7339 c1111  continue
7340 C Contribution from graph II
7341       call transpose2(EE(1,1,k),auxmat(1,1))
7342       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7343       vv(1)=pizda(1,1)+pizda(2,2)
7344       vv(2)=pizda(2,1)-pizda(1,2)
7345       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7346      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7347       if (calc_grad) then
7348 C Explicit gradient in virtual-dihedral angles.
7349       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7350      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7351       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7352       vv(1)=pizda(1,1)+pizda(2,2)
7353       vv(2)=pizda(2,1)-pizda(1,2)
7354       if (l.eq.j+1) then
7355         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7356      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7357      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7358       else
7359         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7360      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7361      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7362       endif
7363 C Cartesian gradient
7364       do iii=1,2
7365         do kkk=1,5
7366           do lll=1,3
7367             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7368      &        pizda(1,1))
7369             vv(1)=pizda(1,1)+pizda(2,2)
7370             vv(2)=pizda(2,1)-pizda(1,2)
7371             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7372      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7373      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7374           enddo
7375         enddo
7376       enddo
7377       endif ! calc_grad
7378 cd      goto 1112
7379 cd1111  continue
7380       if (l.eq.j+1) then
7381 cd        goto 1110
7382 C Parallel orientation
7383 C Contribution from graph III
7384         call transpose2(EUg(1,1,l),auxmat(1,1))
7385         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7386         vv(1)=pizda(1,1)-pizda(2,2)
7387         vv(2)=pizda(1,2)+pizda(2,1)
7388         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7389      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7390         if (calc_grad) then
7391 C Explicit gradient in virtual-dihedral angles.
7392         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7393      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7394      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7395         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7396         vv(1)=pizda(1,1)-pizda(2,2)
7397         vv(2)=pizda(1,2)+pizda(2,1)
7398         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7399      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7400      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7401         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7402         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7403         vv(1)=pizda(1,1)-pizda(2,2)
7404         vv(2)=pizda(1,2)+pizda(2,1)
7405         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7406      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7408 C Cartesian gradient
7409         do iii=1,2
7410           do kkk=1,5
7411             do lll=1,3
7412               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7413      &          pizda(1,1))
7414               vv(1)=pizda(1,1)-pizda(2,2)
7415               vv(2)=pizda(1,2)+pizda(2,1)
7416               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7417      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7418      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7419             enddo
7420           enddo
7421         enddo
7422 cd        goto 1112
7423 C Contribution from graph IV
7424 cd1110    continue
7425         call transpose2(EE(1,1,l),auxmat(1,1))
7426         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7427         vv(1)=pizda(1,1)+pizda(2,2)
7428         vv(2)=pizda(2,1)-pizda(1,2)
7429         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7430      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7431 C Explicit gradient in virtual-dihedral angles.
7432         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7433      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7434         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7435         vv(1)=pizda(1,1)+pizda(2,2)
7436         vv(2)=pizda(2,1)-pizda(1,2)
7437         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7438      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7439      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7440 C Cartesian gradient
7441         do iii=1,2
7442           do kkk=1,5
7443             do lll=1,3
7444               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7445      &          pizda(1,1))
7446               vv(1)=pizda(1,1)+pizda(2,2)
7447               vv(2)=pizda(2,1)-pizda(1,2)
7448               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7449      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7450      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7451             enddo
7452           enddo
7453         enddo
7454         endif ! calc_grad
7455       else
7456 C Antiparallel orientation
7457 C Contribution from graph III
7458 c        goto 1110
7459         call transpose2(EUg(1,1,j),auxmat(1,1))
7460         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7461         vv(1)=pizda(1,1)-pizda(2,2)
7462         vv(2)=pizda(1,2)+pizda(2,1)
7463         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7464      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7465         if (calc_grad) then
7466 C Explicit gradient in virtual-dihedral angles.
7467         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7468      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7469      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7470         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7471         vv(1)=pizda(1,1)-pizda(2,2)
7472         vv(2)=pizda(1,2)+pizda(2,1)
7473         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7474      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7475      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7476         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7477         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7478         vv(1)=pizda(1,1)-pizda(2,2)
7479         vv(2)=pizda(1,2)+pizda(2,1)
7480         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7481      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7483 C Cartesian gradient
7484         do iii=1,2
7485           do kkk=1,5
7486             do lll=1,3
7487               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7488      &          pizda(1,1))
7489               vv(1)=pizda(1,1)-pizda(2,2)
7490               vv(2)=pizda(1,2)+pizda(2,1)
7491               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7492      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7493      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7494             enddo
7495           enddo
7496         enddo
7497         endif ! calc_grad
7498 cd        goto 1112
7499 C Contribution from graph IV
7500 1110    continue
7501         call transpose2(EE(1,1,j),auxmat(1,1))
7502         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7503         vv(1)=pizda(1,1)+pizda(2,2)
7504         vv(2)=pizda(2,1)-pizda(1,2)
7505         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7506      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7507         if (calc_grad) then
7508 C Explicit gradient in virtual-dihedral angles.
7509         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7510      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7511         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7512         vv(1)=pizda(1,1)+pizda(2,2)
7513         vv(2)=pizda(2,1)-pizda(1,2)
7514         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7515      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7516      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7517 C Cartesian gradient
7518         do iii=1,2
7519           do kkk=1,5
7520             do lll=1,3
7521               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7522      &          pizda(1,1))
7523               vv(1)=pizda(1,1)+pizda(2,2)
7524               vv(2)=pizda(2,1)-pizda(1,2)
7525               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7526      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7527      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7528             enddo
7529           enddo
7530         enddo
7531         endif ! calc_grad
7532       endif
7533 1112  continue
7534       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7535 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7536 cd        write (2,*) 'ijkl',i,j,k,l
7537 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7538 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7539 cd      endif
7540 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7541 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7542 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7543 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7544       if (calc_grad) then
7545       if (j.lt.nres-1) then
7546         j1=j+1
7547         j2=j-1
7548       else
7549         j1=j-1
7550         j2=j-2
7551       endif
7552       if (l.lt.nres-1) then
7553         l1=l+1
7554         l2=l-1
7555       else
7556         l1=l-1
7557         l2=l-2
7558       endif
7559 cd      eij=1.0d0
7560 cd      ekl=1.0d0
7561 cd      ekont=1.0d0
7562 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7563 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7564 C        summed up outside the subrouine as for the other subroutines
7565 C        handling long-range interactions. The old code is commented out
7566 C        with "cgrad" to keep track of changes.
7567       do ll=1,3
7568 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7569 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7570         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7571         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7572 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7573 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7574 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7575 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7576 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7577 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7578 c     &   gradcorr5ij,
7579 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7580 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7581 cgrad        ghalf=0.5d0*ggg1(ll)
7582 cd        ghalf=0.0d0
7583         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7584         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7585         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7586         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7587         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7588         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7589 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7590 cgrad        ghalf=0.5d0*ggg2(ll)
7591 cd        ghalf=0.0d0
7592         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7593         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7594         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7595         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7596         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7597         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7598       enddo
7599       endif ! calc_grad
7600 cd      goto 1112
7601 cgrad      do m=i+1,j-1
7602 cgrad        do ll=1,3
7603 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7604 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7605 cgrad        enddo
7606 cgrad      enddo
7607 cgrad      do m=k+1,l-1
7608 cgrad        do ll=1,3
7609 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7610 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7611 cgrad        enddo
7612 cgrad      enddo
7613 c1112  continue
7614 cgrad      do m=i+2,j2
7615 cgrad        do ll=1,3
7616 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7617 cgrad        enddo
7618 cgrad      enddo
7619 cgrad      do m=k+2,l2
7620 cgrad        do ll=1,3
7621 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7622 cgrad        enddo
7623 cgrad      enddo
7624 cd      do iii=1,nres-3
7625 cd        write (2,*) iii,g_corr5_loc(iii)
7626 cd      enddo
7627       eello5=ekont*eel5
7628 cd      write (2,*) 'ekont',ekont
7629 cd      write (iout,*) 'eello5',ekont*eel5
7630       return
7631       end
7632 c--------------------------------------------------------------------------
7633       double precision function eello6(i,j,k,l,jj,kk)
7634       implicit real*8 (a-h,o-z)
7635       include 'DIMENSIONS'
7636       include 'COMMON.IOUNITS'
7637       include 'COMMON.CHAIN'
7638       include 'COMMON.DERIV'
7639       include 'COMMON.INTERACT'
7640       include 'COMMON.CONTACTS'
7641       include 'COMMON.TORSION'
7642       include 'COMMON.VAR'
7643       include 'COMMON.GEO'
7644       include 'COMMON.FFIELD'
7645       double precision ggg1(3),ggg2(3)
7646 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7647 cd        eello6=0.0d0
7648 cd        return
7649 cd      endif
7650 cd      write (iout,*)
7651 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7652 cd     &   ' and',k,l
7653       eello6_1=0.0d0
7654       eello6_2=0.0d0
7655       eello6_3=0.0d0
7656       eello6_4=0.0d0
7657       eello6_5=0.0d0
7658       eello6_6=0.0d0
7659 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7660 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7661       do iii=1,2
7662         do kkk=1,5
7663           do lll=1,3
7664             derx(lll,kkk,iii)=0.0d0
7665           enddo
7666         enddo
7667       enddo
7668 cd      eij=facont_hb(jj,i)
7669 cd      ekl=facont_hb(kk,k)
7670 cd      ekont=eij*ekl
7671 cd      eij=1.0d0
7672 cd      ekl=1.0d0
7673 cd      ekont=1.0d0
7674       if (l.eq.j+1) then
7675         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7676         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7677         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7678         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7679         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7680         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7681       else
7682         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7683         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7684         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7685         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7686         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7687           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7688         else
7689           eello6_5=0.0d0
7690         endif
7691         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7692       endif
7693 C If turn contributions are considered, they will be handled separately.
7694       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7695 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7696 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7697 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7698 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7699 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7700 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7701 cd      goto 1112
7702       if (calc_grad) then
7703       if (j.lt.nres-1) then
7704         j1=j+1
7705         j2=j-1
7706       else
7707         j1=j-1
7708         j2=j-2
7709       endif
7710       if (l.lt.nres-1) then
7711         l1=l+1
7712         l2=l-1
7713       else
7714         l1=l-1
7715         l2=l-2
7716       endif
7717       do ll=1,3
7718 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7719 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7720 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7721 cgrad        ghalf=0.5d0*ggg1(ll)
7722 cd        ghalf=0.0d0
7723         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7724         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7725         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7726         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7727         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7728         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7729         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7730         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7731 cgrad        ghalf=0.5d0*ggg2(ll)
7732 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7733 cd        ghalf=0.0d0
7734         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7735         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7736         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7737         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7738         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7739         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7740       enddo
7741       endif ! calc_grad
7742 cd      goto 1112
7743 cgrad      do m=i+1,j-1
7744 cgrad        do ll=1,3
7745 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7746 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7747 cgrad        enddo
7748 cgrad      enddo
7749 cgrad      do m=k+1,l-1
7750 cgrad        do ll=1,3
7751 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7752 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7753 cgrad        enddo
7754 cgrad      enddo
7755 cgrad1112  continue
7756 cgrad      do m=i+2,j2
7757 cgrad        do ll=1,3
7758 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7759 cgrad        enddo
7760 cgrad      enddo
7761 cgrad      do m=k+2,l2
7762 cgrad        do ll=1,3
7763 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7764 cgrad        enddo
7765 cgrad      enddo
7766 cd      do iii=1,nres-3
7767 cd        write (2,*) iii,g_corr6_loc(iii)
7768 cd      enddo
7769       eello6=ekont*eel6
7770 cd      write (2,*) 'ekont',ekont
7771 cd      write (iout,*) 'eello6',ekont*eel6
7772       return
7773       end
7774 c--------------------------------------------------------------------------
7775       double precision function eello6_graph1(i,j,k,l,imat,swap)
7776       implicit real*8 (a-h,o-z)
7777       include 'DIMENSIONS'
7778       include 'COMMON.IOUNITS'
7779       include 'COMMON.CHAIN'
7780       include 'COMMON.DERIV'
7781       include 'COMMON.INTERACT'
7782       include 'COMMON.CONTACTS'
7783       include 'COMMON.TORSION'
7784       include 'COMMON.VAR'
7785       include 'COMMON.GEO'
7786       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7787       logical swap
7788       logical lprn
7789       common /kutas/ lprn
7790 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7791 C                                                                              C
7792 C      Parallel       Antiparallel                                             C
7793 C                                                                              C
7794 C          o             o                                                     C
7795 C         /l\           /j\                                                    C
7796 C        /   \         /   \                                                   C
7797 C       /| o |         | o |\                                                  C
7798 C     \ j|/k\|  /   \  |/k\|l /                                                C
7799 C      \ /   \ /     \ /   \ /                                                 C
7800 C       o     o       o     o                                                  C
7801 C       i             i                                                        C
7802 C                                                                              C
7803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7804       itk=itype2loc(itype(k))
7805       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7806       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7807       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7808       call transpose2(EUgC(1,1,k),auxmat(1,1))
7809       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7810       vv1(1)=pizda1(1,1)-pizda1(2,2)
7811       vv1(2)=pizda1(1,2)+pizda1(2,1)
7812       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7813       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7814       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7815       s5=scalar2(vv(1),Dtobr2(1,i))
7816 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7817       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7818       if (calc_grad) then
7819       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7820      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7821      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7822      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7823      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7824      & +scalar2(vv(1),Dtobr2der(1,i)))
7825       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7826       vv1(1)=pizda1(1,1)-pizda1(2,2)
7827       vv1(2)=pizda1(1,2)+pizda1(2,1)
7828       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7829       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7830       if (l.eq.j+1) then
7831         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7832      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7833      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7834      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7835      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7836       else
7837         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7838      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7839      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7840      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7841      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7842       endif
7843       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7844       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7845       vv1(1)=pizda1(1,1)-pizda1(2,2)
7846       vv1(2)=pizda1(1,2)+pizda1(2,1)
7847       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7848      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7849      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7850      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7851       do iii=1,2
7852         if (swap) then
7853           ind=3-iii
7854         else
7855           ind=iii
7856         endif
7857         do kkk=1,5
7858           do lll=1,3
7859             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7860             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7861             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7862             call transpose2(EUgC(1,1,k),auxmat(1,1))
7863             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7864      &        pizda1(1,1))
7865             vv1(1)=pizda1(1,1)-pizda1(2,2)
7866             vv1(2)=pizda1(1,2)+pizda1(2,1)
7867             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7868             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7869      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7870             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7871      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7872             s5=scalar2(vv(1),Dtobr2(1,i))
7873             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7874           enddo
7875         enddo
7876       enddo
7877       endif ! calc_grad
7878       return
7879       end
7880 c----------------------------------------------------------------------------
7881       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7882       implicit real*8 (a-h,o-z)
7883       include 'DIMENSIONS'
7884       include 'COMMON.IOUNITS'
7885       include 'COMMON.CHAIN'
7886       include 'COMMON.DERIV'
7887       include 'COMMON.INTERACT'
7888       include 'COMMON.CONTACTS'
7889       include 'COMMON.TORSION'
7890       include 'COMMON.VAR'
7891       include 'COMMON.GEO'
7892       logical swap
7893       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7894      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7895       logical lprn
7896       common /kutas/ lprn
7897 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7898 C                                                                              C
7899 C      Parallel       Antiparallel                                             C
7900 C                                                                              C
7901 C          o             o                                                     C
7902 C     \   /l\           /j\   /                                                C
7903 C      \ /   \         /   \ /                                                 C
7904 C       o| o |         | o |o                                                  C
7905 C     \ j|/k\|      \  |/k\|l                                                  C
7906 C      \ /   \       \ /   \                                                   C
7907 C       o             o                                                        C
7908 C       i             i                                                        C
7909 C                                                                              C
7910 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7911 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7912 C AL 7/4/01 s1 would occur in the sixth-order moment,
7913 C           but not in a cluster cumulant
7914 #ifdef MOMENT
7915       s1=dip(1,jj,i)*dip(1,kk,k)
7916 #endif
7917       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7918       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7919       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7920       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7921       call transpose2(EUg(1,1,k),auxmat(1,1))
7922       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7923       vv(1)=pizda(1,1)-pizda(2,2)
7924       vv(2)=pizda(1,2)+pizda(2,1)
7925       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7926 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7927 #ifdef MOMENT
7928       eello6_graph2=-(s1+s2+s3+s4)
7929 #else
7930       eello6_graph2=-(s2+s3+s4)
7931 #endif
7932 c      eello6_graph2=-s3
7933 C Derivatives in gamma(i-1)
7934       if (calc_grad) then
7935       if (i.gt.1) then
7936 #ifdef MOMENT
7937         s1=dipderg(1,jj,i)*dip(1,kk,k)
7938 #endif
7939         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7940         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7941         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7942         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7943 #ifdef MOMENT
7944         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7945 #else
7946         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7947 #endif
7948 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7949       endif
7950 C Derivatives in gamma(k-1)
7951 #ifdef MOMENT
7952       s1=dip(1,jj,i)*dipderg(1,kk,k)
7953 #endif
7954       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7955       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7956       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7957       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7958       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7959       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7960       vv(1)=pizda(1,1)-pizda(2,2)
7961       vv(2)=pizda(1,2)+pizda(2,1)
7962       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7963 #ifdef MOMENT
7964       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7965 #else
7966       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7967 #endif
7968 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7969 C Derivatives in gamma(j-1) or gamma(l-1)
7970       if (j.gt.1) then
7971 #ifdef MOMENT
7972         s1=dipderg(3,jj,i)*dip(1,kk,k)
7973 #endif
7974         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7975         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7976         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7977         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7978         vv(1)=pizda(1,1)-pizda(2,2)
7979         vv(2)=pizda(1,2)+pizda(2,1)
7980         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7981 #ifdef MOMENT
7982         if (swap) then
7983           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7984         else
7985           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7986         endif
7987 #endif
7988         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7989 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7990       endif
7991 C Derivatives in gamma(l-1) or gamma(j-1)
7992       if (l.gt.1) then
7993 #ifdef MOMENT
7994         s1=dip(1,jj,i)*dipderg(3,kk,k)
7995 #endif
7996         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7997         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7998         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7999         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8000         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8001         vv(1)=pizda(1,1)-pizda(2,2)
8002         vv(2)=pizda(1,2)+pizda(2,1)
8003         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8004 #ifdef MOMENT
8005         if (swap) then
8006           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8007         else
8008           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8009         endif
8010 #endif
8011         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8012 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8013       endif
8014 C Cartesian derivatives.
8015       if (lprn) then
8016         write (2,*) 'In eello6_graph2'
8017         do iii=1,2
8018           write (2,*) 'iii=',iii
8019           do kkk=1,5
8020             write (2,*) 'kkk=',kkk
8021             do jjj=1,2
8022               write (2,'(3(2f10.5),5x)')
8023      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8024             enddo
8025           enddo
8026         enddo
8027       endif
8028       do iii=1,2
8029         do kkk=1,5
8030           do lll=1,3
8031 #ifdef MOMENT
8032             if (iii.eq.1) then
8033               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8034             else
8035               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8036             endif
8037 #endif
8038             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8039      &        auxvec(1))
8040             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8041             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8042      &        auxvec(1))
8043             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8044             call transpose2(EUg(1,1,k),auxmat(1,1))
8045             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8046      &        pizda(1,1))
8047             vv(1)=pizda(1,1)-pizda(2,2)
8048             vv(2)=pizda(1,2)+pizda(2,1)
8049             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8050 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8051 #ifdef MOMENT
8052             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8053 #else
8054             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8055 #endif
8056             if (swap) then
8057               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8058             else
8059               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8060             endif
8061           enddo
8062         enddo
8063       enddo
8064       endif ! calc_grad
8065       return
8066       end
8067 c----------------------------------------------------------------------------
8068       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8069       implicit real*8 (a-h,o-z)
8070       include 'DIMENSIONS'
8071       include 'COMMON.IOUNITS'
8072       include 'COMMON.CHAIN'
8073       include 'COMMON.DERIV'
8074       include 'COMMON.INTERACT'
8075       include 'COMMON.CONTACTS'
8076       include 'COMMON.TORSION'
8077       include 'COMMON.VAR'
8078       include 'COMMON.GEO'
8079       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8080       logical swap
8081 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8082 C                                                                              C
8083 C      Parallel       Antiparallel                                             C
8084 C                                                                              C
8085 C          o             o                                                     C
8086 C         /l\   /   \   /j\                                                    C
8087 C        /   \ /     \ /   \                                                   C
8088 C       /| o |o       o| o |\                                                  C
8089 C       j|/k\|  /      |/k\|l /                                                C
8090 C        /   \ /       /   \ /                                                 C
8091 C       /     o       /     o                                                  C
8092 C       i             i                                                        C
8093 C                                                                              C
8094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8095 C
8096 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8097 C           energy moment and not to the cluster cumulant.
8098       iti=itortyp(itype(i))
8099       if (j.lt.nres-1) then
8100         itj1=itype2loc(itype(j+1))
8101       else
8102         itj1=nloctyp
8103       endif
8104       itk=itype2loc(itype(k))
8105       itk1=itype2loc(itype(k+1))
8106       if (l.lt.nres-1) then
8107         itl1=itype2loc(itype(l+1))
8108       else
8109         itl1=nloctyp
8110       endif
8111 #ifdef MOMENT
8112       s1=dip(4,jj,i)*dip(4,kk,k)
8113 #endif
8114       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8115       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8116       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8117       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8118       call transpose2(EE(1,1,k),auxmat(1,1))
8119       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8120       vv(1)=pizda(1,1)+pizda(2,2)
8121       vv(2)=pizda(2,1)-pizda(1,2)
8122       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8123 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8124 cd     & "sum",-(s2+s3+s4)
8125 #ifdef MOMENT
8126       eello6_graph3=-(s1+s2+s3+s4)
8127 #else
8128       eello6_graph3=-(s2+s3+s4)
8129 #endif
8130 c      eello6_graph3=-s4
8131 C Derivatives in gamma(k-1)
8132       if (calc_grad) then
8133       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8134       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8135       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8136       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8137 C Derivatives in gamma(l-1)
8138       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8139       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8140       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8141       vv(1)=pizda(1,1)+pizda(2,2)
8142       vv(2)=pizda(2,1)-pizda(1,2)
8143       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8144       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8145 C Cartesian derivatives.
8146       do iii=1,2
8147         do kkk=1,5
8148           do lll=1,3
8149 #ifdef MOMENT
8150             if (iii.eq.1) then
8151               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8152             else
8153               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8154             endif
8155 #endif
8156             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8157      &        auxvec(1))
8158             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8159             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8160      &        auxvec(1))
8161             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8162             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8163      &        pizda(1,1))
8164             vv(1)=pizda(1,1)+pizda(2,2)
8165             vv(2)=pizda(2,1)-pizda(1,2)
8166             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8167 #ifdef MOMENT
8168             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8169 #else
8170             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8171 #endif
8172             if (swap) then
8173               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8174             else
8175               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8176             endif
8177 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8178           enddo
8179         enddo
8180       enddo
8181       endif ! calc_grad
8182       return
8183       end
8184 c----------------------------------------------------------------------------
8185       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8186       implicit real*8 (a-h,o-z)
8187       include 'DIMENSIONS'
8188       include 'COMMON.IOUNITS'
8189       include 'COMMON.CHAIN'
8190       include 'COMMON.DERIV'
8191       include 'COMMON.INTERACT'
8192       include 'COMMON.CONTACTS'
8193       include 'COMMON.TORSION'
8194       include 'COMMON.VAR'
8195       include 'COMMON.GEO'
8196       include 'COMMON.FFIELD'
8197       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8198      & auxvec1(2),auxmat1(2,2)
8199       logical swap
8200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8201 C                                                                              C
8202 C      Parallel       Antiparallel                                             C
8203 C                                                                              C
8204 C          o             o                                                     C
8205 C         /l\   /   \   /j\                                                    C
8206 C        /   \ /     \ /   \                                                   C
8207 C       /| o |o       o| o |\                                                  C
8208 C     \ j|/k\|      \  |/k\|l                                                  C
8209 C      \ /   \       \ /   \                                                   C
8210 C       o     \       o     \                                                  C
8211 C       i             i                                                        C
8212 C                                                                              C
8213 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8214 C
8215 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8216 C           energy moment and not to the cluster cumulant.
8217 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8218       iti=itype2loc(itype(i))
8219       itj=itype2loc(itype(j))
8220       if (j.lt.nres-1) then
8221         itj1=itype2loc(itype(j+1))
8222       else
8223         itj1=nloctyp
8224       endif
8225       itk=itype2loc(itype(k))
8226       if (k.lt.nres-1) then
8227         itk1=itype2loc(itype(k+1))
8228       else
8229         itk1=nloctyp
8230       endif
8231       itl=itype2loc(itype(l))
8232       if (l.lt.nres-1) then
8233         itl1=itype2loc(itype(l+1))
8234       else
8235         itl1=nloctyp
8236       endif
8237 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8238 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8239 cd     & ' itl',itl,' itl1',itl1
8240 #ifdef MOMENT
8241       if (imat.eq.1) then
8242         s1=dip(3,jj,i)*dip(3,kk,k)
8243       else
8244         s1=dip(2,jj,j)*dip(2,kk,l)
8245       endif
8246 #endif
8247       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8248       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8249       if (j.eq.l+1) then
8250         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8251         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8252       else
8253         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8254         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8255       endif
8256       call transpose2(EUg(1,1,k),auxmat(1,1))
8257       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8258       vv(1)=pizda(1,1)-pizda(2,2)
8259       vv(2)=pizda(2,1)+pizda(1,2)
8260       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8261 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8262 #ifdef MOMENT
8263       eello6_graph4=-(s1+s2+s3+s4)
8264 #else
8265       eello6_graph4=-(s2+s3+s4)
8266 #endif
8267 C Derivatives in gamma(i-1)
8268       if (calc_grad) then
8269       if (i.gt.1) then
8270 #ifdef MOMENT
8271         if (imat.eq.1) then
8272           s1=dipderg(2,jj,i)*dip(3,kk,k)
8273         else
8274           s1=dipderg(4,jj,j)*dip(2,kk,l)
8275         endif
8276 #endif
8277         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8278         if (j.eq.l+1) then
8279           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8280           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8281         else
8282           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8283           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8284         endif
8285         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8286         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8287 cd          write (2,*) 'turn6 derivatives'
8288 #ifdef MOMENT
8289           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8290 #else
8291           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8292 #endif
8293         else
8294 #ifdef MOMENT
8295           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8296 #else
8297           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8298 #endif
8299         endif
8300       endif
8301 C Derivatives in gamma(k-1)
8302 #ifdef MOMENT
8303       if (imat.eq.1) then
8304         s1=dip(3,jj,i)*dipderg(2,kk,k)
8305       else
8306         s1=dip(2,jj,j)*dipderg(4,kk,l)
8307       endif
8308 #endif
8309       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8310       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8311       if (j.eq.l+1) then
8312         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8313         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8314       else
8315         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8316         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8317       endif
8318       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8319       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8320       vv(1)=pizda(1,1)-pizda(2,2)
8321       vv(2)=pizda(2,1)+pizda(1,2)
8322       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8323       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8324 #ifdef MOMENT
8325         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8326 #else
8327         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8328 #endif
8329       else
8330 #ifdef MOMENT
8331         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8332 #else
8333         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8334 #endif
8335       endif
8336 C Derivatives in gamma(j-1) or gamma(l-1)
8337       if (l.eq.j+1 .and. l.gt.1) then
8338         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8339         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8340         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8341         vv(1)=pizda(1,1)-pizda(2,2)
8342         vv(2)=pizda(2,1)+pizda(1,2)
8343         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8344         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8345       else if (j.gt.1) then
8346         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8347         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8348         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8349         vv(1)=pizda(1,1)-pizda(2,2)
8350         vv(2)=pizda(2,1)+pizda(1,2)
8351         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8352         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8353           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8354         else
8355           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8356         endif
8357       endif
8358 C Cartesian derivatives.
8359       do iii=1,2
8360         do kkk=1,5
8361           do lll=1,3
8362 #ifdef MOMENT
8363             if (iii.eq.1) then
8364               if (imat.eq.1) then
8365                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8366               else
8367                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8368               endif
8369             else
8370               if (imat.eq.1) then
8371                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8372               else
8373                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8374               endif
8375             endif
8376 #endif
8377             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8378      &        auxvec(1))
8379             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8380             if (j.eq.l+1) then
8381               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8382      &          b1(1,j+1),auxvec(1))
8383               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8384             else
8385               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8386      &          b1(1,l+1),auxvec(1))
8387               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8388             endif
8389             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8390      &        pizda(1,1))
8391             vv(1)=pizda(1,1)-pizda(2,2)
8392             vv(2)=pizda(2,1)+pizda(1,2)
8393             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8394             if (swap) then
8395               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8396 #ifdef MOMENT
8397                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8398      &             -(s1+s2+s4)
8399 #else
8400                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8401      &             -(s2+s4)
8402 #endif
8403                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8404               else
8405 #ifdef MOMENT
8406                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8407 #else
8408                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8409 #endif
8410                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8411               endif
8412             else
8413 #ifdef MOMENT
8414               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8415 #else
8416               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8417 #endif
8418               if (l.eq.j+1) then
8419                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8420               else
8421                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8422               endif
8423             endif
8424           enddo
8425         enddo
8426       enddo
8427       endif ! calc_grad
8428       return
8429       end
8430 c----------------------------------------------------------------------------
8431       double precision function eello_turn6(i,jj,kk)
8432       implicit real*8 (a-h,o-z)
8433       include 'DIMENSIONS'
8434       include 'COMMON.IOUNITS'
8435       include 'COMMON.CHAIN'
8436       include 'COMMON.DERIV'
8437       include 'COMMON.INTERACT'
8438       include 'COMMON.CONTACTS'
8439       include 'COMMON.TORSION'
8440       include 'COMMON.VAR'
8441       include 'COMMON.GEO'
8442       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8443      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8444      &  ggg1(3),ggg2(3)
8445       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8446      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8447 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8448 C           the respective energy moment and not to the cluster cumulant.
8449       s1=0.0d0
8450       s8=0.0d0
8451       s13=0.0d0
8452 c
8453       eello_turn6=0.0d0
8454       j=i+4
8455       k=i+1
8456       l=i+3
8457       iti=itype2loc(itype(i))
8458       itk=itype2loc(itype(k))
8459       itk1=itype2loc(itype(k+1))
8460       itl=itype2loc(itype(l))
8461       itj=itype2loc(itype(j))
8462 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8463 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8464 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8465 cd        eello6=0.0d0
8466 cd        return
8467 cd      endif
8468 cd      write (iout,*)
8469 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8470 cd     &   ' and',k,l
8471 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8472       do iii=1,2
8473         do kkk=1,5
8474           do lll=1,3
8475             derx_turn(lll,kkk,iii)=0.0d0
8476           enddo
8477         enddo
8478       enddo
8479 cd      eij=1.0d0
8480 cd      ekl=1.0d0
8481 cd      ekont=1.0d0
8482       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8483 cd      eello6_5=0.0d0
8484 cd      write (2,*) 'eello6_5',eello6_5
8485 #ifdef MOMENT
8486       call transpose2(AEA(1,1,1),auxmat(1,1))
8487       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8488       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8489       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8490 #endif
8491       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8492       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8493       s2 = scalar2(b1(1,k),vtemp1(1))
8494 #ifdef MOMENT
8495       call transpose2(AEA(1,1,2),atemp(1,1))
8496       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8497       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8498       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8499 #endif
8500       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8501       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8502       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8503 #ifdef MOMENT
8504       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8505       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8506       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8507       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8508       ss13 = scalar2(b1(1,k),vtemp4(1))
8509       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8510 #endif
8511 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8512 c      s1=0.0d0
8513 c      s2=0.0d0
8514 c      s8=0.0d0
8515 c      s12=0.0d0
8516 c      s13=0.0d0
8517       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8518 C Derivatives in gamma(i+2)
8519       if (calc_grad) then
8520       s1d =0.0d0
8521       s8d =0.0d0
8522 #ifdef MOMENT
8523       call transpose2(AEA(1,1,1),auxmatd(1,1))
8524       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8525       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8526       call transpose2(AEAderg(1,1,2),atempd(1,1))
8527       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8528       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8529 #endif
8530       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8531       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8532       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8533 c      s1d=0.0d0
8534 c      s2d=0.0d0
8535 c      s8d=0.0d0
8536 c      s12d=0.0d0
8537 c      s13d=0.0d0
8538       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8539 C Derivatives in gamma(i+3)
8540 #ifdef MOMENT
8541       call transpose2(AEA(1,1,1),auxmatd(1,1))
8542       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8543       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8544       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8545 #endif
8546       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8547       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8548       s2d = scalar2(b1(1,k),vtemp1d(1))
8549 #ifdef MOMENT
8550       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8551       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8552 #endif
8553       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8554 #ifdef MOMENT
8555       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8556       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8557       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8558 #endif
8559 c      s1d=0.0d0
8560 c      s2d=0.0d0
8561 c      s8d=0.0d0
8562 c      s12d=0.0d0
8563 c      s13d=0.0d0
8564 #ifdef MOMENT
8565       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8566      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8567 #else
8568       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8569      &               -0.5d0*ekont*(s2d+s12d)
8570 #endif
8571 C Derivatives in gamma(i+4)
8572       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8573       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8574       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8575 #ifdef MOMENT
8576       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8577       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8578       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8579 #endif
8580 c      s1d=0.0d0
8581 c      s2d=0.0d0
8582 c      s8d=0.0d0
8583 C      s12d=0.0d0
8584 c      s13d=0.0d0
8585 #ifdef MOMENT
8586       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8587 #else
8588       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8589 #endif
8590 C Derivatives in gamma(i+5)
8591 #ifdef MOMENT
8592       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8593       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8594       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8595 #endif
8596       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8597       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8598       s2d = scalar2(b1(1,k),vtemp1d(1))
8599 #ifdef MOMENT
8600       call transpose2(AEA(1,1,2),atempd(1,1))
8601       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8602       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8603 #endif
8604       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8605       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8606 #ifdef MOMENT
8607       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8608       ss13d = scalar2(b1(1,k),vtemp4d(1))
8609       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8610 #endif
8611 c      s1d=0.0d0
8612 c      s2d=0.0d0
8613 c      s8d=0.0d0
8614 c      s12d=0.0d0
8615 c      s13d=0.0d0
8616 #ifdef MOMENT
8617       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8618      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8619 #else
8620       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8621      &               -0.5d0*ekont*(s2d+s12d)
8622 #endif
8623 C Cartesian derivatives
8624       do iii=1,2
8625         do kkk=1,5
8626           do lll=1,3
8627 #ifdef MOMENT
8628             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8629             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8630             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8631 #endif
8632             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8633             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8634      &          vtemp1d(1))
8635             s2d = scalar2(b1(1,k),vtemp1d(1))
8636 #ifdef MOMENT
8637             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8638             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8639             s8d = -(atempd(1,1)+atempd(2,2))*
8640      &           scalar2(cc(1,1,l),vtemp2(1))
8641 #endif
8642             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8643      &           auxmatd(1,1))
8644             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8645             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8646 c      s1d=0.0d0
8647 c      s2d=0.0d0
8648 c      s8d=0.0d0
8649 c      s12d=0.0d0
8650 c      s13d=0.0d0
8651 #ifdef MOMENT
8652             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8653      &        - 0.5d0*(s1d+s2d)
8654 #else
8655             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8656      &        - 0.5d0*s2d
8657 #endif
8658 #ifdef MOMENT
8659             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8660      &        - 0.5d0*(s8d+s12d)
8661 #else
8662             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8663      &        - 0.5d0*s12d
8664 #endif
8665           enddo
8666         enddo
8667       enddo
8668 #ifdef MOMENT
8669       do kkk=1,5
8670         do lll=1,3
8671           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8672      &      achuj_tempd(1,1))
8673           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8674           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8675           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8676           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8677           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8678      &      vtemp4d(1))
8679           ss13d = scalar2(b1(1,k),vtemp4d(1))
8680           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8681           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8682         enddo
8683       enddo
8684 #endif
8685 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8686 cd     &  16*eel_turn6_num
8687 cd      goto 1112
8688       if (j.lt.nres-1) then
8689         j1=j+1
8690         j2=j-1
8691       else
8692         j1=j-1
8693         j2=j-2
8694       endif
8695       if (l.lt.nres-1) then
8696         l1=l+1
8697         l2=l-1
8698       else
8699         l1=l-1
8700         l2=l-2
8701       endif
8702       do ll=1,3
8703 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8704 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8705 cgrad        ghalf=0.5d0*ggg1(ll)
8706 cd        ghalf=0.0d0
8707         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8708         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8709         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8710      &    +ekont*derx_turn(ll,2,1)
8711         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8712         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8713      &    +ekont*derx_turn(ll,4,1)
8714         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8715         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8716         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8717 cgrad        ghalf=0.5d0*ggg2(ll)
8718 cd        ghalf=0.0d0
8719         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8720      &    +ekont*derx_turn(ll,2,2)
8721         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8722         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8723      &    +ekont*derx_turn(ll,4,2)
8724         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8725         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8726         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8727       enddo
8728 cd      goto 1112
8729 cgrad      do m=i+1,j-1
8730 cgrad        do ll=1,3
8731 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8732 cgrad        enddo
8733 cgrad      enddo
8734 cgrad      do m=k+1,l-1
8735 cgrad        do ll=1,3
8736 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8737 cgrad        enddo
8738 cgrad      enddo
8739 cgrad1112  continue
8740 cgrad      do m=i+2,j2
8741 cgrad        do ll=1,3
8742 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8743 cgrad        enddo
8744 cgrad      enddo
8745 cgrad      do m=k+2,l2
8746 cgrad        do ll=1,3
8747 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8748 cgrad        enddo
8749 cgrad      enddo
8750 cd      do iii=1,nres-3
8751 cd        write (2,*) iii,g_corr6_loc(iii)
8752 cd      enddo
8753       endif ! calc_grad
8754       eello_turn6=ekont*eel_turn6
8755 cd      write (2,*) 'ekont',ekont
8756 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8757       return
8758       end
8759
8760 crc-------------------------------------------------
8761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8762       subroutine Eliptransfer(eliptran)
8763       implicit real*8 (a-h,o-z)
8764       include 'DIMENSIONS'
8765       include 'COMMON.GEO'
8766       include 'COMMON.VAR'
8767       include 'COMMON.LOCAL'
8768       include 'COMMON.CHAIN'
8769       include 'COMMON.DERIV'
8770       include 'COMMON.INTERACT'
8771       include 'COMMON.IOUNITS'
8772       include 'COMMON.CALC'
8773       include 'COMMON.CONTROL'
8774       include 'COMMON.SPLITELE'
8775       include 'COMMON.SBRIDGE'
8776 C this is done by Adasko
8777 C      print *,"wchodze"
8778 C structure of box:
8779 C      water
8780 C--bordliptop-- buffore starts
8781 C--bufliptop--- here true lipid starts
8782 C      lipid
8783 C--buflipbot--- lipid ends buffore starts
8784 C--bordlipbot--buffore ends
8785       eliptran=0.0
8786       do i=1,nres
8787 C       do i=1,1
8788         if (itype(i).eq.ntyp1) cycle
8789
8790         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8791         if (positi.le.0) positi=positi+boxzsize
8792 C        print *,i
8793 C first for peptide groups
8794 c for each residue check if it is in lipid or lipid water border area
8795        if ((positi.gt.bordlipbot)
8796      &.and.(positi.lt.bordliptop)) then
8797 C the energy transfer exist
8798         if (positi.lt.buflipbot) then
8799 C what fraction I am in
8800          fracinbuf=1.0d0-
8801      &        ((positi-bordlipbot)/lipbufthick)
8802 C lipbufthick is thickenes of lipid buffore
8803          sslip=sscalelip(fracinbuf)
8804          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8805          eliptran=eliptran+sslip*pepliptran
8806          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8807          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8808 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8809         elseif (positi.gt.bufliptop) then
8810          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8811          sslip=sscalelip(fracinbuf)
8812          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8813          eliptran=eliptran+sslip*pepliptran
8814          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8815          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8816 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8817 C          print *, "doing sscalefor top part"
8818 C         print *,i,sslip,fracinbuf,ssgradlip
8819         else
8820          eliptran=eliptran+pepliptran
8821 C         print *,"I am in true lipid"
8822         endif
8823 C       else
8824 C       eliptran=elpitran+0.0 ! I am in water
8825        endif
8826        enddo
8827 C       print *, "nic nie bylo w lipidzie?"
8828 C now multiply all by the peptide group transfer factor
8829 C       eliptran=eliptran*pepliptran
8830 C now the same for side chains
8831 CV       do i=1,1
8832        do i=1,nres
8833         if (itype(i).eq.ntyp1) cycle
8834         positi=(mod(c(3,i+nres),boxzsize))
8835         if (positi.le.0) positi=positi+boxzsize
8836 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8837 c for each residue check if it is in lipid or lipid water border area
8838 C       respos=mod(c(3,i+nres),boxzsize)
8839 C       print *,positi,bordlipbot,buflipbot
8840        if ((positi.gt.bordlipbot)
8841      & .and.(positi.lt.bordliptop)) then
8842 C the energy transfer exist
8843         if (positi.lt.buflipbot) then
8844          fracinbuf=1.0d0-
8845      &     ((positi-bordlipbot)/lipbufthick)
8846 C lipbufthick is thickenes of lipid buffore
8847          sslip=sscalelip(fracinbuf)
8848          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8849          eliptran=eliptran+sslip*liptranene(itype(i))
8850          gliptranx(3,i)=gliptranx(3,i)
8851      &+ssgradlip*liptranene(itype(i))
8852          gliptranc(3,i-1)= gliptranc(3,i-1)
8853      &+ssgradlip*liptranene(itype(i))
8854 C         print *,"doing sccale for lower part"
8855         elseif (positi.gt.bufliptop) then
8856          fracinbuf=1.0d0-
8857      &((bordliptop-positi)/lipbufthick)
8858          sslip=sscalelip(fracinbuf)
8859          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8860          eliptran=eliptran+sslip*liptranene(itype(i))
8861          gliptranx(3,i)=gliptranx(3,i)
8862      &+ssgradlip*liptranene(itype(i))
8863          gliptranc(3,i-1)= gliptranc(3,i-1)
8864      &+ssgradlip*liptranene(itype(i))
8865 C          print *, "doing sscalefor top part",sslip,fracinbuf
8866         else
8867          eliptran=eliptran+liptranene(itype(i))
8868 C         print *,"I am in true lipid"
8869         endif
8870         endif ! if in lipid or buffor
8871 C       else
8872 C       eliptran=elpitran+0.0 ! I am in water
8873        enddo
8874        return
8875        end
8876
8877
8878 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8879
8880       SUBROUTINE MATVEC2(A1,V1,V2)
8881       implicit real*8 (a-h,o-z)
8882       include 'DIMENSIONS'
8883       DIMENSION A1(2,2),V1(2),V2(2)
8884 c      DO 1 I=1,2
8885 c        VI=0.0
8886 c        DO 3 K=1,2
8887 c    3     VI=VI+A1(I,K)*V1(K)
8888 c        Vaux(I)=VI
8889 c    1 CONTINUE
8890
8891       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8892       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8893
8894       v2(1)=vaux1
8895       v2(2)=vaux2
8896       END
8897 C---------------------------------------
8898       SUBROUTINE MATMAT2(A1,A2,A3)
8899       implicit real*8 (a-h,o-z)
8900       include 'DIMENSIONS'
8901       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8902 c      DIMENSION AI3(2,2)
8903 c        DO  J=1,2
8904 c          A3IJ=0.0
8905 c          DO K=1,2
8906 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8907 c          enddo
8908 c          A3(I,J)=A3IJ
8909 c       enddo
8910 c      enddo
8911
8912       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8913       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8914       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8915       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8916
8917       A3(1,1)=AI3_11
8918       A3(2,1)=AI3_21
8919       A3(1,2)=AI3_12
8920       A3(2,2)=AI3_22
8921       END
8922
8923 c-------------------------------------------------------------------------
8924       double precision function scalar2(u,v)
8925       implicit none
8926       double precision u(2),v(2)
8927       double precision sc
8928       integer i
8929       scalar2=u(1)*v(1)+u(2)*v(2)
8930       return
8931       end
8932
8933 C-----------------------------------------------------------------------------
8934
8935       subroutine transpose2(a,at)
8936       implicit none
8937       double precision a(2,2),at(2,2)
8938       at(1,1)=a(1,1)
8939       at(1,2)=a(2,1)
8940       at(2,1)=a(1,2)
8941       at(2,2)=a(2,2)
8942       return
8943       end
8944 c--------------------------------------------------------------------------
8945       subroutine transpose(n,a,at)
8946       implicit none
8947       integer n,i,j
8948       double precision a(n,n),at(n,n)
8949       do i=1,n
8950         do j=1,n
8951           at(j,i)=a(i,j)
8952         enddo
8953       enddo
8954       return
8955       end
8956 C---------------------------------------------------------------------------
8957       subroutine prodmat3(a1,a2,kk,transp,prod)
8958       implicit none
8959       integer i,j
8960       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8961       logical transp
8962 crc      double precision auxmat(2,2),prod_(2,2)
8963
8964       if (transp) then
8965 crc        call transpose2(kk(1,1),auxmat(1,1))
8966 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8967 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8968
8969            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8970      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8971            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8972      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8973            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8974      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8975            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8976      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8977
8978       else
8979 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8980 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8981
8982            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8983      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8984            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8985      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8986            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8987      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8988            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8989      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8990
8991       endif
8992 c      call transpose2(a2(1,1),a2t(1,1))
8993
8994 crc      print *,transp
8995 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8996 crc      print *,((prod(i,j),i=1,2),j=1,2)
8997
8998       return
8999       end
9000 C-----------------------------------------------------------------------------
9001       double precision function scalar(u,v)
9002       implicit none
9003       double precision u(3),v(3)
9004       double precision sc
9005       integer i
9006       sc=0.0d0
9007       do i=1,3
9008         sc=sc+u(i)*v(i)
9009       enddo
9010       scalar=sc
9011       return
9012       end
9013 C-----------------------------------------------------------------------
9014       double precision function sscale(r)
9015       double precision r,gamm
9016       include "COMMON.SPLITELE"
9017       if(r.lt.r_cut-rlamb) then
9018         sscale=1.0d0
9019       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9020         gamm=(r-(r_cut-rlamb))/rlamb
9021         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9022       else
9023         sscale=0d0
9024       endif
9025       return
9026       end
9027 C-----------------------------------------------------------------------
9028 C-----------------------------------------------------------------------
9029       double precision function sscagrad(r)
9030       double precision r,gamm
9031       include "COMMON.SPLITELE"
9032       if(r.lt.r_cut-rlamb) then
9033         sscagrad=0.0d0
9034       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9035         gamm=(r-(r_cut-rlamb))/rlamb
9036         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9037       else
9038         sscagrad=0.0d0
9039       endif
9040       return
9041       end
9042 C-----------------------------------------------------------------------
9043 C-----------------------------------------------------------------------
9044       double precision function sscalelip(r)
9045       double precision r,gamm
9046       include "COMMON.SPLITELE"
9047 C      if(r.lt.r_cut-rlamb) then
9048 C        sscale=1.0d0
9049 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9050 C        gamm=(r-(r_cut-rlamb))/rlamb
9051         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9052 C      else
9053 C        sscale=0d0
9054 C      endif
9055       return
9056       end
9057 C-----------------------------------------------------------------------
9058       double precision function sscagradlip(r)
9059       double precision r,gamm
9060       include "COMMON.SPLITELE"
9061 C     if(r.lt.r_cut-rlamb) then
9062 C        sscagrad=0.0d0
9063 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9064 C        gamm=(r-(r_cut-rlamb))/rlamb
9065         sscagradlip=r*(6*r-6.0d0)
9066 C      else
9067 C        sscagrad=0.0d0
9068 C      endif
9069       return
9070       end
9071
9072 C-----------------------------------------------------------------------
9073        subroutine set_shield_fac
9074       implicit real*8 (a-h,o-z)
9075       include 'DIMENSIONS'
9076       include 'COMMON.CHAIN'
9077       include 'COMMON.DERIV'
9078       include 'COMMON.IOUNITS'
9079       include 'COMMON.SHIELD'
9080       include 'COMMON.INTERACT'
9081 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9082       double precision div77_81/0.974996043d0/,
9083      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9084
9085 C the vector between center of side_chain and peptide group
9086        double precision pep_side(3),long,side_calf(3),
9087      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9088      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9089 C the line belowe needs to be changed for FGPROC>1
9090       do i=1,nres-1
9091       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9092       ishield_list(i)=0
9093 Cif there two consequtive dummy atoms there is no peptide group between them
9094 C the line below has to be changed for FGPROC>1
9095       VolumeTotal=0.0
9096       do k=1,nres
9097        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9098        dist_pep_side=0.0
9099        dist_side_calf=0.0
9100        do j=1,3
9101 C first lets set vector conecting the ithe side-chain with kth side-chain
9102       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9103 C      pep_side(j)=2.0d0
9104 C and vector conecting the side-chain with its proper calfa
9105       side_calf(j)=c(j,k+nres)-c(j,k)
9106 C      side_calf(j)=2.0d0
9107       pept_group(j)=c(j,i)-c(j,i+1)
9108 C lets have their lenght
9109       dist_pep_side=pep_side(j)**2+dist_pep_side
9110       dist_side_calf=dist_side_calf+side_calf(j)**2
9111       dist_pept_group=dist_pept_group+pept_group(j)**2
9112       enddo
9113        dist_pep_side=dsqrt(dist_pep_side)
9114        dist_pept_group=dsqrt(dist_pept_group)
9115        dist_side_calf=dsqrt(dist_side_calf)
9116       do j=1,3
9117         pep_side_norm(j)=pep_side(j)/dist_pep_side
9118         side_calf_norm(j)=dist_side_calf
9119       enddo
9120 C now sscale fraction
9121        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9122 C       print *,buff_shield,"buff"
9123 C now sscale
9124         if (sh_frac_dist.le.0.0) cycle
9125 C If we reach here it means that this side chain reaches the shielding sphere
9126 C Lets add him to the list for gradient
9127         ishield_list(i)=ishield_list(i)+1
9128 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9129 C this list is essential otherwise problem would be O3
9130         shield_list(ishield_list(i),i)=k
9131 C Lets have the sscale value
9132         if (sh_frac_dist.gt.1.0) then
9133          scale_fac_dist=1.0d0
9134          do j=1,3
9135          sh_frac_dist_grad(j)=0.0d0
9136          enddo
9137         else
9138          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9139      &                   *(2.0*sh_frac_dist-3.0d0)
9140          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9141      &                  /dist_pep_side/buff_shield*0.5
9142 C remember for the final gradient multiply sh_frac_dist_grad(j)
9143 C for side_chain by factor -2 !
9144          do j=1,3
9145          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9146 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9147 C     &                    sh_frac_dist_grad(j)
9148          enddo
9149         endif
9150 C        if ((i.eq.3).and.(k.eq.2)) then
9151 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9152 C     & ,"TU"
9153 C        endif
9154
9155 C this is what is now we have the distance scaling now volume...
9156       short=short_r_sidechain(itype(k))
9157       long=long_r_sidechain(itype(k))
9158       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9159 C now costhet_grad
9160 C       costhet=0.0d0
9161        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9162 C       costhet_fac=0.0d0
9163        do j=1,3
9164          costhet_grad(j)=costhet_fac*pep_side(j)
9165        enddo
9166 C remember for the final gradient multiply costhet_grad(j)
9167 C for side_chain by factor -2 !
9168 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9169 C pep_side0pept_group is vector multiplication
9170       pep_side0pept_group=0.0
9171       do j=1,3
9172       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9173       enddo
9174       cosalfa=(pep_side0pept_group/
9175      & (dist_pep_side*dist_side_calf))
9176       fac_alfa_sin=1.0-cosalfa**2
9177       fac_alfa_sin=dsqrt(fac_alfa_sin)
9178       rkprim=fac_alfa_sin*(long-short)+short
9179 C now costhet_grad
9180        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9181        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9182
9183        do j=1,3
9184          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9185      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9186      &*(long-short)/fac_alfa_sin*cosalfa/
9187      &((dist_pep_side*dist_side_calf))*
9188      &((side_calf(j))-cosalfa*
9189      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9190
9191         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9192      &*(long-short)/fac_alfa_sin*cosalfa
9193      &/((dist_pep_side*dist_side_calf))*
9194      &(pep_side(j)-
9195      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9196        enddo
9197
9198       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9199      &                    /VSolvSphere_div
9200      &                    *wshield
9201 C now the gradient...
9202 C grad_shield is gradient of Calfa for peptide groups
9203 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9204 C     &               costhet,cosphi
9205 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9206 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9207       do j=1,3
9208       grad_shield(j,i)=grad_shield(j,i)
9209 C gradient po skalowaniu
9210      &                +(sh_frac_dist_grad(j)
9211 C  gradient po costhet
9212      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9213      &-scale_fac_dist*(cosphi_grad_long(j))
9214      &/(1.0-cosphi) )*div77_81
9215      &*VofOverlap
9216 C grad_shield_side is Cbeta sidechain gradient
9217       grad_shield_side(j,ishield_list(i),i)=
9218      &        (sh_frac_dist_grad(j)*(-2.0d0)
9219      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9220      &       +scale_fac_dist*(cosphi_grad_long(j))
9221      &        *2.0d0/(1.0-cosphi))
9222      &        *div77_81*VofOverlap
9223
9224        grad_shield_loc(j,ishield_list(i),i)=
9225      &   scale_fac_dist*cosphi_grad_loc(j)
9226      &        *2.0d0/(1.0-cosphi)
9227      &        *div77_81*VofOverlap
9228       enddo
9229       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9230       enddo
9231       fac_shield(i)=VolumeTotal*div77_81+div4_81
9232 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9233       enddo
9234       return
9235       end
9236 C--------------------------------------------------------------------------
9237 C first for shielding is setting of function of side-chains
9238        subroutine set_shield_fac2
9239       implicit real*8 (a-h,o-z)
9240       include 'DIMENSIONS'
9241       include 'COMMON.CHAIN'
9242       include 'COMMON.DERIV'
9243       include 'COMMON.IOUNITS'
9244       include 'COMMON.SHIELD'
9245       include 'COMMON.INTERACT'
9246 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9247       double precision div77_81/0.974996043d0/,
9248      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9249
9250 C the vector between center of side_chain and peptide group
9251        double precision pep_side(3),long,side_calf(3),
9252      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9253      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9254 C the line belowe needs to be changed for FGPROC>1
9255       do i=1,nres-1
9256       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9257       ishield_list(i)=0
9258 Cif there two consequtive dummy atoms there is no peptide group between them
9259 C the line below has to be changed for FGPROC>1
9260       VolumeTotal=0.0
9261       do k=1,nres
9262        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9263        dist_pep_side=0.0
9264        dist_side_calf=0.0
9265        do j=1,3
9266 C first lets set vector conecting the ithe side-chain with kth side-chain
9267       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9268 C      pep_side(j)=2.0d0
9269 C and vector conecting the side-chain with its proper calfa
9270       side_calf(j)=c(j,k+nres)-c(j,k)
9271 C      side_calf(j)=2.0d0
9272       pept_group(j)=c(j,i)-c(j,i+1)
9273 C lets have their lenght
9274       dist_pep_side=pep_side(j)**2+dist_pep_side
9275       dist_side_calf=dist_side_calf+side_calf(j)**2
9276       dist_pept_group=dist_pept_group+pept_group(j)**2
9277       enddo
9278        dist_pep_side=dsqrt(dist_pep_side)
9279        dist_pept_group=dsqrt(dist_pept_group)
9280        dist_side_calf=dsqrt(dist_side_calf)
9281       do j=1,3
9282         pep_side_norm(j)=pep_side(j)/dist_pep_side
9283         side_calf_norm(j)=dist_side_calf
9284       enddo
9285 C now sscale fraction
9286        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9287 C       print *,buff_shield,"buff"
9288 C now sscale
9289         if (sh_frac_dist.le.0.0) cycle
9290 C If we reach here it means that this side chain reaches the shielding sphere
9291 C Lets add him to the list for gradient
9292         ishield_list(i)=ishield_list(i)+1
9293 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9294 C this list is essential otherwise problem would be O3
9295         shield_list(ishield_list(i),i)=k
9296 C Lets have the sscale value
9297         if (sh_frac_dist.gt.1.0) then
9298          scale_fac_dist=1.0d0
9299          do j=1,3
9300          sh_frac_dist_grad(j)=0.0d0
9301          enddo
9302         else
9303          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9304      &                   *(2.0d0*sh_frac_dist-3.0d0)
9305          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9306      &                  /dist_pep_side/buff_shield*0.5d0
9307 C remember for the final gradient multiply sh_frac_dist_grad(j)
9308 C for side_chain by factor -2 !
9309          do j=1,3
9310          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9311 C         sh_frac_dist_grad(j)=0.0d0
9312 C         scale_fac_dist=1.0d0
9313 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9314 C     &                    sh_frac_dist_grad(j)
9315          enddo
9316         endif
9317 C this is what is now we have the distance scaling now volume...
9318       short=short_r_sidechain(itype(k))
9319       long=long_r_sidechain(itype(k))
9320       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9321       sinthet=short/dist_pep_side*costhet
9322 C now costhet_grad
9323 C       costhet=0.6d0
9324 C       sinthet=0.8
9325        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9326 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9327 C     &             -short/dist_pep_side**2/costhet)
9328 C       costhet_fac=0.0d0
9329        do j=1,3
9330          costhet_grad(j)=costhet_fac*pep_side(j)
9331        enddo
9332 C remember for the final gradient multiply costhet_grad(j)
9333 C for side_chain by factor -2 !
9334 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9335 C pep_side0pept_group is vector multiplication
9336       pep_side0pept_group=0.0d0
9337       do j=1,3
9338       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9339       enddo
9340       cosalfa=(pep_side0pept_group/
9341      & (dist_pep_side*dist_side_calf))
9342       fac_alfa_sin=1.0d0-cosalfa**2
9343       fac_alfa_sin=dsqrt(fac_alfa_sin)
9344       rkprim=fac_alfa_sin*(long-short)+short
9345 C      rkprim=short
9346
9347 C now costhet_grad
9348        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9349 C       cosphi=0.6
9350        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9351        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9352      &      dist_pep_side**2)
9353 C       sinphi=0.8
9354        do j=1,3
9355          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9356      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9357      &*(long-short)/fac_alfa_sin*cosalfa/
9358      &((dist_pep_side*dist_side_calf))*
9359      &((side_calf(j))-cosalfa*
9360      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9361 C       cosphi_grad_long(j)=0.0d0
9362         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9363      &*(long-short)/fac_alfa_sin*cosalfa
9364      &/((dist_pep_side*dist_side_calf))*
9365      &(pep_side(j)-
9366      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9367 C       cosphi_grad_loc(j)=0.0d0
9368        enddo
9369 C      print *,sinphi,sinthet
9370       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9371      &                    /VSolvSphere_div
9372 C     &                    *wshield
9373 C now the gradient...
9374       do j=1,3
9375       grad_shield(j,i)=grad_shield(j,i)
9376 C gradient po skalowaniu
9377      &                +(sh_frac_dist_grad(j)*VofOverlap
9378 C  gradient po costhet
9379      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9380      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9381      &       sinphi/sinthet*costhet*costhet_grad(j)
9382      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9383      & )*wshield
9384 C grad_shield_side is Cbeta sidechain gradient
9385       grad_shield_side(j,ishield_list(i),i)=
9386      &        (sh_frac_dist_grad(j)*(-2.0d0)
9387      &        *VofOverlap
9388      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9389      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9390      &       sinphi/sinthet*costhet*costhet_grad(j)
9391      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9392      &       )*wshield
9393
9394        grad_shield_loc(j,ishield_list(i),i)=
9395      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9396      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9397      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9398      &        ))
9399      &        *wshield
9400       enddo
9401       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9402       enddo
9403       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9404 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9405 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9406       enddo
9407       return
9408       end
9409 C--------------------------------------------------------------------------
9410       double precision function tschebyshev(m,n,x,y)
9411       implicit none
9412       include "DIMENSIONS"
9413       integer i,m,n
9414       double precision x(n),y,yy(0:maxvar),aux
9415 c Tschebyshev polynomial. Note that the first term is omitted
9416 c m=0: the constant term is included
9417 c m=1: the constant term is not included
9418       yy(0)=1.0d0
9419       yy(1)=y
9420       do i=2,n
9421         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9422       enddo
9423       aux=0.0d0
9424       do i=m,n
9425         aux=aux+x(i)*yy(i)
9426       enddo
9427       tschebyshev=aux
9428       return
9429       end
9430 C--------------------------------------------------------------------------
9431       double precision function gradtschebyshev(m,n,x,y)
9432       implicit none
9433       include "DIMENSIONS"
9434       integer i,m,n
9435       double precision x(n+1),y,yy(0:maxvar),aux
9436 c Tschebyshev polynomial. Note that the first term is omitted
9437 c m=0: the constant term is included
9438 c m=1: the constant term is not included
9439       yy(0)=1.0d0
9440       yy(1)=2.0d0*y
9441       do i=2,n
9442         yy(i)=2*y*yy(i-1)-yy(i-2)
9443       enddo
9444       aux=0.0d0
9445       do i=m,n
9446         aux=aux+x(i+1)*yy(i)*(i+1)
9447 C        print *, x(i+1),yy(i),i
9448       enddo
9449       gradtschebyshev=aux
9450       return
9451       end
9452 c----------------------------------------------------------------------------
9453       double precision function sscale2(r,r_cut,r0,rlamb)
9454       implicit none
9455       double precision r,gamm,r_cut,r0,rlamb,rr
9456       rr = dabs(r-r0)
9457 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9458 c      write (2,*) "rr",rr
9459       if(rr.lt.r_cut-rlamb) then
9460         sscale2=1.0d0
9461       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9462         gamm=(rr-(r_cut-rlamb))/rlamb
9463         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9464       else
9465         sscale2=0d0
9466       endif
9467       return
9468       end
9469 C-----------------------------------------------------------------------
9470       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9471       implicit none
9472       double precision r,gamm,r_cut,r0,rlamb,rr
9473       rr = dabs(r-r0)
9474       if(rr.lt.r_cut-rlamb) then
9475         sscalgrad2=0.0d0
9476       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9477         gamm=(rr-(r_cut-rlamb))/rlamb
9478         if (r.ge.r0) then
9479           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9480         else
9481           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9482         endif
9483       else
9484         sscalgrad2=0.0d0
9485       endif
9486       return
9487       end
9488 c----------------------------------------------------------------------------
9489       subroutine e_saxs(Esaxs_constr)
9490       implicit none
9491       include 'DIMENSIONS'
9492 #ifdef MPI
9493       include "mpif.h"
9494       include "COMMON.SETUP"
9495       integer IERR
9496 #endif
9497       include 'COMMON.SBRIDGE'
9498       include 'COMMON.CHAIN'
9499       include 'COMMON.GEO'
9500       include 'COMMON.LOCAL'
9501       include 'COMMON.INTERACT'
9502       include 'COMMON.VAR'
9503       include 'COMMON.IOUNITS'
9504       include 'COMMON.DERIV'
9505       include 'COMMON.CONTROL'
9506       include 'COMMON.NAMES'
9507       include 'COMMON.FFIELD'
9508       include 'COMMON.LANGEVIN'
9509 c
9510       double precision Esaxs_constr
9511       integer i,iint,j,k,l
9512       double precision PgradC(maxSAXS,3,maxres),
9513      &  PgradX(maxSAXS,3,maxres)
9514 #ifdef MPI
9515       double precision PgradC_(maxSAXS,3,maxres),
9516      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9517 #endif
9518       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9519      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9520      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9521      & auxX,auxX1,CACAgrad,Cnorm
9522       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9523       double precision dist
9524       external dist
9525 c  SAXS restraint penalty function
9526 #ifdef DEBUG
9527       write(iout,*) "------- SAXS penalty function start -------"
9528       write (iout,*) "nsaxs",nsaxs
9529       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9530       write (iout,*) "Psaxs"
9531       do i=1,nsaxs
9532         write (iout,'(i5,e15.5)') i, Psaxs(i)
9533       enddo
9534 #endif
9535       Esaxs_constr = 0.0d0
9536       do k=1,nsaxs
9537         Pcalc(k)=0.0d0
9538         do j=1,nres
9539           do l=1,3
9540             PgradC(k,l,j)=0.0d0
9541             PgradX(k,l,j)=0.0d0
9542           enddo
9543         enddo
9544       enddo
9545       do i=iatsc_s,iatsc_e
9546        if (itype(i).eq.ntyp1) cycle
9547        do iint=1,nint_gr(i)
9548          do j=istart(i,iint),iend(i,iint)
9549            if (itype(j).eq.ntyp1) cycle
9550 #ifdef ALLSAXS
9551            dijCACA=dist(i,j)
9552            dijCASC=dist(i,j+nres)
9553            dijSCCA=dist(i+nres,j)
9554            dijSCSC=dist(i+nres,j+nres)
9555            sigma2CACA=2.0d0/(pstok**2)
9556            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9557            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9558            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9559            do k=1,nsaxs
9560              dk = distsaxs(k)
9561              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9562              if (itype(j).ne.10) then
9563              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9564              else
9565              endif
9566              expCASC = 0.0d0
9567              if (itype(i).ne.10) then
9568              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9569              else
9570              expSCCA = 0.0d0
9571              endif
9572              if (itype(i).ne.10 .and. itype(j).ne.10) then
9573              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9574              else
9575              expSCSC = 0.0d0
9576              endif
9577              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9578 #ifdef DEBUG
9579              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9580 #endif
9581              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9582              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9583              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9584              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9585              do l=1,3
9586 c CA CA
9587                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9588                PgradC(k,l,i) = PgradC(k,l,i)-aux
9589                PgradC(k,l,j) = PgradC(k,l,j)+aux
9590 c CA SC
9591                if (itype(j).ne.10) then
9592                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9593                PgradC(k,l,i) = PgradC(k,l,i)-aux
9594                PgradC(k,l,j) = PgradC(k,l,j)+aux
9595                PgradX(k,l,j) = PgradX(k,l,j)+aux
9596                endif
9597 c SC CA
9598                if (itype(i).ne.10) then
9599                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9600                PgradX(k,l,i) = PgradX(k,l,i)-aux
9601                PgradC(k,l,i) = PgradC(k,l,i)-aux
9602                PgradC(k,l,j) = PgradC(k,l,j)+aux
9603                endif
9604 c SC SC
9605                if (itype(i).ne.10 .and. itype(j).ne.10) then
9606                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9607                PgradC(k,l,i) = PgradC(k,l,i)-aux
9608                PgradC(k,l,j) = PgradC(k,l,j)+aux
9609                PgradX(k,l,i) = PgradX(k,l,i)-aux
9610                PgradX(k,l,j) = PgradX(k,l,j)+aux
9611                endif
9612              enddo ! l
9613            enddo ! k
9614 #else
9615            dijCACA=dist(i,j)
9616            sigma2CACA=scal_rad**2*0.25d0/
9617      &        (restok(itype(j))**2+restok(itype(i))**2)
9618
9619            IF (saxs_cutoff.eq.0) THEN
9620            do k=1,nsaxs
9621              dk = distsaxs(k)
9622              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9623              Pcalc(k) = Pcalc(k)+expCACA
9624              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9625              do l=1,3
9626                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9627                PgradC(k,l,i) = PgradC(k,l,i)-aux
9628                PgradC(k,l,j) = PgradC(k,l,j)+aux
9629              enddo ! l
9630            enddo ! k
9631            ELSE
9632            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9633            do k=1,nsaxs
9634              dk = distsaxs(k)
9635 c             write (2,*) "ijk",i,j,k
9636              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9637              if (sss2.eq.0.0d0) cycle
9638              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9639              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9640              Pcalc(k) = Pcalc(k)+expCACA
9641 #ifdef DEBUG
9642              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9643 #endif
9644              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9645      &             ssgrad2*expCACA/sss2
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              enddo ! l
9652            enddo ! k
9653            ENDIF
9654 #endif
9655          enddo ! j
9656        enddo ! iint
9657       enddo ! i
9658 #ifdef MPI
9659       if (nfgtasks.gt.1) then
9660         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9661      &    MPI_SUM,king,FG_COMM,IERR)
9662         if (fg_rank.eq.king) then
9663           do k=1,nsaxs
9664             Pcalc(k) = Pcalc_(k)
9665           enddo
9666         endif
9667         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9668      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9669         if (fg_rank.eq.king) then
9670           do i=1,nres
9671             do l=1,3
9672               do k=1,nsaxs
9673                 PgradC(k,l,i) = PgradC_(k,l,i)
9674               enddo
9675             enddo
9676           enddo
9677         endif
9678 #ifdef ALLSAXS
9679         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9680      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9681         if (fg_rank.eq.king) then
9682           do i=1,nres
9683             do l=1,3
9684               do k=1,nsaxs
9685                 PgradX(k,l,i) = PgradX_(k,l,i)
9686               enddo
9687             enddo
9688           enddo
9689         endif
9690 #endif
9691       endif
9692 #endif
9693 #ifdef MPI
9694       if (fg_rank.eq.king) then
9695 #endif
9696       Cnorm = 0.0d0
9697       do k=1,nsaxs
9698         Cnorm = Cnorm + Pcalc(k)
9699       enddo
9700       Esaxs_constr = dlog(Cnorm)-wsaxs0
9701       do k=1,nsaxs
9702         if (Pcalc(k).gt.0.0d0)
9703      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9704 #ifdef DEBUG
9705         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9706 #endif
9707       enddo
9708 #ifdef DEBUG
9709       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9710 #endif
9711       do i=nnt,nct
9712         do l=1,3
9713           auxC=0.0d0
9714           auxC1=0.0d0
9715           auxX=0.0d0
9716           auxX1=0.d0
9717           do k=1,nsaxs
9718             if (Pcalc(k).gt.0)
9719      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9720             auxC1 = auxC1+PgradC(k,l,i)
9721 #ifdef ALLSAXS
9722             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9723             auxX1 = auxX1+PgradX(k,l,i)
9724 #endif
9725           enddo
9726           gsaxsC(l,i) = auxC - auxC1/Cnorm
9727 #ifdef ALLSAXS
9728           gsaxsX(l,i) = auxX - auxX1/Cnorm
9729 #endif
9730 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9731 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9732         enddo
9733       enddo
9734 #ifdef MPI
9735       endif
9736 #endif
9737       return
9738       end
9739 c----------------------------------------------------------------------------
9740       subroutine e_saxsC(Esaxs_constr)
9741       implicit none
9742       include 'DIMENSIONS'
9743 #ifdef MPI
9744       include "mpif.h"
9745       include "COMMON.SETUP"
9746       integer IERR
9747 #endif
9748       include 'COMMON.SBRIDGE'
9749       include 'COMMON.CHAIN'
9750       include 'COMMON.GEO'
9751       include 'COMMON.LOCAL'
9752       include 'COMMON.INTERACT'
9753       include 'COMMON.VAR'
9754       include 'COMMON.IOUNITS'
9755       include 'COMMON.DERIV'
9756       include 'COMMON.CONTROL'
9757       include 'COMMON.NAMES'
9758       include 'COMMON.FFIELD'
9759       include 'COMMON.LANGEVIN'
9760 c
9761       double precision Esaxs_constr
9762       integer i,iint,j,k,l
9763       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9764 #ifdef MPI
9765       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9766 #endif
9767       double precision dk,dijCASPH,dijSCSPH,
9768      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9769      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9770      & auxX,auxX1,Cnorm
9771 c  SAXS restraint penalty function
9772 #ifdef DEBUG
9773       write(iout,*) "------- SAXS penalty function start -------"
9774       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9775      & " isaxs_end",isaxs_end
9776       write (iout,*) "nnt",nnt," ntc",nct
9777       do i=nnt,nct
9778         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9779      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9780       enddo
9781       do i=nnt,nct
9782         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9783       enddo
9784 #endif
9785       Esaxs_constr = 0.0d0
9786       logPtot=0.0d0
9787       do j=isaxs_start,isaxs_end
9788         Pcalc_=0.0d0
9789         do i=1,nres
9790           do l=1,3
9791             PgradC(l,i)=0.0d0
9792             PgradX(l,i)=0.0d0
9793           enddo
9794         enddo
9795         do i=nnt,nct
9796           dijCASPH=0.0d0
9797           dijSCSPH=0.0d0
9798           do l=1,3
9799             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9800           enddo
9801           if (itype(i).ne.10) then
9802           do l=1,3
9803             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9804           enddo
9805           endif
9806           sigma2CA=2.0d0/pstok**2
9807           sigma2SC=4.0d0/restok(itype(i))**2
9808           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9809           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9810           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9811 #ifdef DEBUG
9812           write(*,*) "processor i j Pcalc",
9813      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9814 #endif
9815           CASPHgrad = sigma2CA*expCASPH
9816           SCSPHgrad = sigma2SC*expSCSPH
9817           do l=1,3
9818             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9819             PgradX(l,i) = PgradX(l,i) + aux
9820             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9821           enddo ! l
9822         enddo ! i
9823         do i=nnt,nct
9824           do l=1,3
9825             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9826             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9827           enddo
9828         enddo
9829         logPtot = logPtot - dlog(Pcalc_)
9830 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9831 c     &    " logPtot",logPtot
9832       enddo ! j
9833 #ifdef MPI
9834       if (nfgtasks.gt.1) then
9835 c        write (iout,*) "logPtot before reduction",logPtot
9836         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9837      &    MPI_SUM,king,FG_COMM,IERR)
9838         logPtot = logPtot_
9839 c        write (iout,*) "logPtot after reduction",logPtot
9840         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9841      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9842         if (fg_rank.eq.king) then
9843           do i=1,nres
9844             do l=1,3
9845               gsaxsC(l,i) = gsaxsC_(l,i)
9846             enddo
9847           enddo
9848         endif
9849         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9850      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9851         if (fg_rank.eq.king) then
9852           do i=1,nres
9853             do l=1,3
9854               gsaxsX(l,i) = gsaxsX_(l,i)
9855             enddo
9856           enddo
9857         endif
9858       endif
9859 #endif
9860       Esaxs_constr = logPtot
9861       return
9862       end