source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C      write(iout,*) 'po elektostatyce'
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 continue
  51       call vec_and_deriv
  52       if (shield_mode.eq.1) then
  53        call set_shield_fac
  54       else if  (shield_mode.eq.2) then
  55        call set_shield_fac2
  56       endif
  57       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  58 C            write(iout,*) 'po eelec'
  59
  60 C Calculate excluded-volume interaction energy between peptide groups
  61 C and side chains.
  62 C
  63       call escp(evdw2,evdw2_14)
  64 c
  65 c Calculate the bond-stretching energy
  66 c
  67
  68       call ebond(estr)
  69 C       write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79 C      print *,'Bend energy finished.'
  80       if (wang.gt.0d0) then
  81        if (tor_mode.eq.0) then
  82          call ebend(ebe)
  83        else
  84 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  85 C energy function
  86          call ebend_kcc(ebe)
  87        endif
  88       else
  89         ebe=0.0d0
  90       endif
  91       ethetacnstr=0.0d0
  92       if (with_theta_constr) call etheta_constr(ethetacnstr)
  93 c      call ebend(ebe,ethetacnstr)
  94 cd    print *,'Bend energy finished.'
  95 C
  96 C Calculate the SC local energy.
  97 C
  98       call esc(escloc)
  99 C       print *,'SCLOC energy finished.'
 100 C
 101 C Calculate the virtual-bond torsional energy.
 102 C
 103       if (wtor.gt.0.0d0) then
 104          if (tor_mode.eq.0) then
 105            call etor(etors,fact(1))
 106          else
 107 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 108 C energy function
 109            call etor_kcc(etors,fact(1))
 110          endif
 111       else
 112         etors=0.0d0
 113       endif
 114       edihcnstr=0.0d0
 115       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 116 c      print *,"Processor",myrank," computed Utor"
 117 C
 118 C 6/23/01 Calculate double-torsional energy
 119 C
 120       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 121         call etor_d(etors_d,fact(2))
 122       else
 123         etors_d=0
 124       endif
 125 c      print *,"Processor",myrank," computed Utord"
 126 C
 127       call eback_sc_corr(esccor)
 128
 129       if (wliptran.gt.0) then
 130         call Eliptransfer(eliptran)
 131       endif
 132
 133 C
 134 C 12/1/95 Multi-body terms
 135 C
 136       n_corr=0
 137       n_corr1=0
 138       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 139      &    .or. wturn6.gt.0.0d0) then
 140 c         write(iout,*)"calling multibody_eello"
 141          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 142 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 143 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 144       else
 145          ecorr=0.0d0
 146          ecorr5=0.0d0
 147          ecorr6=0.0d0
 148          eturn6=0.0d0
 149       endif
 150       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 151 c         write (iout,*) "Calling multibody_hbond"
 152          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 153       endif
 154 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 155 #ifdef SPLITELE
 156       if (shield_mode.gt.0) then
 157       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 158      & +welec*fact(1)*ees
 159      & +fact(1)*wvdwpp*evdw1
 160      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 161      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 162      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 163      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 164      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 165      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 166      & +wliptran*eliptran
 167       else
 168       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 169      & +wvdwpp*evdw1
 170      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 171      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 172      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 173      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 174      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 175      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 176      & +wliptran*eliptran
 177       endif
 178 #else
 179       if (shield_mode.gt.0) then
 180       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 181      & +welec*fact(1)*(ees+evdw1)
 182      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 183      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 184      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 185      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 186      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 187      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 188      & +wliptran*eliptran
 189       else
 190       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 191      & +welec*fact(1)*(ees+evdw1)
 192      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 193      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 194      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 195      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 196      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 197      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 198      & +wliptran*eliptran
 199       endif
 200 #endif
 201       energia(0)=etot
 202       energia(1)=evdw
 203 #ifdef SCP14
 204       energia(2)=evdw2-evdw2_14
 205       energia(17)=evdw2_14
 206 #else
 207       energia(2)=evdw2
 208       energia(17)=0.0d0
 209 #endif
 210 #ifdef SPLITELE
 211       energia(3)=ees
 212       energia(16)=evdw1
 213 #else
 214       energia(3)=ees+evdw1
 215       energia(16)=0.0d0
 216 #endif
 217       energia(4)=ecorr
 218       energia(5)=ecorr5
 219       energia(6)=ecorr6
 220       energia(7)=eel_loc
 221       energia(8)=eello_turn3
 222       energia(9)=eello_turn4
 223       energia(10)=eturn6
 224       energia(11)=ebe
 225       energia(12)=escloc
 226       energia(13)=etors
 227       energia(14)=etors_d
 228       energia(15)=ehpb
 229       energia(18)=estr
 230       energia(19)=esccor
 231       energia(20)=edihcnstr
 232       energia(21)=evdw_t
 233       energia(24)=ethetacnstr
 234       energia(22)=eliptran
 235 c detecting NaNQ
 236 #ifdef ISNAN
 237 #ifdef AIX
 238       if (isnan(etot).ne.0) energia(0)=1.0d+99
 239 #else
 240       if (isnan(etot)) energia(0)=1.0d+99
 241 #endif
 242 #else
 243       i=0
 244 #ifdef WINPGI
 245       idumm=proc_proc(etot,i)
 246 #else
 247       call proc_proc(etot,i)
 248 #endif
 249       if(i.eq.1)energia(0)=1.0d+99
 250 #endif
 251 #ifdef MPL
 252 c     endif
 253 #endif
 254 #ifdef DEBUG
 255       call enerprint(energia,fact)
 256 #endif
 257       if (calc_grad) then
 258 C
 259 C Sum up the components of the Cartesian gradient.
 260 C
 261 #ifdef SPLITELE
 262       do i=1,nct
 263         do j=1,3
 264       if (shield_mode.eq.0) then
 265           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 266      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 267      &                wbond*gradb(j,i)+
 268      &                wstrain*ghpbc(j,i)+
 269      &                wcorr*fact(3)*gradcorr(j,i)+
 270      &                wel_loc*fact(2)*gel_loc(j,i)+
 271      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 272      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 273      &                wcorr5*fact(4)*gradcorr5(j,i)+
 274      &                wcorr6*fact(5)*gradcorr6(j,i)+
 275      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 276      &                wsccor*fact(2)*gsccorc(j,i)
 277      &               +wliptran*gliptranc(j,i)
 278           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 279      &                  wbond*gradbx(j,i)+
 280      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 281      &                  wsccor*fact(2)*gsccorx(j,i)
 282      &                 +wliptran*gliptranx(j,i)
 283         else
 284           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 285      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 286      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 287      &                wbond*gradb(j,i)+
 288      &                wstrain*ghpbc(j,i)+
 289      &                wcorr*fact(3)*gradcorr(j,i)+
 290      &                wel_loc*fact(2)*gel_loc(j,i)+
 291      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 292      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 293      &                wcorr5*fact(4)*gradcorr5(j,i)+
 294      &                wcorr6*fact(5)*gradcorr6(j,i)+
 295      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 296      &                wsccor*fact(2)*gsccorc(j,i)
 297      &               +wliptran*gliptranc(j,i)
 298      &                 +welec*gshieldc(j,i)
 299      &                 +welec*gshieldc_loc(j,i)
 300      &                 +wcorr*gshieldc_ec(j,i)
 301      &                 +wcorr*gshieldc_loc_ec(j,i)
 302      &                 +wturn3*gshieldc_t3(j,i)
 303      &                 +wturn3*gshieldc_loc_t3(j,i)
 304      &                 +wturn4*gshieldc_t4(j,i)
 305      &                 +wturn4*gshieldc_loc_t4(j,i)
 306      &                 +wel_loc*gshieldc_ll(j,i)
 307      &                 +wel_loc*gshieldc_loc_ll(j,i)
 308
 309           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 310      &                 +fact(1)*wscp*gradx_scp(j,i)+
 311      &                  wbond*gradbx(j,i)+
 312      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 313      &                  wsccor*fact(2)*gsccorx(j,i)
 314      &                 +wliptran*gliptranx(j,i)
 315      &                 +welec*gshieldx(j,i)
 316      &                 +wcorr*gshieldx_ec(j,i)
 317      &                 +wturn3*gshieldx_t3(j,i)
 318      &                 +wturn4*gshieldx_t4(j,i)
 319      &                 +wel_loc*gshieldx_ll(j,i)
 320
 321
 322         endif
 323         enddo
 324 #else
 325       do i=1,nct
 326         do j=1,3
 327                 if (shield_mode.eq.0) then
 328           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 329      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 330      &                wbond*gradb(j,i)+
 331      &                wcorr*fact(3)*gradcorr(j,i)+
 332      &                wel_loc*fact(2)*gel_loc(j,i)+
 333      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 334      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 335      &                wcorr5*fact(4)*gradcorr5(j,i)+
 336      &                wcorr6*fact(5)*gradcorr6(j,i)+
 337      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 338      &                wsccor*fact(2)*gsccorc(j,i)
 339      &               +wliptran*gliptranc(j,i)
 340           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 341      &                  wbond*gradbx(j,i)+
 342      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 343      &                  wsccor*fact(1)*gsccorx(j,i)
 344      &                 +wliptran*gliptranx(j,i)
 345               else
 346           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 347      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 348      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 349      &                wbond*gradb(j,i)+
 350      &                wcorr*fact(3)*gradcorr(j,i)+
 351      &                wel_loc*fact(2)*gel_loc(j,i)+
 352      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 353      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 354      &                wcorr5*fact(4)*gradcorr5(j,i)+
 355      &                wcorr6*fact(5)*gradcorr6(j,i)+
 356      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 357      &                wsccor*fact(2)*gsccorc(j,i)
 358      &               +wliptran*gliptranc(j,i)
 359      &                 +welec*gshieldc(j,i)
 360      &                 +welec*gshieldc_loc(j,i)
 361      &                 +wcorr*gshieldc_ec(j,i)
 362      &                 +wcorr*gshieldc_loc_ec(j,i)
 363      &                 +wturn3*gshieldc_t3(j,i)
 364      &                 +wturn3*gshieldc_loc_t3(j,i)
 365      &                 +wturn4*gshieldc_t4(j,i)
 366      &                 +wturn4*gshieldc_loc_t4(j,i)
 367      &                 +wel_loc*gshieldc_ll(j,i)
 368      &                 +wel_loc*gshieldc_loc_ll(j,i)
 369
 370           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 371      &                  fact(1)*wscp*gradx_scp(j,i)+
 372      &                  wbond*gradbx(j,i)+
 373      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 374      &                  wsccor*fact(1)*gsccorx(j,i)
 375      &                 +wliptran*gliptranx(j,i)
 376      &                 +welec*gshieldx(j,i)
 377      &                 +wcorr*gshieldx_ec(j,i)
 378      &                 +wturn3*gshieldx_t3(j,i)
 379      &                 +wturn4*gshieldx_t4(j,i)
 380      &                 +wel_loc*gshieldx_ll(j,i)
 381
 382          endif
 383         enddo
 384 #endif
 385       enddo
 386
 387
 388       do i=1,nres-3
 389         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 390      &   +wcorr5*fact(4)*g_corr5_loc(i)
 391      &   +wcorr6*fact(5)*g_corr6_loc(i)
 392      &   +wturn4*fact(3)*gel_loc_turn4(i)
 393      &   +wturn3*fact(2)*gel_loc_turn3(i)
 394      &   +wturn6*fact(5)*gel_loc_turn6(i)
 395      &   +wel_loc*fact(2)*gel_loc_loc(i)
 396 c     &   +wsccor*fact(1)*gsccor_loc(i)
 397 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 398       enddo
 399       endif
 400       if (dyn_ss) call dyn_set_nss
 401       return
 402       end
 403 C------------------------------------------------------------------------
 404       subroutine enerprint(energia,fact)
 405       implicit real*8 (a-h,o-z)
 406       include 'DIMENSIONS'
 407       include 'DIMENSIONS.ZSCOPT'
 408       include 'COMMON.IOUNITS'
 409       include 'COMMON.FFIELD'
 410       include 'COMMON.SBRIDGE'
 411       include 'COMMON.CONTROL'
 412       double precision energia(0:max_ene),fact(6)
 413       etot=energia(0)
 414       evdw=energia(1)+fact(6)*energia(21)
 415 #ifdef SCP14
 416       evdw2=energia(2)+energia(17)
 417 #else
 418       evdw2=energia(2)
 419 #endif
 420       ees=energia(3)
 421 #ifdef SPLITELE
 422       evdw1=energia(16)
 423 #endif
 424       ecorr=energia(4)
 425       ecorr5=energia(5)
 426       ecorr6=energia(6)
 427       eel_loc=energia(7)
 428       eello_turn3=energia(8)
 429       eello_turn4=energia(9)
 430       eello_turn6=energia(10)
 431       ebe=energia(11)
 432       escloc=energia(12)
 433       etors=energia(13)
 434       etors_d=energia(14)
 435       ehpb=energia(15)
 436       esccor=energia(19)
 437       edihcnstr=energia(20)
 438       estr=energia(18)
 439       ethetacnstr=energia(24)
 440       eliptran=energia(22)
 441 #ifdef SPLITELE
 442       if (shield_mode.gt.0) then
 443       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(1),ees,
 444      &  welec*fact(1),evdw1,wvdwpp*fact(1),
 445      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 446      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 447      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 448      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 449      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 450      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 451      & eliptran,wliptran,etot
 452       else
 453       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 454      &  wvdwpp,
 455      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 456      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 457      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 458      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 459      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 460      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 461      & eliptran,wliptran,etot
 462       endif
 463    10 format (/'Virtual-chain energies:'//
 464      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 465      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 466      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 467      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 468      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 469      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 470      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 471      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 472      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 473      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 474      & ' (SS bridges & dist. cnstr.)'/
 475      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 476      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 477      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 478      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 479      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 480      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 481      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 482      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 483      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 484      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 485      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 486      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 487      & 'ETOT=  ',1pE16.6,' (total)')
 488 #else
 489       if (shield_mode.gt.0) then
 490       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(2),ees,
 491      &  welec*fact(1),estr,wbond,
 492      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 493      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 494      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 495      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 496      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 497      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 498       else
 499       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 500      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 501      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 502      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 503      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 504      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 505      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 506       endif
 507    10 format (/'Virtual-chain energies:'//
 508      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 509      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 510      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 511      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 512      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 513      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 514      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 515      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 516      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 517      & ' (SS bridges & dist. cnstr.)'/
 518      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 519      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 520      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 521      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 522      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 523      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 524      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 525      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 526      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 527      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 528      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 529      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 530      & 'ETOT=  ',1pE16.6,' (total)')
 531 #endif
 532       return
 533       end
 534 C-----------------------------------------------------------------------
 535       subroutine elj(evdw,evdw_t)
 536 C
 537 C This subroutine calculates the interaction energy of nonbonded side chains
 538 C assuming the LJ potential of interaction.
 539 C
 540       implicit real*8 (a-h,o-z)
 541       include 'DIMENSIONS'
 542       include 'DIMENSIONS.ZSCOPT'
 543       include "DIMENSIONS.COMPAR"
 544       parameter (accur=1.0d-10)
 545       include 'COMMON.GEO'
 546       include 'COMMON.VAR'
 547       include 'COMMON.LOCAL'
 548       include 'COMMON.CHAIN'
 549       include 'COMMON.DERIV'
 550       include 'COMMON.INTERACT'
 551       include 'COMMON.TORSION'
 552       include 'COMMON.ENEPS'
 553       include 'COMMON.SBRIDGE'
 554       include 'COMMON.NAMES'
 555       include 'COMMON.IOUNITS'
 556       include 'COMMON.CONTACTS'
 557       dimension gg(3)
 558       integer icant
 559       external icant
 560 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 561 c ROZNICA z cluster
 562       do i=1,210
 563         do j=1,2
 564           eneps_temp(j,i)=0.0d0
 565         enddo
 566       enddo
 567 cROZNICA
 568
 569       evdw=0.0D0
 570       evdw_t=0.0d0
 571       do i=iatsc_s,iatsc_e
 572         itypi=iabs(itype(i))
 573         if (itypi.eq.ntyp1) cycle
 574         itypi1=iabs(itype(i+1))
 575         xi=c(1,nres+i)
 576         yi=c(2,nres+i)
 577         zi=c(3,nres+i)
 578 C Change 12/1/95
 579         num_conti=0
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 585 cd   &                  'iend=',iend(i,iint)
 586           do j=istart(i,iint),iend(i,iint)
 587             itypj=iabs(itype(j))
 588             if (itypj.eq.ntyp1) cycle
 589             xj=c(1,nres+j)-xi
 590             yj=c(2,nres+j)-yi
 591             zj=c(3,nres+j)-zi
 592 C Change 12/1/95 to calculate four-body interactions
 593             rij=xj*xj+yj*yj+zj*zj
 594             rrij=1.0D0/rij
 595 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 596             eps0ij=eps(itypi,itypj)
 597             fac=rrij**expon2
 598             e1=fac*fac*aa
 599             e2=fac*bb
 600             evdwij=e1+e2
 601             ij=icant(itypi,itypj)
 602 c ROZNICA z cluster
 603             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 604             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 605 c
 606
 607 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 608 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 609 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 610 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 611 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 612 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 613             if (bb.gt.0.0d0) then
 614               evdw=evdw+evdwij
 615             else
 616               evdw_t=evdw_t+evdwij
 617             endif
 618             if (calc_grad) then
 619 C
 620 C Calculate the components of the gradient in DC and X
 621 C
 622             fac=-rrij*(e1+evdwij)
 623             gg(1)=xj*fac
 624             gg(2)=yj*fac
 625             gg(3)=zj*fac
 626             do k=1,3
 627               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 628               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 629             enddo
 630             do k=i,j-1
 631               do l=1,3
 632                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 633               enddo
 634             enddo
 635             endif
 636 C
 637 C 12/1/95, revised on 5/20/97
 638 C
 639 C Calculate the contact function. The ith column of the array JCONT will
 640 C contain the numbers of atoms that make contacts with the atom I (of numbers
 641 C greater than I). The arrays FACONT and GACONT will contain the values of
 642 C the contact function and its derivative.
 643 C
 644 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 645 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 646 C Uncomment next line, if the correlation interactions are contact function only
 647             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 648               rij=dsqrt(rij)
 649               sigij=sigma(itypi,itypj)
 650               r0ij=rs0(itypi,itypj)
 651 C
 652 C Check whether the SC's are not too far to make a contact.
 653 C
 654               rcut=1.5d0*r0ij
 655               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 656 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 657 C
 658               if (fcont.gt.0.0D0) then
 659 C If the SC-SC distance if close to sigma, apply spline.
 660 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 661 cAdam &             fcont1,fprimcont1)
 662 cAdam           fcont1=1.0d0-fcont1
 663 cAdam           if (fcont1.gt.0.0d0) then
 664 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 665 cAdam             fcont=fcont*fcont1
 666 cAdam           endif
 667 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 668 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 669 cga             do k=1,3
 670 cga               gg(k)=gg(k)*eps0ij
 671 cga             enddo
 672 cga             eps0ij=-evdwij*eps0ij
 673 C Uncomment for AL's type of SC correlation interactions.
 674 cadam           eps0ij=-evdwij
 675                 num_conti=num_conti+1
 676                 jcont(num_conti,i)=j
 677                 facont(num_conti,i)=fcont*eps0ij
 678                 fprimcont=eps0ij*fprimcont/rij
 679                 fcont=expon*fcont
 680 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 681 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 682 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 683 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 684                 gacont(1,num_conti,i)=-fprimcont*xj
 685                 gacont(2,num_conti,i)=-fprimcont*yj
 686                 gacont(3,num_conti,i)=-fprimcont*zj
 687 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 688 cd              write (iout,'(2i3,3f10.5)')
 689 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 690               endif
 691             endif
 692           enddo      ! j
 693         enddo        ! iint
 694 C Change 12/1/95
 695         num_cont(i)=num_conti
 696       enddo          ! i
 697       if (calc_grad) then
 698       do i=1,nct
 699         do j=1,3
 700           gvdwc(j,i)=expon*gvdwc(j,i)
 701           gvdwx(j,i)=expon*gvdwx(j,i)
 702         enddo
 703       enddo
 704       endif
 705 C******************************************************************************
 706 C
 707 C                              N O T E !!!
 708 C
 709 C To save time, the factor of EXPON has been extracted from ALL components
 710 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 711 C use!
 712 C
 713 C******************************************************************************
 714       return
 715       end
 716 C-----------------------------------------------------------------------------
 717       subroutine eljk(evdw,evdw_t)
 718 C
 719 C This subroutine calculates the interaction energy of nonbonded side chains
 720 C assuming the LJK potential of interaction.
 721 C
 722       implicit real*8 (a-h,o-z)
 723       include 'DIMENSIONS'
 724       include 'DIMENSIONS.ZSCOPT'
 725       include "DIMENSIONS.COMPAR"
 726       include 'COMMON.GEO'
 727       include 'COMMON.VAR'
 728       include 'COMMON.LOCAL'
 729       include 'COMMON.CHAIN'
 730       include 'COMMON.DERIV'
 731       include 'COMMON.INTERACT'
 732       include 'COMMON.ENEPS'
 733       include 'COMMON.IOUNITS'
 734       include 'COMMON.NAMES'
 735       dimension gg(3)
 736       logical scheck
 737       integer icant
 738       external icant
 739 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 740       do i=1,210
 741         do j=1,2
 742           eneps_temp(j,i)=0.0d0
 743         enddo
 744       enddo
 745       evdw=0.0D0
 746       evdw_t=0.0d0
 747       do i=iatsc_s,iatsc_e
 748         itypi=iabs(itype(i))
 749         if (itypi.eq.ntyp1) cycle
 750         itypi1=iabs(itype(i+1))
 751         xi=c(1,nres+i)
 752         yi=c(2,nres+i)
 753         zi=c(3,nres+i)
 754 C
 755 C Calculate SC interaction energy.
 756 C
 757         do iint=1,nint_gr(i)
 758           do j=istart(i,iint),iend(i,iint)
 759             itypj=iabs(itype(j))
 760             if (itypj.eq.ntyp1) cycle
 761             xj=c(1,nres+j)-xi
 762             yj=c(2,nres+j)-yi
 763             zj=c(3,nres+j)-zi
 764             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 765             fac_augm=rrij**expon
 766             e_augm=augm(itypi,itypj)*fac_augm
 767             r_inv_ij=dsqrt(rrij)
 768             rij=1.0D0/r_inv_ij
 769             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 770             fac=r_shift_inv**expon
 771             e1=fac*fac*aa
 772             e2=fac*bb
 773             evdwij=e_augm+e1+e2
 774             ij=icant(itypi,itypj)
 775             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 776      &        /dabs(eps(itypi,itypj))
 777             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 778 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 779 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 780 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 781 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 782 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 783 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 784 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 785             if (bb.gt.0.0d0) then
 786               evdw=evdw+evdwij
 787             else
 788               evdw_t=evdw_t+evdwij
 789             endif
 790             if (calc_grad) then
 791 C
 792 C Calculate the components of the gradient in DC and X
 793 C
 794             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 795             gg(1)=xj*fac
 796             gg(2)=yj*fac
 797             gg(3)=zj*fac
 798             do k=1,3
 799               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 800               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 801             enddo
 802             do k=i,j-1
 803               do l=1,3
 804                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 805               enddo
 806             enddo
 807             endif
 808           enddo      ! j
 809         enddo        ! iint
 810       enddo          ! i
 811       if (calc_grad) then
 812       do i=1,nct
 813         do j=1,3
 814           gvdwc(j,i)=expon*gvdwc(j,i)
 815           gvdwx(j,i)=expon*gvdwx(j,i)
 816         enddo
 817       enddo
 818       endif
 819       return
 820       end
 821 C-----------------------------------------------------------------------------
 822       subroutine ebp(evdw,evdw_t)
 823 C
 824 C This subroutine calculates the interaction energy of nonbonded side chains
 825 C assuming the Berne-Pechukas potential of interaction.
 826 C
 827       implicit real*8 (a-h,o-z)
 828       include 'DIMENSIONS'
 829       include 'DIMENSIONS.ZSCOPT'
 830       include "DIMENSIONS.COMPAR"
 831       include 'COMMON.GEO'
 832       include 'COMMON.VAR'
 833       include 'COMMON.LOCAL'
 834       include 'COMMON.CHAIN'
 835       include 'COMMON.DERIV'
 836       include 'COMMON.NAMES'
 837       include 'COMMON.INTERACT'
 838       include 'COMMON.ENEPS'
 839       include 'COMMON.IOUNITS'
 840       include 'COMMON.CALC'
 841       common /srutu/ icall
 842 c     double precision rrsave(maxdim)
 843       logical lprn
 844       integer icant
 845       external icant
 846       do i=1,210
 847         do j=1,2
 848           eneps_temp(j,i)=0.0d0
 849         enddo
 850       enddo
 851       evdw=0.0D0
 852       evdw_t=0.0d0
 853 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 854 c     if (icall.eq.0) then
 855 c       lprn=.true.
 856 c     else
 857         lprn=.false.
 858 c     endif
 859       ind=0
 860       do i=iatsc_s,iatsc_e
 861         itypi=iabs(itype(i))
 862         if (itypi.eq.ntyp1) cycle
 863         itypi1=iabs(itype(i+1))
 864         xi=c(1,nres+i)
 865         yi=c(2,nres+i)
 866         zi=c(3,nres+i)
 867         dxi=dc_norm(1,nres+i)
 868         dyi=dc_norm(2,nres+i)
 869         dzi=dc_norm(3,nres+i)
 870         dsci_inv=vbld_inv(i+nres)
 871 C
 872 C Calculate SC interaction energy.
 873 C
 874         do iint=1,nint_gr(i)
 875           do j=istart(i,iint),iend(i,iint)
 876             ind=ind+1
 877             itypj=iabs(itype(j))
 878             if (itypj.eq.ntyp1) cycle
 879             dscj_inv=vbld_inv(j+nres)
 880             chi1=chi(itypi,itypj)
 881             chi2=chi(itypj,itypi)
 882             chi12=chi1*chi2
 883             chip1=chip(itypi)
 884             chip2=chip(itypj)
 885             chip12=chip1*chip2
 886             alf1=alp(itypi)
 887             alf2=alp(itypj)
 888             alf12=0.5D0*(alf1+alf2)
 889 C For diagnostics only!!!
 890 c           chi1=0.0D0
 891 c           chi2=0.0D0
 892 c           chi12=0.0D0
 893 c           chip1=0.0D0
 894 c           chip2=0.0D0
 895 c           chip12=0.0D0
 896 c           alf1=0.0D0
 897 c           alf2=0.0D0
 898 c           alf12=0.0D0
 899             xj=c(1,nres+j)-xi
 900             yj=c(2,nres+j)-yi
 901             zj=c(3,nres+j)-zi
 902             dxj=dc_norm(1,nres+j)
 903             dyj=dc_norm(2,nres+j)
 904             dzj=dc_norm(3,nres+j)
 905             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 906 cd          if (icall.eq.0) then
 907 cd            rrsave(ind)=rrij
 908 cd          else
 909 cd            rrij=rrsave(ind)
 910 cd          endif
 911             rij=dsqrt(rrij)
 912 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 913             call sc_angular
 914 C Calculate whole angle-dependent part of epsilon and contributions
 915 C to its derivatives
 916             fac=(rrij*sigsq)**expon2
 917             e1=fac*fac*aa
 918             e2=fac*bb
 919             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 920             eps2der=evdwij*eps3rt
 921             eps3der=evdwij*eps2rt
 922             evdwij=evdwij*eps2rt*eps3rt
 923             ij=icant(itypi,itypj)
 924             aux=eps1*eps2rt**2*eps3rt**2
 925             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 926      &        /dabs(eps(itypi,itypj))
 927             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 928             if (bb.gt.0.0d0) then
 929               evdw=evdw+evdwij
 930             else
 931               evdw_t=evdw_t+evdwij
 932             endif
 933             if (calc_grad) then
 934             if (lprn) then
 935             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 936             epsi=bb**2/aa
 937             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 938      &        restyp(itypi),i,restyp(itypj),j,
 939      &        epsi,sigm,chi1,chi2,chip1,chip2,
 940      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 941      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 942      &        evdwij
 943             endif
 944 C Calculate gradient components.
 945             e1=e1*eps1*eps2rt**2*eps3rt**2
 946             fac=-expon*(e1+evdwij)
 947             sigder=fac/sigsq
 948             fac=rrij*fac
 949 C Calculate radial part of the gradient
 950             gg(1)=xj*fac
 951             gg(2)=yj*fac
 952             gg(3)=zj*fac
 953 C Calculate the angular part of the gradient and sum add the contributions
 954 C to the appropriate components of the Cartesian gradient.
 955             call sc_grad
 956             endif
 957           enddo      ! j
 958         enddo        ! iint
 959       enddo          ! i
 960 c     stop
 961       return
 962       end
 963 C-----------------------------------------------------------------------------
 964       subroutine egb(evdw,evdw_t)
 965 C
 966 C This subroutine calculates the interaction energy of nonbonded side chains
 967 C assuming the Gay-Berne potential of interaction.
 968 C
 969       implicit real*8 (a-h,o-z)
 970       include 'DIMENSIONS'
 971       include 'DIMENSIONS.ZSCOPT'
 972       include "DIMENSIONS.COMPAR"
 973       include 'COMMON.CONTROL'
 974       include 'COMMON.GEO'
 975       include 'COMMON.VAR'
 976       include 'COMMON.LOCAL'
 977       include 'COMMON.CHAIN'
 978       include 'COMMON.DERIV'
 979       include 'COMMON.NAMES'
 980       include 'COMMON.INTERACT'
 981       include 'COMMON.ENEPS'
 982       include 'COMMON.IOUNITS'
 983       include 'COMMON.CALC'
 984       include 'COMMON.SBRIDGE'
 985       logical lprn
 986       common /srutu/icall
 987       integer icant,xshift,yshift,zshift
 988       external icant
 989       do i=1,210
 990         do j=1,2
 991           eneps_temp(j,i)=0.0d0
 992         enddo
 993       enddo
 994 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 995       evdw=0.0D0
 996       evdw_t=0.0d0
 997       lprn=.false.
 998 c      if (icall.gt.0) lprn=.true.
 999       ind=0
1000       do i=iatsc_s,iatsc_e
1001         itypi=iabs(itype(i))
1002         if (itypi.eq.ntyp1) cycle
1003         itypi1=iabs(itype(i+1))
1004         xi=c(1,nres+i)
1005         yi=c(2,nres+i)
1006         zi=c(3,nres+i)
1007 C returning the ith atom to box
1008           xi=mod(xi,boxxsize)
1009           if (xi.lt.0) xi=xi+boxxsize
1010           yi=mod(yi,boxysize)
1011           if (yi.lt.0) yi=yi+boxysize
1012           zi=mod(zi,boxzsize)
1013           if (zi.lt.0) zi=zi+boxzsize
1014        if ((zi.gt.bordlipbot)
1015      &.and.(zi.lt.bordliptop)) then
1016 C the energy transfer exist
1017         if (zi.lt.buflipbot) then
1018 C what fraction I am in
1019          fracinbuf=1.0d0-
1020      &        ((zi-bordlipbot)/lipbufthick)
1021 C lipbufthick is thickenes of lipid buffore
1022          sslipi=sscalelip(fracinbuf)
1023          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1024         elseif (zi.gt.bufliptop) then
1025          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1026          sslipi=sscalelip(fracinbuf)
1027          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1028         else
1029          sslipi=1.0d0
1030          ssgradlipi=0.0
1031         endif
1032        else
1033          sslipi=0.0d0
1034          ssgradlipi=0.0
1035        endif
1036
1037         dxi=dc_norm(1,nres+i)
1038         dyi=dc_norm(2,nres+i)
1039         dzi=dc_norm(3,nres+i)
1040         dsci_inv=vbld_inv(i+nres)
1041 C
1042 C Calculate SC interaction energy.
1043 C
1044         do iint=1,nint_gr(i)
1045           do j=istart(i,iint),iend(i,iint)
1046 c            write (iout,*) "i j",i,j," dyn_ss_mask",dyn_ss_mask(i),
1047 c     &          dyn_ss_mask(j)
1048             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1049               call dyn_ssbond_ene(i,j,evdwij)
1050               evdw=evdw+evdwij
1051               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1052      &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1053 C triple bond artifac removal
1054              do k=j+1,iend(i,iint)
1055 C search over all next residues
1056               if (dyn_ss_mask(k)) then
1057 C check if they are cysteins
1058 C              write(iout,*) 'k=',k
1059               call triple_ssbond_ene(i,j,k,evdwij)
1060 C call the energy function that removes the artifical triple disulfide
1061 C bond the soubroutine is located in ssMD.F
1062               evdw=evdw+evdwij
1063 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1064 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1065               endif!dyn_ss_mask(k)
1066              enddo! k
1067             ELSE
1068             ind=ind+1
1069             itypj=iabs(itype(j))
1070             if (itypj.eq.ntyp1) cycle
1071             dscj_inv=vbld_inv(j+nres)
1072             sig0ij=sigma(itypi,itypj)
1073             chi1=chi(itypi,itypj)
1074             chi2=chi(itypj,itypi)
1075             chi12=chi1*chi2
1076             chip1=chip(itypi)
1077             chip2=chip(itypj)
1078             chip12=chip1*chip2
1079             alf1=alp(itypi)
1080             alf2=alp(itypj)
1081             alf12=0.5D0*(alf1+alf2)
1082 C For diagnostics only!!!
1083 c           chi1=0.0D0
1084 c           chi2=0.0D0
1085 c           chi12=0.0D0
1086 c           chip1=0.0D0
1087 c           chip2=0.0D0
1088 c           chip12=0.0D0
1089 c           alf1=0.0D0
1090 c           alf2=0.0D0
1091 c           alf12=0.0D0
1092             xj=c(1,nres+j)
1093             yj=c(2,nres+j)
1094             zj=c(3,nres+j)
1095 C returning jth atom to box
1096           xj=mod(xj,boxxsize)
1097           if (xj.lt.0) xj=xj+boxxsize
1098           yj=mod(yj,boxysize)
1099           if (yj.lt.0) yj=yj+boxysize
1100           zj=mod(zj,boxzsize)
1101           if (zj.lt.0) zj=zj+boxzsize
1102        if ((zj.gt.bordlipbot)
1103      &.and.(zj.lt.bordliptop)) then
1104 C the energy transfer exist
1105         if (zj.lt.buflipbot) then
1106 C what fraction I am in
1107          fracinbuf=1.0d0-
1108      &        ((zj-bordlipbot)/lipbufthick)
1109 C lipbufthick is thickenes of lipid buffore
1110          sslipj=sscalelip(fracinbuf)
1111          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1112         elseif (zj.gt.bufliptop) then
1113          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1114          sslipj=sscalelip(fracinbuf)
1115          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1116         else
1117          sslipj=1.0d0
1118          ssgradlipj=0.0
1119         endif
1120        else
1121          sslipj=0.0d0
1122          ssgradlipj=0.0
1123        endif
1124       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1125      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1126       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1127      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1128 C       if (aa.ne.aa_aq(itypi,itypj)) then
1129
1130 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1131 C     & bb_aq(itypi,itypj)-bb,
1132 C     & sslipi,sslipj
1133 C         endif
1134
1135 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1136 C checking the distance
1137       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1138       xj_safe=xj
1139       yj_safe=yj
1140       zj_safe=zj
1141       subchap=0
1142 C finding the closest
1143       do xshift=-1,1
1144       do yshift=-1,1
1145       do zshift=-1,1
1146           xj=xj_safe+xshift*boxxsize
1147           yj=yj_safe+yshift*boxysize
1148           zj=zj_safe+zshift*boxzsize
1149           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1150           if(dist_temp.lt.dist_init) then
1151             dist_init=dist_temp
1152             xj_temp=xj
1153             yj_temp=yj
1154             zj_temp=zj
1155             subchap=1
1156           endif
1157        enddo
1158        enddo
1159        enddo
1160        if (subchap.eq.1) then
1161           xj=xj_temp-xi
1162           yj=yj_temp-yi
1163           zj=zj_temp-zi
1164        else
1165           xj=xj_safe-xi
1166           yj=yj_safe-yi
1167           zj=zj_safe-zi
1168        endif
1169
1170             dxj=dc_norm(1,nres+j)
1171             dyj=dc_norm(2,nres+j)
1172             dzj=dc_norm(3,nres+j)
1173 c            write (iout,*) i,j,xj,yj,zj
1174             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1175             rij=dsqrt(rrij)
1176             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1177             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1178             if (sss.le.0.0) cycle
1179 C Calculate angle-dependent terms of energy and contributions to their
1180 C derivatives.
1181
1182             call sc_angular
1183             sigsq=1.0D0/sigsq
1184             sig=sig0ij*dsqrt(sigsq)
1185             rij_shift=1.0D0/rij-sig+sig0ij
1186 C I hate to put IF's in the loops, but here don't have another choice!!!!
1187             if (rij_shift.le.0.0D0) then
1188               evdw=1.0D20
1189               return
1190             endif
1191             sigder=-sig*sigsq
1192 c---------------------------------------------------------------
1193             rij_shift=1.0D0/rij_shift
1194             fac=rij_shift**expon
1195             e1=fac*fac*aa
1196             e2=fac*bb
1197             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1198             eps2der=evdwij*eps3rt
1199             eps3der=evdwij*eps2rt
1200             evdwij=evdwij*eps2rt*eps3rt
1201             if (bb.gt.0) then
1202               evdw=evdw+evdwij*sss
1203             else
1204               evdw_t=evdw_t+evdwij*sss
1205             endif
1206             ij=icant(itypi,itypj)
1207             aux=eps1*eps2rt**2*eps3rt**2
1208             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1209      &        /dabs(eps(itypi,itypj))
1210             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1211 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1212 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1213 c     &         aux*e2/eps(itypi,itypj)
1214 c            if (lprn) then
1215             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1216             epsi=bb**2/aa
1217 c#define DEBUG
1218 #ifdef DEBUG
1219             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1220      &        restyp(itypi),i,restyp(itypj),j,
1221      &        epsi,sigm,chi1,chi2,chip1,chip2,
1222      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1223      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1224      &        evdwij
1225              write (iout,*) "partial sum", evdw, evdw_t
1226 #endif
1227 c#undef DEBUG
1228 c            endif
1229             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1230      &                        'evdw',i,j,evdwij
1231             if (calc_grad) then
1232 C Calculate gradient components.
1233             e1=e1*eps1*eps2rt**2*eps3rt**2
1234             fac=-expon*(e1+evdwij)*rij_shift
1235             sigder=fac*sigder
1236             fac=rij*fac
1237             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1238 C Calculate the radial part of the gradient
1239             gg(1)=xj*fac
1240             gg(2)=yj*fac
1241             gg(3)=zj*fac
1242 C Calculate angular part of the gradient.
1243             call sc_grad
1244             endif
1245 C            write(iout,*)  "partial sum", evdw, evdw_t
1246             ENDIF    ! dyn_ss
1247           enddo      ! j
1248         enddo        ! iint
1249       enddo          ! i
1250       return
1251       end
1252 C-----------------------------------------------------------------------------
1253       subroutine egbv(evdw,evdw_t)
1254 C
1255 C This subroutine calculates the interaction energy of nonbonded side chains
1256 C assuming the Gay-Berne-Vorobjev potential of interaction.
1257 C
1258       implicit real*8 (a-h,o-z)
1259       include 'DIMENSIONS'
1260       include 'DIMENSIONS.ZSCOPT'
1261       include "DIMENSIONS.COMPAR"
1262       include 'COMMON.CONTROL'
1263       include 'COMMON.GEO'
1264       include 'COMMON.VAR'
1265       include 'COMMON.LOCAL'
1266       include 'COMMON.CHAIN'
1267       include 'COMMON.DERIV'
1268       include 'COMMON.NAMES'
1269       include 'COMMON.INTERACT'
1270       include 'COMMON.ENEPS'
1271       include 'COMMON.IOUNITS'
1272       include 'COMMON.CALC'
1273       include 'COMMON.SBRIDGE'
1274       common /srutu/ icall
1275       logical lprn
1276       integer icant
1277       external icant
1278       do i=1,210
1279         do j=1,2
1280           eneps_temp(j,i)=0.0d0
1281         enddo
1282       enddo
1283       evdw=0.0D0
1284       evdw_t=0.0d0
1285 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1286       evdw=0.0D0
1287       lprn=.false.
1288 c      if (icall.gt.0) lprn=.true.
1289       ind=0
1290       do i=iatsc_s,iatsc_e
1291         itypi=iabs(itype(i))
1292         if (itypi.eq.ntyp1) cycle
1293         itypi1=iabs(itype(i+1))
1294         xi=c(1,nres+i)
1295         yi=c(2,nres+i)
1296         zi=c(3,nres+i)
1297 C returning the ith atom to box
1298         xi=mod(xi,boxxsize)
1299         if (xi.lt.0) xi=xi+boxxsize
1300         yi=mod(yi,boxysize)
1301         if (yi.lt.0) yi=yi+boxysize
1302         zi=mod(zi,boxzsize)
1303         if (zi.lt.0) zi=zi+boxzsize
1304         if ((zi.gt.bordlipbot)
1305      &  .and.(zi.lt.bordliptop)) then
1306 C the energy transfer exist
1307           if (zi.lt.buflipbot) then
1308 C what fraction I am in
1309             fracinbuf=1.0d0-
1310      &        ((zi-bordlipbot)/lipbufthick)
1311 C lipbufthick is thickenes of lipid buffore
1312             sslipi=sscalelip(fracinbuf)
1313             ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1314           elseif (zi.gt.bufliptop) then
1315             fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1316             sslipi=sscalelip(fracinbuf)
1317             ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1318           else
1319             sslipi=1.0d0
1320             ssgradlipi=0.0
1321           endif
1322         else
1323           sslipi=0.0d0
1324           ssgradlipi=0.0
1325         endif
1326         dxi=dc_norm(1,nres+i)
1327         dyi=dc_norm(2,nres+i)
1328         dzi=dc_norm(3,nres+i)
1329         dsci_inv=vbld_inv(i+nres)
1330         dxi=dc_norm(1,nres+i)
1331         dyi=dc_norm(2,nres+i)
1332         dzi=dc_norm(3,nres+i)
1333         dsci_inv=vbld_inv(i+nres)
1334 C
1335 C Calculate SC interaction energy.
1336 C
1337         do iint=1,nint_gr(i)
1338           do j=istart(i,iint),iend(i,iint)
1339             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1340               call dyn_ssbond_ene(i,j,evdwij)
1341               evdw=evdw+evdwij
1342               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1343      &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1344 C triple bond artifac removal
1345              do k=j+1,iend(i,iint)
1346 C search over all next residues
1347               if (dyn_ss_mask(k)) then
1348 C check if they are cysteins
1349 C              write(iout,*) 'k=',k
1350               call triple_ssbond_ene(i,j,k,evdwij)
1351 C call the energy function that removes the artifical triple disulfide
1352 C bond the soubroutine is located in ssMD.F
1353               evdw=evdw+evdwij
1354              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1355      &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1356               endif!dyn_ss_mask(k)
1357              enddo! k
1358             ELSE
1359             ind=ind+1
1360             itypj=iabs(itype(j))
1361             if (itypj.eq.ntyp1) cycle
1362             dscj_inv=vbld_inv(j+nres)
1363             sig0ij=sigma(itypi,itypj)
1364             r0ij=r0(itypi,itypj)
1365             chi1=chi(itypi,itypj)
1366             chi2=chi(itypj,itypi)
1367             chi12=chi1*chi2
1368             chip1=chip(itypi)
1369             chip2=chip(itypj)
1370             chip12=chip1*chip2
1371             alf1=alp(itypi)
1372             alf2=alp(itypj)
1373             alf12=0.5D0*(alf1+alf2)
1374 C For diagnostics only!!!
1375 c           chi1=0.0D0
1376 c           chi2=0.0D0
1377 c           chi12=0.0D0
1378 c           chip1=0.0D0
1379 c           chip2=0.0D0
1380 c           chip12=0.0D0
1381 c           alf1=0.0D0
1382 c           alf2=0.0D0
1383 c           alf12=0.0D0
1384             xj=c(1,nres+j)
1385             yj=c(2,nres+j)
1386             zj=c(3,nres+j)
1387 C returning jth atom to box
1388             xj=mod(xj,boxxsize)
1389             if (xj.lt.0) xj=xj+boxxsize
1390             yj=mod(yj,boxysize)
1391             if (yj.lt.0) yj=yj+boxysize
1392             zj=mod(zj,boxzsize)
1393             if (zj.lt.0) zj=zj+boxzsize
1394             if ((zj.gt.bordlipbot)
1395      &        .and.(zj.lt.bordliptop)) then
1396 C the energy transfer exist
1397               if (zj.lt.buflipbot) then
1398 C what fraction I am in
1399                 fracinbuf=1.0d0-
1400      &          ((zj-bordlipbot)/lipbufthick)
1401 C lipbufthick is thickenes of lipid buffore
1402                 sslipj=sscalelip(fracinbuf)
1403                 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1404               elseif (zj.gt.bufliptop) then
1405                 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1406                 sslipj=sscalelip(fracinbuf)
1407                 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1408               else
1409                 sslipj=1.0d0
1410                 ssgradlipj=0.0
1411               endif
1412             else
1413               sslipj=0.0d0
1414               ssgradlipj=0.0
1415             endif
1416             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1417      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1418             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1419      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1420 C       if (aa.ne.aa_aq(itypi,itypj)) then
1421
1422 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1423 C     & bb_aq(itypi,itypj)-bb,
1424 C     & sslipi,sslipj
1425 C         endif
1426
1427 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1428 C checking the distance
1429             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1430             xj_safe=xj
1431             yj_safe=yj
1432             zj_safe=zj
1433             subchap=0
1434 C finding the closest
1435             do xshift=-1,1
1436               do yshift=-1,1
1437                 do zshift=-1,1
1438                   xj=xj_safe+xshift*boxxsize
1439                   yj=yj_safe+yshift*boxysize
1440                   zj=zj_safe+zshift*boxzsize
1441                   dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1442                   if (dist_temp.lt.dist_init) then
1443                     dist_init=dist_temp
1444                     xj_temp=xj
1445                     yj_temp=yj
1446                     zj_temp=zj
1447                     subchap=1
1448                   endif
1449                 enddo
1450               enddo
1451             enddo
1452             if (subchap.eq.1) then
1453               xj=xj_temp-xi
1454               yj=yj_temp-yi
1455               zj=zj_temp-zi
1456             else
1457               xj=xj_safe-xi
1458               yj=yj_safe-yi
1459               zj=zj_safe-zi
1460             endif
1461
1462             dxj=dc_norm(1,nres+j)
1463             dyj=dc_norm(2,nres+j)
1464             dzj=dc_norm(3,nres+j)
1465 c            write (iout,*) i,j,xj,yj,zj
1466             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1467             rij=dsqrt(rrij)
1468             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1469             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1470             if (sss.le.0.0) cycle
1471 C Calculate angle-dependent terms of energy and contributions to their
1472 C derivatives.
1473
1474             call sc_angular
1475             sigsq=1.0D0/sigsq
1476             sig=sig0ij*dsqrt(sigsq)
1477             rij_shift=1.0D0/rij-sig+r0ij
1478 C I hate to put IF's in the loops, but here don't have another choice!!!!
1479             if (rij_shift.le.0.0D0) then
1480               evdw=1.0D20
1481               return
1482             endif
1483             sigder=-sig*sigsq
1484 c---------------------------------------------------------------
1485             rij_shift=1.0D0/rij_shift
1486             fac=rij_shift**expon
1487             e1=fac*fac*aa
1488             e2=fac*bb
1489             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1490             eps2der=evdwij*eps3rt
1491             eps3der=evdwij*eps2rt
1492             fac_augm=rrij**expon
1493             e_augm=augm(itypi,itypj)*fac_augm
1494             evdwij=evdwij*eps2rt*eps3rt
1495             if (bb.gt.0) then
1496               evdw=evdw+evdwij*sss+e_augm
1497             else
1498               evdw_t=evdw_t+evdwij*sss+e_augm
1499             endif
1500 c            evdw=evdw+evdwij+e_augm
1501             ij=icant(itypi,itypj)
1502             aux=eps1*eps2rt**2*eps3rt**2
1503             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1504      &        /dabs(eps(itypi,itypj))
1505             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1506 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1507 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1508 c     &         aux*e2/eps(itypi,itypj)
1509 c            if (lprn) then
1510 c#define DEBUG
1511 #ifdef DEBUG
1512             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1513             epsi=bb**2/aa
1514             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1515      &        restyp(itypi),i,restyp(itypj),j,
1516      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1517      &        chi1,chi2,chip1,chip2,
1518      &        eps1,eps2rt**2,eps3rt**2,
1519      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1520      &        evdwij+e_augm
1521              write (iout,*) "partial sum", evdw, evdw_t
1522 #endif
1523 c#undef DEBUG
1524 c            endif
1525             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1526      &                        'evdw',i,j,evdwij
1527             if (calc_grad) then
1528 C Calculate gradient components.
1529             e1=e1*eps1*eps2rt**2*eps3rt**2
1530             fac=-expon*(e1+evdwij)*rij_shift
1531             sigder=fac*sigder
1532             fac=rij*fac
1533             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1534 C Calculate the radial part of the gradient
1535             gg(1)=xj*fac
1536             gg(2)=yj*fac
1537             gg(3)=zj*fac
1538 C Calculate angular part of the gradient.
1539             call sc_grad
1540             endif
1541             ENDIF
1542           enddo      ! j
1543         enddo        ! iint
1544       enddo          ! i
1545       return
1546       end
1547 C-----------------------------------------------------------------------------
1548       subroutine sc_angular
1549 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1550 C om12. Called by ebp, egb, and egbv.
1551       implicit none
1552       include 'COMMON.CALC'
1553       erij(1)=xj*rij
1554       erij(2)=yj*rij
1555       erij(3)=zj*rij
1556       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1557       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1558       om12=dxi*dxj+dyi*dyj+dzi*dzj
1559       chiom12=chi12*om12
1560 C Calculate eps1(om12) and its derivative in om12
1561       faceps1=1.0D0-om12*chiom12
1562       faceps1_inv=1.0D0/faceps1
1563       eps1=dsqrt(faceps1_inv)
1564 C Following variable is eps1*deps1/dom12
1565       eps1_om12=faceps1_inv*chiom12
1566 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1567 C and om12.
1568       om1om2=om1*om2
1569       chiom1=chi1*om1
1570       chiom2=chi2*om2
1571       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1572       sigsq=1.0D0-facsig*faceps1_inv
1573       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1574       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1575       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1576 C Calculate eps2 and its derivatives in om1, om2, and om12.
1577       chipom1=chip1*om1
1578       chipom2=chip2*om2
1579       chipom12=chip12*om12
1580       facp=1.0D0-om12*chipom12
1581       facp_inv=1.0D0/facp
1582       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1583 C Following variable is the square root of eps2
1584       eps2rt=1.0D0-facp1*facp_inv
1585 C Following three variables are the derivatives of the square root of eps
1586 C in om1, om2, and om12.
1587       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1588       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1589       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1590 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1591       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1592 C Calculate whole angle-dependent part of epsilon and contributions
1593 C to its derivatives
1594       return
1595       end
1596 C----------------------------------------------------------------------------
1597       subroutine sc_grad
1598       implicit real*8 (a-h,o-z)
1599       include 'DIMENSIONS'
1600       include 'DIMENSIONS.ZSCOPT'
1601       include 'COMMON.CHAIN'
1602       include 'COMMON.DERIV'
1603       include 'COMMON.CALC'
1604       double precision dcosom1(3),dcosom2(3)
1605       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1606       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1607       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1608      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1609       do k=1,3
1610         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1611         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1612       enddo
1613       do k=1,3
1614         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1615       enddo
1616       do k=1,3
1617         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1618      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1619      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1620         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1621      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1622      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1623       enddo
1624 C
1625 C Calculate the components of the gradient in DC and X
1626 C
1627       do k=i,j-1
1628         do l=1,3
1629           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1630         enddo
1631       enddo
1632       return
1633       end
1634 c------------------------------------------------------------------------------
1635       subroutine vec_and_deriv
1636       implicit real*8 (a-h,o-z)
1637       include 'DIMENSIONS'
1638       include 'DIMENSIONS.ZSCOPT'
1639       include 'COMMON.IOUNITS'
1640       include 'COMMON.GEO'
1641       include 'COMMON.VAR'
1642       include 'COMMON.LOCAL'
1643       include 'COMMON.CHAIN'
1644       include 'COMMON.VECTORS'
1645       include 'COMMON.DERIV'
1646       include 'COMMON.INTERACT'
1647       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1648 C Compute the local reference systems. For reference system (i), the
1649 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1650 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1651       do i=1,nres-1
1652 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1653           if (i.eq.nres-1) then
1654 C Case of the last full residue
1655 C Compute the Z-axis
1656             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1657             costh=dcos(pi-theta(nres))
1658             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1659 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1660 c     &         " uz",uz(:,i)
1661             do k=1,3
1662               uz(k,i)=fac*uz(k,i)
1663             enddo
1664             if (calc_grad) then
1665 C Compute the derivatives of uz
1666             uzder(1,1,1)= 0.0d0
1667             uzder(2,1,1)=-dc_norm(3,i-1)
1668             uzder(3,1,1)= dc_norm(2,i-1)
1669             uzder(1,2,1)= dc_norm(3,i-1)
1670             uzder(2,2,1)= 0.0d0
1671             uzder(3,2,1)=-dc_norm(1,i-1)
1672             uzder(1,3,1)=-dc_norm(2,i-1)
1673             uzder(2,3,1)= dc_norm(1,i-1)
1674             uzder(3,3,1)= 0.0d0
1675             uzder(1,1,2)= 0.0d0
1676             uzder(2,1,2)= dc_norm(3,i)
1677             uzder(3,1,2)=-dc_norm(2,i)
1678             uzder(1,2,2)=-dc_norm(3,i)
1679             uzder(2,2,2)= 0.0d0
1680             uzder(3,2,2)= dc_norm(1,i)
1681             uzder(1,3,2)= dc_norm(2,i)
1682             uzder(2,3,2)=-dc_norm(1,i)
1683             uzder(3,3,2)= 0.0d0
1684             endif ! calc_grad
1685 C Compute the Y-axis
1686             facy=fac
1687             do k=1,3
1688               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1689             enddo
1690             if (calc_grad) then
1691 C Compute the derivatives of uy
1692             do j=1,3
1693               do k=1,3
1694                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1695      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1696                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1697               enddo
1698               uyder(j,j,1)=uyder(j,j,1)-costh
1699               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1700             enddo
1701             do j=1,2
1702               do k=1,3
1703                 do l=1,3
1704                   uygrad(l,k,j,i)=uyder(l,k,j)
1705                   uzgrad(l,k,j,i)=uzder(l,k,j)
1706                 enddo
1707               enddo
1708             enddo
1709             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1710             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1711             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1712             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1713             endif
1714           else
1715 C Other residues
1716 C Compute the Z-axis
1717             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1718             costh=dcos(pi-theta(i+2))
1719             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1720             do k=1,3
1721               uz(k,i)=fac*uz(k,i)
1722             enddo
1723             if (calc_grad) then
1724 C Compute the derivatives of uz
1725             uzder(1,1,1)= 0.0d0
1726             uzder(2,1,1)=-dc_norm(3,i+1)
1727             uzder(3,1,1)= dc_norm(2,i+1)
1728             uzder(1,2,1)= dc_norm(3,i+1)
1729             uzder(2,2,1)= 0.0d0
1730             uzder(3,2,1)=-dc_norm(1,i+1)
1731             uzder(1,3,1)=-dc_norm(2,i+1)
1732             uzder(2,3,1)= dc_norm(1,i+1)
1733             uzder(3,3,1)= 0.0d0
1734             uzder(1,1,2)= 0.0d0
1735             uzder(2,1,2)= dc_norm(3,i)
1736             uzder(3,1,2)=-dc_norm(2,i)
1737             uzder(1,2,2)=-dc_norm(3,i)
1738             uzder(2,2,2)= 0.0d0
1739             uzder(3,2,2)= dc_norm(1,i)
1740             uzder(1,3,2)= dc_norm(2,i)
1741             uzder(2,3,2)=-dc_norm(1,i)
1742             uzder(3,3,2)= 0.0d0
1743             endif
1744 C Compute the Y-axis
1745             facy=fac
1746             do k=1,3
1747               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1748             enddo
1749             if (calc_grad) then
1750 C Compute the derivatives of uy
1751             do j=1,3
1752               do k=1,3
1753                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1754      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1755                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1756               enddo
1757               uyder(j,j,1)=uyder(j,j,1)-costh
1758               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1759             enddo
1760             do j=1,2
1761               do k=1,3
1762                 do l=1,3
1763                   uygrad(l,k,j,i)=uyder(l,k,j)
1764                   uzgrad(l,k,j,i)=uzder(l,k,j)
1765                 enddo
1766               enddo
1767             enddo
1768             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1769             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1770             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1771             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1772           endif
1773           endif
1774       enddo
1775       if (calc_grad) then
1776       do i=1,nres-1
1777         vbld_inv_temp(1)=vbld_inv(i+1)
1778         if (i.lt.nres-1) then
1779           vbld_inv_temp(2)=vbld_inv(i+2)
1780         else
1781           vbld_inv_temp(2)=vbld_inv(i)
1782         endif
1783         do j=1,2
1784           do k=1,3
1785             do l=1,3
1786               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1787               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1788             enddo
1789           enddo
1790         enddo
1791       enddo
1792       endif
1793       return
1794       end
1795 C--------------------------------------------------------------------------
1796       subroutine set_matrices
1797       implicit real*8 (a-h,o-z)
1798       include 'DIMENSIONS'
1799 #ifdef MPI
1800       include "mpif.h"
1801       integer IERR
1802       integer status(MPI_STATUS_SIZE)
1803 #endif
1804       include 'DIMENSIONS.ZSCOPT'
1805       include 'COMMON.IOUNITS'
1806       include 'COMMON.GEO'
1807       include 'COMMON.VAR'
1808       include 'COMMON.LOCAL'
1809       include 'COMMON.CHAIN'
1810       include 'COMMON.DERIV'
1811       include 'COMMON.INTERACT'
1812       include 'COMMON.CONTACTS'
1813       include 'COMMON.TORSION'
1814       include 'COMMON.VECTORS'
1815       include 'COMMON.FFIELD'
1816       double precision auxvec(2),auxmat(2,2)
1817 C
1818 C Compute the virtual-bond-torsional-angle dependent quantities needed
1819 C to calculate the el-loc multibody terms of various order.
1820 C
1821 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1822       do i=3,nres+1
1823         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1824           iti = itype2loc(itype(i-2))
1825         else
1826           iti=nloctyp
1827         endif
1828 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1829         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1830           iti1 = itype2loc(itype(i-1))
1831         else
1832           iti1=nloctyp
1833         endif
1834 #ifdef NEWCORR
1835         cost1=dcos(theta(i-1))
1836         sint1=dsin(theta(i-1))
1837         sint1sq=sint1*sint1
1838         sint1cub=sint1sq*sint1
1839         sint1cost1=2*sint1*cost1
1840 #ifdef DEBUG
1841         write (iout,*) "bnew1",i,iti
1842         write (iout,*) (bnew1(k,1,iti),k=1,3)
1843         write (iout,*) (bnew1(k,2,iti),k=1,3)
1844         write (iout,*) "bnew2",i,iti
1845         write (iout,*) (bnew2(k,1,iti),k=1,3)
1846         write (iout,*) (bnew2(k,2,iti),k=1,3)
1847 #endif
1848         do k=1,2
1849           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1850           b1(k,i-2)=sint1*b1k
1851           gtb1(k,i-2)=cost1*b1k-sint1sq*
1852      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1853           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1854           b2(k,i-2)=sint1*b2k
1855           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1856      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1857         enddo
1858         do k=1,2
1859           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1860           cc(1,k,i-2)=sint1sq*aux
1861           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1862      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1863           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1864           dd(1,k,i-2)=sint1sq*aux
1865           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1866      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1867         enddo
1868         cc(2,1,i-2)=cc(1,2,i-2)
1869         cc(2,2,i-2)=-cc(1,1,i-2)
1870         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1871         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1872         dd(2,1,i-2)=dd(1,2,i-2)
1873         dd(2,2,i-2)=-dd(1,1,i-2)
1874         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1875         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1876         do k=1,2
1877           do l=1,2
1878             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1879             EE(l,k,i-2)=sint1sq*aux
1880             if (calc_grad)
1881      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1882           enddo
1883         enddo
1884         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1885         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1886         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1887         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1888         if (calc_grad) then
1889         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1890         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1891         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1892         endif
1893 c        b1tilde(1,i-2)=b1(1,i-2)
1894 c        b1tilde(2,i-2)=-b1(2,i-2)
1895 c        b2tilde(1,i-2)=b2(1,i-2)
1896 c        b2tilde(2,i-2)=-b2(2,i-2)
1897 #ifdef DEBUG
1898         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1899         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1900         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1901         write (iout,*) 'theta=', theta(i-1)
1902 #endif
1903 #else
1904 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1905 c          iti = itype2loc(itype(i-2))
1906 c        else
1907 c          iti=nloctyp
1908 c        endif
1909 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1910 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1911 c          iti1 = itype2loc(itype(i-1))
1912 c        else
1913 c          iti1=nloctyp
1914 c        endif
1915         b1(1,i-2)=b(3,iti)
1916         b1(2,i-2)=b(5,iti)
1917         b2(1,i-2)=b(2,iti)
1918         b2(2,i-2)=b(4,iti)
1919         do k=1,2
1920           do l=1,2
1921            CC(k,l,i-2)=ccold(k,l,iti)
1922            DD(k,l,i-2)=ddold(k,l,iti)
1923            EE(k,l,i-2)=eeold(k,l,iti)
1924           enddo
1925         enddo
1926 #endif
1927         b1tilde(1,i-2)= b1(1,i-2)
1928         b1tilde(2,i-2)=-b1(2,i-2)
1929         b2tilde(1,i-2)= b2(1,i-2)
1930         b2tilde(2,i-2)=-b2(2,i-2)
1931 c
1932         Ctilde(1,1,i-2)= CC(1,1,i-2)
1933         Ctilde(1,2,i-2)= CC(1,2,i-2)
1934         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1935         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1936 c
1937         Dtilde(1,1,i-2)= DD(1,1,i-2)
1938         Dtilde(1,2,i-2)= DD(1,2,i-2)
1939         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1940         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1941 #ifdef DEBUG
1942         write(iout,*) "i",i," iti",iti
1943         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1944         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1945 #endif
1946       enddo
1947       do i=3,nres+1
1948         if (i .lt. nres+1) then
1949           sin1=dsin(phi(i))
1950           cos1=dcos(phi(i))
1951           sintab(i-2)=sin1
1952           costab(i-2)=cos1
1953           obrot(1,i-2)=cos1
1954           obrot(2,i-2)=sin1
1955           sin2=dsin(2*phi(i))
1956           cos2=dcos(2*phi(i))
1957           sintab2(i-2)=sin2
1958           costab2(i-2)=cos2
1959           obrot2(1,i-2)=cos2
1960           obrot2(2,i-2)=sin2
1961           Ug(1,1,i-2)=-cos1
1962           Ug(1,2,i-2)=-sin1
1963           Ug(2,1,i-2)=-sin1
1964           Ug(2,2,i-2)= cos1
1965           Ug2(1,1,i-2)=-cos2
1966           Ug2(1,2,i-2)=-sin2
1967           Ug2(2,1,i-2)=-sin2
1968           Ug2(2,2,i-2)= cos2
1969         else
1970           costab(i-2)=1.0d0
1971           sintab(i-2)=0.0d0
1972           obrot(1,i-2)=1.0d0
1973           obrot(2,i-2)=0.0d0
1974           obrot2(1,i-2)=0.0d0
1975           obrot2(2,i-2)=0.0d0
1976           Ug(1,1,i-2)=1.0d0
1977           Ug(1,2,i-2)=0.0d0
1978           Ug(2,1,i-2)=0.0d0
1979           Ug(2,2,i-2)=1.0d0
1980           Ug2(1,1,i-2)=0.0d0
1981           Ug2(1,2,i-2)=0.0d0
1982           Ug2(2,1,i-2)=0.0d0
1983           Ug2(2,2,i-2)=0.0d0
1984         endif
1985         if (i .gt. 3 .and. i .lt. nres+1) then
1986           obrot_der(1,i-2)=-sin1
1987           obrot_der(2,i-2)= cos1
1988           Ugder(1,1,i-2)= sin1
1989           Ugder(1,2,i-2)=-cos1
1990           Ugder(2,1,i-2)=-cos1
1991           Ugder(2,2,i-2)=-sin1
1992           dwacos2=cos2+cos2
1993           dwasin2=sin2+sin2
1994           obrot2_der(1,i-2)=-dwasin2
1995           obrot2_der(2,i-2)= dwacos2
1996           Ug2der(1,1,i-2)= dwasin2
1997           Ug2der(1,2,i-2)=-dwacos2
1998           Ug2der(2,1,i-2)=-dwacos2
1999           Ug2der(2,2,i-2)=-dwasin2
2000         else
2001           obrot_der(1,i-2)=0.0d0
2002           obrot_der(2,i-2)=0.0d0
2003           Ugder(1,1,i-2)=0.0d0
2004           Ugder(1,2,i-2)=0.0d0
2005           Ugder(2,1,i-2)=0.0d0
2006           Ugder(2,2,i-2)=0.0d0
2007           obrot2_der(1,i-2)=0.0d0
2008           obrot2_der(2,i-2)=0.0d0
2009           Ug2der(1,1,i-2)=0.0d0
2010           Ug2der(1,2,i-2)=0.0d0
2011           Ug2der(2,1,i-2)=0.0d0
2012           Ug2der(2,2,i-2)=0.0d0
2013         endif
2014 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2015         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2016           iti = itype2loc(itype(i-2))
2017         else
2018           iti=nloctyp
2019         endif
2020 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2021         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2022           iti1 = itype2loc(itype(i-1))
2023         else
2024           iti1=nloctyp
2025         endif
2026 cd        write (iout,*) '*******i',i,' iti1',iti
2027 cd        write (iout,*) 'b1',b1(:,iti)
2028 cd        write (iout,*) 'b2',b2(:,iti)
2029 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2030 c        if (i .gt. iatel_s+2) then
2031         if (i .gt. nnt+2) then
2032           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2033 #ifdef NEWCORR
2034           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2035 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2036 #endif
2037 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2038 c     &    EE(1,2,iti),EE(2,2,i)
2039           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2040           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2041 c          write(iout,*) "Macierz EUG",
2042 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2043 c     &    eug(2,2,i-2)
2044           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2045      &    then
2046           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2047           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2048           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2049           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2050           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2051           endif
2052         else
2053           do k=1,2
2054             Ub2(k,i-2)=0.0d0
2055             Ctobr(k,i-2)=0.0d0
2056             Dtobr2(k,i-2)=0.0d0
2057             do l=1,2
2058               EUg(l,k,i-2)=0.0d0
2059               CUg(l,k,i-2)=0.0d0
2060               DUg(l,k,i-2)=0.0d0
2061               DtUg2(l,k,i-2)=0.0d0
2062             enddo
2063           enddo
2064         endif
2065         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2066         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2067         do k=1,2
2068           muder(k,i-2)=Ub2der(k,i-2)
2069         enddo
2070 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2071         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2072           if (itype(i-1).le.ntyp) then
2073             iti1 = itype2loc(itype(i-1))
2074           else
2075             iti1=nloctyp
2076           endif
2077         else
2078           iti1=nloctyp
2079         endif
2080         do k=1,2
2081           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2082         enddo
2083 #ifdef MUOUT
2084         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2085      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2086      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2087      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2088      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2089      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2090 #endif
2091 cd        write (iout,*) 'mu1',mu1(:,i-2)
2092 cd        write (iout,*) 'mu2',mu2(:,i-2)
2093         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2094      &  then
2095         if (calc_grad) then
2096         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2097         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2098         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2099         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2100         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2101         endif
2102 C Vectors and matrices dependent on a single virtual-bond dihedral.
2103         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2104         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2105         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2106         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2107         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2108         if (calc_grad) then
2109         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2110         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2111         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2112         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2113         endif
2114         endif
2115       enddo
2116 C Matrices dependent on two consecutive virtual-bond dihedrals.
2117 C The order of matrices is from left to right.
2118       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2119      &then
2120       do i=2,nres-1
2121         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2122         if (calc_grad) then
2123         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2124         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2125         endif
2126         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2127         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2128         if (calc_grad) then
2129         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2130         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2131         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2132         endif
2133       enddo
2134       endif
2135       return
2136       end
2137 C--------------------------------------------------------------------------
2138       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2139 C
2140 C This subroutine calculates the average interaction energy and its gradient
2141 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2142 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2143 C The potential depends both on the distance of peptide-group centers and on
2144 C the orientation of the CA-CA virtual bonds.
2145 C
2146       implicit real*8 (a-h,o-z)
2147 #ifdef MPI
2148       include 'mpif.h'
2149 #endif
2150       include 'DIMENSIONS'
2151       include 'DIMENSIONS.ZSCOPT'
2152       include 'COMMON.CONTROL'
2153       include 'COMMON.IOUNITS'
2154       include 'COMMON.GEO'
2155       include 'COMMON.VAR'
2156       include 'COMMON.LOCAL'
2157       include 'COMMON.CHAIN'
2158       include 'COMMON.DERIV'
2159       include 'COMMON.INTERACT'
2160       include 'COMMON.CONTACTS'
2161       include 'COMMON.TORSION'
2162       include 'COMMON.VECTORS'
2163       include 'COMMON.FFIELD'
2164       include 'COMMON.TIME1'
2165       include 'COMMON.SPLITELE'
2166       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2167      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2168       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2169      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2170       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2171      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2172      &    num_conti,j1,j2
2173 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2174 #ifdef MOMENT
2175       double precision scal_el /1.0d0/
2176 #else
2177       double precision scal_el /0.5d0/
2178 #endif
2179 C 12/13/98
2180 C 13-go grudnia roku pamietnego...
2181       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2182      &                   0.0d0,1.0d0,0.0d0,
2183      &                   0.0d0,0.0d0,1.0d0/
2184 cd      write(iout,*) 'In EELEC'
2185 cd      do i=1,nloctyp
2186 cd        write(iout,*) 'Type',i
2187 cd        write(iout,*) 'B1',B1(:,i)
2188 cd        write(iout,*) 'B2',B2(:,i)
2189 cd        write(iout,*) 'CC',CC(:,:,i)
2190 cd        write(iout,*) 'DD',DD(:,:,i)
2191 cd        write(iout,*) 'EE',EE(:,:,i)
2192 cd      enddo
2193 cd      call check_vecgrad
2194 cd      stop
2195       if (icheckgrad.eq.1) then
2196         do i=1,nres-1
2197           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2198           do k=1,3
2199             dc_norm(k,i)=dc(k,i)*fac
2200           enddo
2201 c          write (iout,*) 'i',i,' fac',fac
2202         enddo
2203       endif
2204       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2205      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2206      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2207 c        call vec_and_deriv
2208 #ifdef TIMING
2209         time01=MPI_Wtime()
2210 #endif
2211         call set_matrices
2212 #ifdef TIMING
2213         time_mat=time_mat+MPI_Wtime()-time01
2214 #endif
2215       endif
2216 cd      do i=1,nres-1
2217 cd        write (iout,*) 'i=',i
2218 cd        do k=1,3
2219 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2220 cd        enddo
2221 cd        do k=1,3
2222 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2223 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2224 cd        enddo
2225 cd      enddo
2226       t_eelecij=0.0d0
2227       ees=0.0D0
2228       evdw1=0.0D0
2229       eel_loc=0.0d0
2230       eello_turn3=0.0d0
2231       eello_turn4=0.0d0
2232       ind=0
2233       do i=1,nres
2234         num_cont_hb(i)=0
2235       enddo
2236 cd      print '(a)','Enter EELEC'
2237 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2238       do i=1,nres
2239         gel_loc_loc(i)=0.0d0
2240         gcorr_loc(i)=0.0d0
2241       enddo
2242 c
2243 c
2244 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2245 C
2246 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2247 C
2248 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2249       do i=iturn3_start,iturn3_end
2250 c        if (i.le.1) cycle
2251 C        write(iout,*) "tu jest i",i
2252         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2253 C changes suggested by Ana to avoid out of bounds
2254 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2255 c     & .or.((i+4).gt.nres)
2256 c     & .or.((i-1).le.0)
2257 C end of changes by Ana
2258 C dobra zmiana wycofana
2259      &  .or. itype(i+2).eq.ntyp1
2260      &  .or. itype(i+3).eq.ntyp1) cycle
2261 C Adam: Instructions below will switch off existing interactions
2262 c        if(i.gt.1)then
2263 c          if(itype(i-1).eq.ntyp1)cycle
2264 c        end if
2265 c        if(i.LT.nres-3)then
2266 c          if (itype(i+4).eq.ntyp1) cycle
2267 c        end if
2268         dxi=dc(1,i)
2269         dyi=dc(2,i)
2270         dzi=dc(3,i)
2271         dx_normi=dc_norm(1,i)
2272         dy_normi=dc_norm(2,i)
2273         dz_normi=dc_norm(3,i)
2274         xmedi=c(1,i)+0.5d0*dxi
2275         ymedi=c(2,i)+0.5d0*dyi
2276         zmedi=c(3,i)+0.5d0*dzi
2277           xmedi=mod(xmedi,boxxsize)
2278           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2279           ymedi=mod(ymedi,boxysize)
2280           if (ymedi.lt.0) ymedi=ymedi+boxysize
2281           zmedi=mod(zmedi,boxzsize)
2282           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2283         num_conti=0
2284         call eelecij(i,i+2,ees,evdw1,eel_loc)
2285         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2286         num_cont_hb(i)=num_conti
2287       enddo
2288       do i=iturn4_start,iturn4_end
2289         if (i.lt.1) cycle
2290         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2291 C changes suggested by Ana to avoid out of bounds
2292 c     & .or.((i+5).gt.nres)
2293 c     & .or.((i-1).le.0)
2294 C end of changes suggested by Ana
2295      &    .or. itype(i+3).eq.ntyp1
2296      &    .or. itype(i+4).eq.ntyp1
2297 c     &    .or. itype(i+5).eq.ntyp1
2298 c     &    .or. itype(i).eq.ntyp1
2299 c     &    .or. itype(i-1).eq.ntyp1
2300      &                             ) cycle
2301         dxi=dc(1,i)
2302         dyi=dc(2,i)
2303         dzi=dc(3,i)
2304         dx_normi=dc_norm(1,i)
2305         dy_normi=dc_norm(2,i)
2306         dz_normi=dc_norm(3,i)
2307         xmedi=c(1,i)+0.5d0*dxi
2308         ymedi=c(2,i)+0.5d0*dyi
2309         zmedi=c(3,i)+0.5d0*dzi
2310 C Return atom into box, boxxsize is size of box in x dimension
2311 c  194   continue
2312 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2313 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2314 C Condition for being inside the proper box
2315 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2316 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2317 c        go to 194
2318 c        endif
2319 c  195   continue
2320 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2321 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2322 C Condition for being inside the proper box
2323 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2324 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2325 c        go to 195
2326 c        endif
2327 c  196   continue
2328 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2329 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2330 C Condition for being inside the proper box
2331 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2332 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2333 c        go to 196
2334 c        endif
2335           xmedi=mod(xmedi,boxxsize)
2336           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2337           ymedi=mod(ymedi,boxysize)
2338           if (ymedi.lt.0) ymedi=ymedi+boxysize
2339           zmedi=mod(zmedi,boxzsize)
2340           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2341
2342         num_conti=num_cont_hb(i)
2343 c        write(iout,*) "JESTEM W PETLI"
2344         call eelecij(i,i+3,ees,evdw1,eel_loc)
2345         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2346      &   call eturn4(i,eello_turn4)
2347         num_cont_hb(i)=num_conti
2348       enddo   ! i
2349 C Loop over all neighbouring boxes
2350 C      do xshift=-1,1
2351 C      do yshift=-1,1
2352 C      do zshift=-1,1
2353 c
2354 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2355 c
2356 CTU KURWA
2357       do i=iatel_s,iatel_e
2358 C        do i=75,75
2359 c        if (i.le.1) cycle
2360         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2361 C changes suggested by Ana to avoid out of bounds
2362 c     & .or.((i+2).gt.nres)
2363 c     & .or.((i-1).le.0)
2364 C end of changes by Ana
2365 c     &  .or. itype(i+2).eq.ntyp1
2366 c     &  .or. itype(i-1).eq.ntyp1
2367      &                ) cycle
2368         dxi=dc(1,i)
2369         dyi=dc(2,i)
2370         dzi=dc(3,i)
2371         dx_normi=dc_norm(1,i)
2372         dy_normi=dc_norm(2,i)
2373         dz_normi=dc_norm(3,i)
2374         xmedi=c(1,i)+0.5d0*dxi
2375         ymedi=c(2,i)+0.5d0*dyi
2376         zmedi=c(3,i)+0.5d0*dzi
2377           xmedi=mod(xmedi,boxxsize)
2378           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2379           ymedi=mod(ymedi,boxysize)
2380           if (ymedi.lt.0) ymedi=ymedi+boxysize
2381           zmedi=mod(zmedi,boxzsize)
2382           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2383 C          xmedi=xmedi+xshift*boxxsize
2384 C          ymedi=ymedi+yshift*boxysize
2385 C          zmedi=zmedi+zshift*boxzsize
2386
2387 C Return tom into box, boxxsize is size of box in x dimension
2388 c  164   continue
2389 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2390 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2391 C Condition for being inside the proper box
2392 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2393 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2394 c        go to 164
2395 c        endif
2396 c  165   continue
2397 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2398 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2399 C Condition for being inside the proper box
2400 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2401 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2402 c        go to 165
2403 c        endif
2404 c  166   continue
2405 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2406 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2407 cC Condition for being inside the proper box
2408 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2409 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2410 c        go to 166
2411 c        endif
2412
2413 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2414         num_conti=num_cont_hb(i)
2415 C I TU KURWA
2416         do j=ielstart(i),ielend(i)
2417 C          do j=16,17
2418 C          write (iout,*) i,j
2419 C         if (j.le.1) cycle
2420           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2421 C changes suggested by Ana to avoid out of bounds
2422 c     & .or.((j+2).gt.nres)
2423 c     & .or.((j-1).le.0)
2424 C end of changes by Ana
2425 c     & .or.itype(j+2).eq.ntyp1
2426 c     & .or.itype(j-1).eq.ntyp1
2427      &) cycle
2428           call eelecij(i,j,ees,evdw1,eel_loc)
2429         enddo ! j
2430         num_cont_hb(i)=num_conti
2431       enddo   ! i
2432 C     enddo   ! zshift
2433 C      enddo   ! yshift
2434 C      enddo   ! xshift
2435
2436 c      write (iout,*) "Number of loop steps in EELEC:",ind
2437 cd      do i=1,nres
2438 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2439 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2440 cd      enddo
2441 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2442 ccc      eel_loc=eel_loc+eello_turn3
2443 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2444       return
2445       end
2446 C-------------------------------------------------------------------------------
2447       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2448       implicit real*8 (a-h,o-z)
2449       include 'DIMENSIONS'
2450       include 'DIMENSIONS.ZSCOPT'
2451 #ifdef MPI
2452       include "mpif.h"
2453 #endif
2454       include 'COMMON.CONTROL'
2455       include 'COMMON.IOUNITS'
2456       include 'COMMON.GEO'
2457       include 'COMMON.VAR'
2458       include 'COMMON.LOCAL'
2459       include 'COMMON.CHAIN'
2460       include 'COMMON.DERIV'
2461       include 'COMMON.INTERACT'
2462       include 'COMMON.CONTACTS'
2463       include 'COMMON.TORSION'
2464       include 'COMMON.VECTORS'
2465       include 'COMMON.FFIELD'
2466       include 'COMMON.TIME1'
2467       include 'COMMON.SPLITELE'
2468       include 'COMMON.SHIELD'
2469       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2470      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2471       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2472      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2473      &    gmuij2(4),gmuji2(4)
2474       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2475      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2476      &    num_conti,j1,j2
2477 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2478 #ifdef MOMENT
2479       double precision scal_el /1.0d0/
2480 #else
2481       double precision scal_el /0.5d0/
2482 #endif
2483 C 12/13/98
2484 C 13-go grudnia roku pamietnego...
2485       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2486      &                   0.0d0,1.0d0,0.0d0,
2487      &                   0.0d0,0.0d0,1.0d0/
2488        integer xshift,yshift,zshift
2489 c          time00=MPI_Wtime()
2490 cd      write (iout,*) "eelecij",i,j
2491 c          ind=ind+1
2492           iteli=itel(i)
2493           itelj=itel(j)
2494           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2495           aaa=app(iteli,itelj)
2496           bbb=bpp(iteli,itelj)
2497           ael6i=ael6(iteli,itelj)
2498           ael3i=ael3(iteli,itelj)
2499           dxj=dc(1,j)
2500           dyj=dc(2,j)
2501           dzj=dc(3,j)
2502           dx_normj=dc_norm(1,j)
2503           dy_normj=dc_norm(2,j)
2504           dz_normj=dc_norm(3,j)
2505 C          xj=c(1,j)+0.5D0*dxj-xmedi
2506 C          yj=c(2,j)+0.5D0*dyj-ymedi
2507 C          zj=c(3,j)+0.5D0*dzj-zmedi
2508           xj=c(1,j)+0.5D0*dxj
2509           yj=c(2,j)+0.5D0*dyj
2510           zj=c(3,j)+0.5D0*dzj
2511           xj=mod(xj,boxxsize)
2512           if (xj.lt.0) xj=xj+boxxsize
2513           yj=mod(yj,boxysize)
2514           if (yj.lt.0) yj=yj+boxysize
2515           zj=mod(zj,boxzsize)
2516           if (zj.lt.0) zj=zj+boxzsize
2517           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2518       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2519       xj_safe=xj
2520       yj_safe=yj
2521       zj_safe=zj
2522       isubchap=0
2523       do xshift=-1,1
2524       do yshift=-1,1
2525       do zshift=-1,1
2526           xj=xj_safe+xshift*boxxsize
2527           yj=yj_safe+yshift*boxysize
2528           zj=zj_safe+zshift*boxzsize
2529           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2530           if(dist_temp.lt.dist_init) then
2531             dist_init=dist_temp
2532             xj_temp=xj
2533             yj_temp=yj
2534             zj_temp=zj
2535             isubchap=1
2536           endif
2537        enddo
2538        enddo
2539        enddo
2540        if (isubchap.eq.1) then
2541           xj=xj_temp-xmedi
2542           yj=yj_temp-ymedi
2543           zj=zj_temp-zmedi
2544        else
2545           xj=xj_safe-xmedi
2546           yj=yj_safe-ymedi
2547           zj=zj_safe-zmedi
2548        endif
2549 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2550 c  174   continue
2551 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2552 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2553 C Condition for being inside the proper box
2554 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2555 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2556 c        go to 174
2557 c        endif
2558 c  175   continue
2559 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2560 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2561 C Condition for being inside the proper box
2562 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2563 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2564 c        go to 175
2565 c        endif
2566 c  176   continue
2567 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2568 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2569 C Condition for being inside the proper box
2570 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2571 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2572 c        go to 176
2573 c        endif
2574 C        endif !endPBC condintion
2575 C        xj=xj-xmedi
2576 C        yj=yj-ymedi
2577 C        zj=zj-zmedi
2578           rij=xj*xj+yj*yj+zj*zj
2579
2580             sss=sscale(sqrt(rij))
2581             sssgrad=sscagrad(sqrt(rij))
2582 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2583 c     &       " rlamb",rlamb," sss",sss
2584 c            if (sss.gt.0.0d0) then
2585           rrmij=1.0D0/rij
2586           rij=dsqrt(rij)
2587           rmij=1.0D0/rij
2588           r3ij=rrmij*rmij
2589           r6ij=r3ij*r3ij
2590           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2591           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2592           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2593           fac=cosa-3.0D0*cosb*cosg
2594           ev1=aaa*r6ij*r6ij
2595 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2596           if (j.eq.i+2) ev1=scal_el*ev1
2597           ev2=bbb*r6ij
2598           fac3=ael6i*r6ij
2599           fac4=ael3i*r3ij
2600           evdwij=(ev1+ev2)
2601           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2602           el2=fac4*fac
2603 C MARYSIA
2604 C          eesij=(el1+el2)
2605 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2606           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2607           if (shield_mode.gt.0) then
2608 C          fac_shield(i)=0.4
2609 C          fac_shield(j)=0.6
2610           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2611           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2612           eesij=(el1+el2)
2613           ees=ees+eesij
2614           else
2615           fac_shield(i)=1.0
2616           fac_shield(j)=1.0
2617           eesij=(el1+el2)
2618           ees=ees+eesij
2619           endif
2620           evdw1=evdw1+evdwij*sss
2621 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2622 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2623 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2624 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2625
2626           if (energy_dec) then
2627               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2628      &'evdw1',i,j,evdwij
2629      &,iteli,itelj,aaa,evdw1,sss
2630               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2631      &fac_shield(i),fac_shield(j)
2632           endif
2633
2634 C
2635 C Calculate contributions to the Cartesian gradient.
2636 C
2637 #ifdef SPLITELE
2638           facvdw=-6*rrmij*(ev1+evdwij)*sss
2639           facel=-3*rrmij*(el1+eesij)
2640           fac1=fac
2641           erij(1)=xj*rmij
2642           erij(2)=yj*rmij
2643           erij(3)=zj*rmij
2644
2645 *
2646 * Radial derivatives. First process both termini of the fragment (i,j)
2647 *
2648           if (calc_grad) then
2649           ggg(1)=facel*xj
2650           ggg(2)=facel*yj
2651           ggg(3)=facel*zj
2652           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2653      &  (shield_mode.gt.0)) then
2654 C          print *,i,j
2655           do ilist=1,ishield_list(i)
2656            iresshield=shield_list(ilist,i)
2657            do k=1,3
2658            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2659      &      *2.0
2660            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2661      &              rlocshield
2662      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2663             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2664 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2665 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2666 C             if (iresshield.gt.i) then
2667 C               do ishi=i+1,iresshield-1
2668 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2669 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2670 C
2671 C              enddo
2672 C             else
2673 C               do ishi=iresshield,i
2674 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2675 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2676 C
2677 C               enddo
2678 C              endif
2679            enddo
2680           enddo
2681           do ilist=1,ishield_list(j)
2682            iresshield=shield_list(ilist,j)
2683            do k=1,3
2684            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2685      &     *2.0
2686            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2687      &              rlocshield
2688      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2689            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2690
2691 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2692 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2693 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2694 C             if (iresshield.gt.j) then
2695 C               do ishi=j+1,iresshield-1
2696 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2697 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2698 C
2699 C               enddo
2700 C            else
2701 C               do ishi=iresshield,j
2702 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2703 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2704 C               enddo
2705 C              endif
2706            enddo
2707           enddo
2708
2709           do k=1,3
2710             gshieldc(k,i)=gshieldc(k,i)+
2711      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2712             gshieldc(k,j)=gshieldc(k,j)+
2713      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2714             gshieldc(k,i-1)=gshieldc(k,i-1)+
2715      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2716             gshieldc(k,j-1)=gshieldc(k,j-1)+
2717      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2718
2719            enddo
2720            endif
2721 c          do k=1,3
2722 c            ghalf=0.5D0*ggg(k)
2723 c            gelc(k,i)=gelc(k,i)+ghalf
2724 c            gelc(k,j)=gelc(k,j)+ghalf
2725 c          enddo
2726 c 9/28/08 AL Gradient compotents will be summed only at the end
2727 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2728           do k=1,3
2729             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2730 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2731             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2732 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2733 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2734 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2735 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2736 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2737           enddo
2738 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2739
2740 *
2741 * Loop over residues i+1 thru j-1.
2742 *
2743 cgrad          do k=i+1,j-1
2744 cgrad            do l=1,3
2745 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2746 cgrad            enddo
2747 cgrad          enddo
2748           if (sss.gt.0.0) then
2749           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2750           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2751           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2752           else
2753           ggg(1)=0.0
2754           ggg(2)=0.0
2755           ggg(3)=0.0
2756           endif
2757 c          do k=1,3
2758 c            ghalf=0.5D0*ggg(k)
2759 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2760 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2761 c          enddo
2762 c 9/28/08 AL Gradient compotents will be summed only at the end
2763           do k=1,3
2764             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2765             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2766           enddo
2767 *
2768 * Loop over residues i+1 thru j-1.
2769 *
2770 cgrad          do k=i+1,j-1
2771 cgrad            do l=1,3
2772 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2773 cgrad            enddo
2774 cgrad          enddo
2775           endif ! calc_grad
2776 #else
2777 C MARYSIA
2778           facvdw=(ev1+evdwij)*sss
2779           facel=(el1+eesij)
2780           fac1=fac
2781           fac=-3*rrmij*(facvdw+facvdw+facel)
2782           erij(1)=xj*rmij
2783           erij(2)=yj*rmij
2784           erij(3)=zj*rmij
2785 *
2786 * Radial derivatives. First process both termini of the fragment (i,j)
2787 *
2788           if (calc_grad) then
2789           ggg(1)=fac*xj
2790 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2791           ggg(2)=fac*yj
2792 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2793           ggg(3)=fac*zj
2794 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2795 c          do k=1,3
2796 c            ghalf=0.5D0*ggg(k)
2797 c            gelc(k,i)=gelc(k,i)+ghalf
2798 c            gelc(k,j)=gelc(k,j)+ghalf
2799 c          enddo
2800 c 9/28/08 AL Gradient compotents will be summed only at the end
2801           do k=1,3
2802             gelc_long(k,j)=gelc(k,j)+ggg(k)
2803             gelc_long(k,i)=gelc(k,i)-ggg(k)
2804           enddo
2805 *
2806 * Loop over residues i+1 thru j-1.
2807 *
2808 cgrad          do k=i+1,j-1
2809 cgrad            do l=1,3
2810 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2811 cgrad            enddo
2812 cgrad          enddo
2813 c 9/28/08 AL Gradient compotents will be summed only at the end
2814           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2815           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2816           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2817           do k=1,3
2818             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2819             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2820           enddo
2821           endif ! calc_grad
2822 #endif
2823 *
2824 * Angular part
2825 *
2826           if (calc_grad) then
2827           ecosa=2.0D0*fac3*fac1+fac4
2828           fac4=-3.0D0*fac4
2829           fac3=-6.0D0*fac3
2830           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2831           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2832           do k=1,3
2833             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2834             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2835           enddo
2836 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2837 cd   &          (dcosg(k),k=1,3)
2838           do k=1,3
2839             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2840      &      fac_shield(i)**2*fac_shield(j)**2
2841           enddo
2842 c          do k=1,3
2843 c            ghalf=0.5D0*ggg(k)
2844 c            gelc(k,i)=gelc(k,i)+ghalf
2845 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2846 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2847 c            gelc(k,j)=gelc(k,j)+ghalf
2848 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2849 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2850 c          enddo
2851 cgrad          do k=i+1,j-1
2852 cgrad            do l=1,3
2853 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2854 cgrad            enddo
2855 cgrad          enddo
2856 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2857           do k=1,3
2858             gelc(k,i)=gelc(k,i)
2859      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2860      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2861      &           *fac_shield(i)**2*fac_shield(j)**2
2862             gelc(k,j)=gelc(k,j)
2863      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2864      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2865      &           *fac_shield(i)**2*fac_shield(j)**2
2866             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2867             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2868           enddo
2869 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2870
2871 C MARYSIA
2872 c          endif !sscale
2873           endif ! calc_grad
2874           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2875      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2876      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2877 C
2878 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2879 C   energy of a peptide unit is assumed in the form of a second-order
2880 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2881 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2882 C   are computed for EVERY pair of non-contiguous peptide groups.
2883 C
2884
2885           if (j.lt.nres-1) then
2886             j1=j+1
2887             j2=j-1
2888           else
2889             j1=j-1
2890             j2=j-2
2891           endif
2892           kkk=0
2893           lll=0
2894           do k=1,2
2895             do l=1,2
2896               kkk=kkk+1
2897               muij(kkk)=mu(k,i)*mu(l,j)
2898 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2899 #ifdef NEWCORR
2900              if (calc_grad) then
2901              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2902 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2903              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2904              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2905 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2906              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2907              endif
2908 #endif
2909             enddo
2910           enddo
2911 #ifdef DEBUG
2912           write (iout,*) 'EELEC: i',i,' j',j
2913           write (iout,*) 'j',j,' j1',j1,' j2',j2
2914           write(iout,*) 'muij',muij
2915           write (iout,*) "uy",uy(:,i)
2916           write (iout,*) "uz",uz(:,j)
2917           write (iout,*) "erij",erij
2918 #endif
2919           ury=scalar(uy(1,i),erij)
2920           urz=scalar(uz(1,i),erij)
2921           vry=scalar(uy(1,j),erij)
2922           vrz=scalar(uz(1,j),erij)
2923           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2924           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2925           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2926           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2927           fac=dsqrt(-ael6i)*r3ij
2928           a22=a22*fac
2929           a23=a23*fac
2930           a32=a32*fac
2931           a33=a33*fac
2932 cd          write (iout,'(4i5,4f10.5)')
2933 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2934 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2935 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2936 cd     &      uy(:,j),uz(:,j)
2937 cd          write (iout,'(4f10.5)')
2938 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2939 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2940 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2941 cd           write (iout,'(9f10.5/)')
2942 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2943 C Derivatives of the elements of A in virtual-bond vectors
2944           if (calc_grad) then
2945           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2946           do k=1,3
2947             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2948             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2949             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2950             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2951             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2952             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2953             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2954             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2955             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2956             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2957             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2958             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2959           enddo
2960 C Compute radial contributions to the gradient
2961           facr=-3.0d0*rrmij
2962           a22der=a22*facr
2963           a23der=a23*facr
2964           a32der=a32*facr
2965           a33der=a33*facr
2966           agg(1,1)=a22der*xj
2967           agg(2,1)=a22der*yj
2968           agg(3,1)=a22der*zj
2969           agg(1,2)=a23der*xj
2970           agg(2,2)=a23der*yj
2971           agg(3,2)=a23der*zj
2972           agg(1,3)=a32der*xj
2973           agg(2,3)=a32der*yj
2974           agg(3,3)=a32der*zj
2975           agg(1,4)=a33der*xj
2976           agg(2,4)=a33der*yj
2977           agg(3,4)=a33der*zj
2978 C Add the contributions coming from er
2979           fac3=-3.0d0*fac
2980           do k=1,3
2981             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2982             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2983             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2984             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2985           enddo
2986           do k=1,3
2987 C Derivatives in DC(i)
2988 cgrad            ghalf1=0.5d0*agg(k,1)
2989 cgrad            ghalf2=0.5d0*agg(k,2)
2990 cgrad            ghalf3=0.5d0*agg(k,3)
2991 cgrad            ghalf4=0.5d0*agg(k,4)
2992             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2993      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2994             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2995      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2996             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2997      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2998             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2999      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3000 C Derivatives in DC(i+1)
3001             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3002      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3003             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3004      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3005             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3006      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3007             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3008      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3009 C Derivatives in DC(j)
3010             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3011      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3012             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3013      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3014             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3015      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3016             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3017      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3018 C Derivatives in DC(j+1) or DC(nres-1)
3019             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3020      &      -3.0d0*vryg(k,3)*ury)
3021             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3022      &      -3.0d0*vrzg(k,3)*ury)
3023             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3024      &      -3.0d0*vryg(k,3)*urz)
3025             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3026      &      -3.0d0*vrzg(k,3)*urz)
3027 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3028 cgrad              do l=1,4
3029 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3030 cgrad              enddo
3031 cgrad            endif
3032           enddo
3033           endif ! calc_grad
3034           acipa(1,1)=a22
3035           acipa(1,2)=a23
3036           acipa(2,1)=a32
3037           acipa(2,2)=a33
3038           a22=-a22
3039           a23=-a23
3040           if (calc_grad) then
3041           do l=1,2
3042             do k=1,3
3043               agg(k,l)=-agg(k,l)
3044               aggi(k,l)=-aggi(k,l)
3045               aggi1(k,l)=-aggi1(k,l)
3046               aggj(k,l)=-aggj(k,l)
3047               aggj1(k,l)=-aggj1(k,l)
3048             enddo
3049           enddo
3050           endif ! calc_grad
3051           if (j.lt.nres-1) then
3052             a22=-a22
3053             a32=-a32
3054             do l=1,3,2
3055               do k=1,3
3056                 agg(k,l)=-agg(k,l)
3057                 aggi(k,l)=-aggi(k,l)
3058                 aggi1(k,l)=-aggi1(k,l)
3059                 aggj(k,l)=-aggj(k,l)
3060                 aggj1(k,l)=-aggj1(k,l)
3061               enddo
3062             enddo
3063           else
3064             a22=-a22
3065             a23=-a23
3066             a32=-a32
3067             a33=-a33
3068             do l=1,4
3069               do k=1,3
3070                 agg(k,l)=-agg(k,l)
3071                 aggi(k,l)=-aggi(k,l)
3072                 aggi1(k,l)=-aggi1(k,l)
3073                 aggj(k,l)=-aggj(k,l)
3074                 aggj1(k,l)=-aggj1(k,l)
3075               enddo
3076             enddo
3077           endif
3078           ENDIF ! WCORR
3079           IF (wel_loc.gt.0.0d0) THEN
3080 C Contribution to the local-electrostatic energy coming from the i-j pair
3081           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3082      &     +a33*muij(4)
3083 #ifdef DEBUG
3084           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3085      &     " a33",a33
3086           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3087      &     " wel_loc",wel_loc
3088 #endif
3089           if (shield_mode.eq.0) then
3090            fac_shield(i)=1.0
3091            fac_shield(j)=1.0
3092 C          else
3093 C           fac_shield(i)=0.4
3094 C           fac_shield(j)=0.6
3095           endif
3096           eel_loc_ij=eel_loc_ij
3097      &    *fac_shield(i)*fac_shield(j)
3098           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3099      &            'eelloc',i,j,eel_loc_ij
3100 c           if (eel_loc_ij.ne.0)
3101 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3102 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3103
3104           eel_loc=eel_loc+eel_loc_ij
3105 C Now derivative over eel_loc
3106           if (calc_grad) then
3107           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3108      &  (shield_mode.gt.0)) then
3109 C          print *,i,j
3110
3111           do ilist=1,ishield_list(i)
3112            iresshield=shield_list(ilist,i)
3113            do k=1,3
3114            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3115      &                                          /fac_shield(i)
3116 C     &      *2.0
3117            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3118      &              rlocshield
3119      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3120             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3121      &      +rlocshield
3122            enddo
3123           enddo
3124           do ilist=1,ishield_list(j)
3125            iresshield=shield_list(ilist,j)
3126            do k=1,3
3127            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3128      &                                       /fac_shield(j)
3129 C     &     *2.0
3130            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3131      &              rlocshield
3132      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3133            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3134      &             +rlocshield
3135
3136            enddo
3137           enddo
3138
3139           do k=1,3
3140             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3141      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3142             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3143      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3144             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3145      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3146             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3147      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3148            enddo
3149            endif
3150
3151
3152 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3153 c     &                     ' eel_loc_ij',eel_loc_ij
3154 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3155 C Calculate patrial derivative for theta angle
3156 #ifdef NEWCORR
3157          geel_loc_ij=(a22*gmuij1(1)
3158      &     +a23*gmuij1(2)
3159      &     +a32*gmuij1(3)
3160      &     +a33*gmuij1(4))
3161      &    *fac_shield(i)*fac_shield(j)
3162 c         write(iout,*) "derivative over thatai"
3163 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3164 c     &   a33*gmuij1(4)
3165          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3166      &      geel_loc_ij*wel_loc
3167 c         write(iout,*) "derivative over thatai-1"
3168 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3169 c     &   a33*gmuij2(4)
3170          geel_loc_ij=
3171      &     a22*gmuij2(1)
3172      &     +a23*gmuij2(2)
3173      &     +a32*gmuij2(3)
3174      &     +a33*gmuij2(4)
3175          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3176      &      geel_loc_ij*wel_loc
3177      &    *fac_shield(i)*fac_shield(j)
3178
3179 c  Derivative over j residue
3180          geel_loc_ji=a22*gmuji1(1)
3181      &     +a23*gmuji1(2)
3182      &     +a32*gmuji1(3)
3183      &     +a33*gmuji1(4)
3184 c         write(iout,*) "derivative over thataj"
3185 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3186 c     &   a33*gmuji1(4)
3187
3188         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3189      &      geel_loc_ji*wel_loc
3190      &    *fac_shield(i)*fac_shield(j)
3191
3192          geel_loc_ji=
3193      &     +a22*gmuji2(1)
3194      &     +a23*gmuji2(2)
3195      &     +a32*gmuji2(3)
3196      &     +a33*gmuji2(4)
3197 c         write(iout,*) "derivative over thataj-1"
3198 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3199 c     &   a33*gmuji2(4)
3200          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3201      &      geel_loc_ji*wel_loc
3202      &    *fac_shield(i)*fac_shield(j)
3203 #endif
3204 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3205
3206 C Partial derivatives in virtual-bond dihedral angles gamma
3207           if (i.gt.1)
3208      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3209      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3210      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3211      &    *fac_shield(i)*fac_shield(j)
3212
3213           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3214      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3215      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3216      &    *fac_shield(i)*fac_shield(j)
3217 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3218           do l=1,3
3219             ggg(l)=(agg(l,1)*muij(1)+
3220      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3221      &    *fac_shield(i)*fac_shield(j)
3222             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3223             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3224 cgrad            ghalf=0.5d0*ggg(l)
3225 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3226 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3227           enddo
3228 cgrad          do k=i+1,j2
3229 cgrad            do l=1,3
3230 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3231 cgrad            enddo
3232 cgrad          enddo
3233 C Remaining derivatives of eello
3234           do l=1,3
3235             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3236      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3237      &    *fac_shield(i)*fac_shield(j)
3238
3239             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3240      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3241      &    *fac_shield(i)*fac_shield(j)
3242
3243             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3244      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3245      &    *fac_shield(i)*fac_shield(j)
3246
3247             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3248      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3249      &    *fac_shield(i)*fac_shield(j)
3250
3251           enddo
3252           endif ! calc_grad
3253           ENDIF
3254
3255
3256 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3257 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3258           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3259      &       .and. num_conti.le.maxconts) then
3260 c            write (iout,*) i,j," entered corr"
3261 C
3262 C Calculate the contact function. The ith column of the array JCONT will
3263 C contain the numbers of atoms that make contacts with the atom I (of numbers
3264 C greater than I). The arrays FACONT and GACONT will contain the values of
3265 C the contact function and its derivative.
3266 c           r0ij=1.02D0*rpp(iteli,itelj)
3267 c           r0ij=1.11D0*rpp(iteli,itelj)
3268             r0ij=2.20D0*rpp(iteli,itelj)
3269 c           r0ij=1.55D0*rpp(iteli,itelj)
3270             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3271             if (fcont.gt.0.0D0) then
3272               num_conti=num_conti+1
3273               if (num_conti.gt.maxconts) then
3274                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3275      &                         ' will skip next contacts for this conf.'
3276               else
3277                 jcont_hb(num_conti,i)=j
3278 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3279 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3280                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3281      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3282 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3283 C  terms.
3284                 d_cont(num_conti,i)=rij
3285 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3286 C     --- Electrostatic-interaction matrix ---
3287                 a_chuj(1,1,num_conti,i)=a22
3288                 a_chuj(1,2,num_conti,i)=a23
3289                 a_chuj(2,1,num_conti,i)=a32
3290                 a_chuj(2,2,num_conti,i)=a33
3291 C     --- Gradient of rij
3292                 if (calc_grad) then
3293                 do kkk=1,3
3294                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3295                 enddo
3296                 kkll=0
3297                 do k=1,2
3298                   do l=1,2
3299                     kkll=kkll+1
3300                     do m=1,3
3301                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3302                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3303                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3304                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3305                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3306                     enddo
3307                   enddo
3308                 enddo
3309                 endif ! calc_grad
3310                 ENDIF
3311                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3312 C Calculate contact energies
3313                 cosa4=4.0D0*cosa
3314                 wij=cosa-3.0D0*cosb*cosg
3315                 cosbg1=cosb+cosg
3316                 cosbg2=cosb-cosg
3317 c               fac3=dsqrt(-ael6i)/r0ij**3
3318                 fac3=dsqrt(-ael6i)*r3ij
3319 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3320                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3321                 if (ees0tmp.gt.0) then
3322                   ees0pij=dsqrt(ees0tmp)
3323                 else
3324                   ees0pij=0
3325                 endif
3326 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3327                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3328                 if (ees0tmp.gt.0) then
3329                   ees0mij=dsqrt(ees0tmp)
3330                 else
3331                   ees0mij=0
3332                 endif
3333 c               ees0mij=0.0D0
3334                 if (shield_mode.eq.0) then
3335                 fac_shield(i)=1.0d0
3336                 fac_shield(j)=1.0d0
3337                 else
3338                 ees0plist(num_conti,i)=j
3339 C                fac_shield(i)=0.4d0
3340 C                fac_shield(j)=0.6d0
3341                 endif
3342                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3343      &          *fac_shield(i)*fac_shield(j)
3344                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3345      &          *fac_shield(i)*fac_shield(j)
3346 C Diagnostics. Comment out or remove after debugging!
3347 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3348 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3349 c               ees0m(num_conti,i)=0.0D0
3350 C End diagnostics.
3351 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3352 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3353 C Angular derivatives of the contact function
3354
3355                 ees0pij1=fac3/ees0pij
3356                 ees0mij1=fac3/ees0mij
3357                 fac3p=-3.0D0*fac3*rrmij
3358                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3359                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3360 c               ees0mij1=0.0D0
3361                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3362                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3363                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3364                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3365                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3366                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3367                 ecosap=ecosa1+ecosa2
3368                 ecosbp=ecosb1+ecosb2
3369                 ecosgp=ecosg1+ecosg2
3370                 ecosam=ecosa1-ecosa2
3371                 ecosbm=ecosb1-ecosb2
3372                 ecosgm=ecosg1-ecosg2
3373 C Diagnostics
3374 c               ecosap=ecosa1
3375 c               ecosbp=ecosb1
3376 c               ecosgp=ecosg1
3377 c               ecosam=0.0D0
3378 c               ecosbm=0.0D0
3379 c               ecosgm=0.0D0
3380 C End diagnostics
3381                 facont_hb(num_conti,i)=fcont
3382
3383                 if (calc_grad) then
3384                 fprimcont=fprimcont/rij
3385 cd              facont_hb(num_conti,i)=1.0D0
3386 C Following line is for diagnostics.
3387 cd              fprimcont=0.0D0
3388                 do k=1,3
3389                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3390                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3391                 enddo
3392                 do k=1,3
3393                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3394                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3395                 enddo
3396                 gggp(1)=gggp(1)+ees0pijp*xj
3397                 gggp(2)=gggp(2)+ees0pijp*yj
3398                 gggp(3)=gggp(3)+ees0pijp*zj
3399                 gggm(1)=gggm(1)+ees0mijp*xj
3400                 gggm(2)=gggm(2)+ees0mijp*yj
3401                 gggm(3)=gggm(3)+ees0mijp*zj
3402 C Derivatives due to the contact function
3403                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3404                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3405                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3406                 do k=1,3
3407 c
3408 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3409 c          following the change of gradient-summation algorithm.
3410 c
3411 cgrad                  ghalfp=0.5D0*gggp(k)
3412 cgrad                  ghalfm=0.5D0*gggm(k)
3413                   gacontp_hb1(k,num_conti,i)=!ghalfp
3414      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3415      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3416      &          *fac_shield(i)*fac_shield(j)
3417
3418                   gacontp_hb2(k,num_conti,i)=!ghalfp
3419      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3420      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3421      &          *fac_shield(i)*fac_shield(j)
3422
3423                   gacontp_hb3(k,num_conti,i)=gggp(k)
3424      &          *fac_shield(i)*fac_shield(j)
3425
3426                   gacontm_hb1(k,num_conti,i)=!ghalfm
3427      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3428      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3429      &          *fac_shield(i)*fac_shield(j)
3430
3431                   gacontm_hb2(k,num_conti,i)=!ghalfm
3432      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3433      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3434      &          *fac_shield(i)*fac_shield(j)
3435
3436                   gacontm_hb3(k,num_conti,i)=gggm(k)
3437      &          *fac_shield(i)*fac_shield(j)
3438
3439                 enddo
3440 C Diagnostics. Comment out or remove after debugging!
3441 cdiag           do k=1,3
3442 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3443 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3444 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3445 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3446 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3447 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3448 cdiag           enddo
3449
3450                  endif ! calc_grad
3451
3452               ENDIF ! wcorr
3453               endif  ! num_conti.le.maxconts
3454             endif  ! fcont.gt.0
3455           endif    ! j.gt.i+1
3456           if (calc_grad) then
3457           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3458             do k=1,4
3459               do l=1,3
3460                 ghalf=0.5d0*agg(l,k)
3461                 aggi(l,k)=aggi(l,k)+ghalf
3462                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3463                 aggj(l,k)=aggj(l,k)+ghalf
3464               enddo
3465             enddo
3466             if (j.eq.nres-1 .and. i.lt.j-2) then
3467               do k=1,4
3468                 do l=1,3
3469                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3470                 enddo
3471               enddo
3472             endif
3473           endif
3474           endif ! calc_grad
3475 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3476       return
3477       end
3478 C-----------------------------------------------------------------------------
3479       subroutine eturn3(i,eello_turn3)
3480 C Third- and fourth-order contributions from turns
3481       implicit real*8 (a-h,o-z)
3482       include 'DIMENSIONS'
3483       include 'DIMENSIONS.ZSCOPT'
3484       include 'COMMON.IOUNITS'
3485       include 'COMMON.GEO'
3486       include 'COMMON.VAR'
3487       include 'COMMON.LOCAL'
3488       include 'COMMON.CHAIN'
3489       include 'COMMON.DERIV'
3490       include 'COMMON.INTERACT'
3491       include 'COMMON.CONTACTS'
3492       include 'COMMON.TORSION'
3493       include 'COMMON.VECTORS'
3494       include 'COMMON.FFIELD'
3495       include 'COMMON.CONTROL'
3496       include 'COMMON.SHIELD'
3497       dimension ggg(3)
3498       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3499      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3500      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3501      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3502      &  auxgmat2(2,2),auxgmatt2(2,2)
3503       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3504      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3505       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3506      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3507      &    num_conti,j1,j2
3508       j=i+2
3509 c      write (iout,*) "eturn3",i,j,j1,j2
3510       a_temp(1,1)=a22
3511       a_temp(1,2)=a23
3512       a_temp(2,1)=a32
3513       a_temp(2,2)=a33
3514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3515 C
3516 C               Third-order contributions
3517 C
3518 C                 (i+2)o----(i+3)
3519 C                      | |
3520 C                      | |
3521 C                 (i+1)o----i
3522 C
3523 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3524 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3525         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3526 c auxalary matices for theta gradient
3527 c auxalary matrix for i+1 and constant i+2
3528         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3529 c auxalary matrix for i+2 and constant i+1
3530         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3531         call transpose2(auxmat(1,1),auxmat1(1,1))
3532         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3533         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3534         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3535         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3536         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3537         if (shield_mode.eq.0) then
3538         fac_shield(i)=1.0
3539         fac_shield(j)=1.0
3540 C        else
3541 C        fac_shield(i)=0.4
3542 C        fac_shield(j)=0.6
3543         endif
3544         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3545      &  *fac_shield(i)*fac_shield(j)
3546         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3547      &  *fac_shield(i)*fac_shield(j)
3548         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3549      &    eello_t3
3550         if (calc_grad) then
3551 C#ifdef NEWCORR
3552 C Derivatives in theta
3553         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3554      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3555      &   *fac_shield(i)*fac_shield(j)
3556         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3557      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3558      &   *fac_shield(i)*fac_shield(j)
3559 C#endif
3560
3561 C Derivatives in shield mode
3562           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3563      &  (shield_mode.gt.0)) then
3564 C          print *,i,j
3565
3566           do ilist=1,ishield_list(i)
3567            iresshield=shield_list(ilist,i)
3568            do k=1,3
3569            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3570 C     &      *2.0
3571            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3572      &              rlocshield
3573      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3574             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3575      &      +rlocshield
3576            enddo
3577           enddo
3578           do ilist=1,ishield_list(j)
3579            iresshield=shield_list(ilist,j)
3580            do k=1,3
3581            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3582 C     &     *2.0
3583            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3584      &              rlocshield
3585      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3586            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3587      &             +rlocshield
3588
3589            enddo
3590           enddo
3591
3592           do k=1,3
3593             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3594      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3595             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3596      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3597             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3598      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3599             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3600      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3601            enddo
3602            endif
3603
3604 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3605 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3606 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3607 cd     &    ' eello_turn3_num',4*eello_turn3_num
3608 C Derivatives in gamma(i)
3609         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3610         call transpose2(auxmat2(1,1),auxmat3(1,1))
3611         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3612         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3613      &   *fac_shield(i)*fac_shield(j)
3614 C Derivatives in gamma(i+1)
3615         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3616         call transpose2(auxmat2(1,1),auxmat3(1,1))
3617         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3618         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3619      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3620      &   *fac_shield(i)*fac_shield(j)
3621 C Cartesian derivatives
3622         do l=1,3
3623 c            ghalf1=0.5d0*agg(l,1)
3624 c            ghalf2=0.5d0*agg(l,2)
3625 c            ghalf3=0.5d0*agg(l,3)
3626 c            ghalf4=0.5d0*agg(l,4)
3627           a_temp(1,1)=aggi(l,1)!+ghalf1
3628           a_temp(1,2)=aggi(l,2)!+ghalf2
3629           a_temp(2,1)=aggi(l,3)!+ghalf3
3630           a_temp(2,2)=aggi(l,4)!+ghalf4
3631           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3632           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3633      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3634      &   *fac_shield(i)*fac_shield(j)
3635
3636           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3637           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3638           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3639           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3640           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3641           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3642      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3643      &   *fac_shield(i)*fac_shield(j)
3644           a_temp(1,1)=aggj(l,1)!+ghalf1
3645           a_temp(1,2)=aggj(l,2)!+ghalf2
3646           a_temp(2,1)=aggj(l,3)!+ghalf3
3647           a_temp(2,2)=aggj(l,4)!+ghalf4
3648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3649           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3650      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3651      &   *fac_shield(i)*fac_shield(j)
3652           a_temp(1,1)=aggj1(l,1)
3653           a_temp(1,2)=aggj1(l,2)
3654           a_temp(2,1)=aggj1(l,3)
3655           a_temp(2,2)=aggj1(l,4)
3656           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3657           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3658      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3659      &   *fac_shield(i)*fac_shield(j)
3660         enddo
3661
3662         endif ! calc_grad
3663
3664       return
3665       end
3666 C-------------------------------------------------------------------------------
3667       subroutine eturn4(i,eello_turn4)
3668 C Third- and fourth-order contributions from turns
3669       implicit real*8 (a-h,o-z)
3670       include 'DIMENSIONS'
3671       include 'DIMENSIONS.ZSCOPT'
3672       include 'COMMON.IOUNITS'
3673       include 'COMMON.GEO'
3674       include 'COMMON.VAR'
3675       include 'COMMON.LOCAL'
3676       include 'COMMON.CHAIN'
3677       include 'COMMON.DERIV'
3678       include 'COMMON.INTERACT'
3679       include 'COMMON.CONTACTS'
3680       include 'COMMON.TORSION'
3681       include 'COMMON.VECTORS'
3682       include 'COMMON.FFIELD'
3683       include 'COMMON.CONTROL'
3684       include 'COMMON.SHIELD'
3685       dimension ggg(3)
3686       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3687      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3688      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3689      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3690      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3691      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3692      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3693       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3694      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3695       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3696      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3697      &    num_conti,j1,j2
3698       j=i+3
3699 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3700 C
3701 C               Fourth-order contributions
3702 C
3703 C                 (i+3)o----(i+4)
3704 C                     /  |
3705 C               (i+2)o   |
3706 C                     \  |
3707 C                 (i+1)o----i
3708 C
3709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3710 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3711 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3712 c        write(iout,*)"WCHODZE W PROGRAM"
3713         a_temp(1,1)=a22
3714         a_temp(1,2)=a23
3715         a_temp(2,1)=a32
3716         a_temp(2,2)=a33
3717         iti1=itype2loc(itype(i+1))
3718         iti2=itype2loc(itype(i+2))
3719         iti3=itype2loc(itype(i+3))
3720 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3721         call transpose2(EUg(1,1,i+1),e1t(1,1))
3722         call transpose2(Eug(1,1,i+2),e2t(1,1))
3723         call transpose2(Eug(1,1,i+3),e3t(1,1))
3724 C Ematrix derivative in theta
3725         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3726         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3727         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3728         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3729 c       eta1 in derivative theta
3730         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3731         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3732 c       auxgvec is derivative of Ub2 so i+3 theta
3733         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3734 c       auxalary matrix of E i+1
3735         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3736 c        s1=0.0
3737 c        gs1=0.0
3738         s1=scalar2(b1(1,i+2),auxvec(1))
3739 c derivative of theta i+2 with constant i+3
3740         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3741 c derivative of theta i+2 with constant i+2
3742         gs32=scalar2(b1(1,i+2),auxgvec(1))
3743 c derivative of E matix in theta of i+1
3744         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3745
3746         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3747 c       ea31 in derivative theta
3748         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3749         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3750 c auxilary matrix auxgvec of Ub2 with constant E matirx
3751         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3752 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3753         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3754
3755 c        s2=0.0
3756 c        gs2=0.0
3757         s2=scalar2(b1(1,i+1),auxvec(1))
3758 c derivative of theta i+1 with constant i+3
3759         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3760 c derivative of theta i+2 with constant i+1
3761         gs21=scalar2(b1(1,i+1),auxgvec(1))
3762 c derivative of theta i+3 with constant i+1
3763         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3764 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3765 c     &  gtb1(1,i+1)
3766         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3767 c two derivatives over diffetent matrices
3768 c gtae3e2 is derivative over i+3
3769         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3770 c ae3gte2 is derivative over i+2
3771         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3772         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3773 c three possible derivative over theta E matices
3774 c i+1
3775         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3776 c i+2
3777         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3778 c i+3
3779         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3780         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3781
3782         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3783         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3784         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3785         if (shield_mode.eq.0) then
3786         fac_shield(i)=1.0
3787         fac_shield(j)=1.0
3788 C        else
3789 C        fac_shield(i)=0.6
3790 C        fac_shield(j)=0.4
3791         endif
3792         eello_turn4=eello_turn4-(s1+s2+s3)
3793      &  *fac_shield(i)*fac_shield(j)
3794         eello_t4=-(s1+s2+s3)
3795      &  *fac_shield(i)*fac_shield(j)
3796 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3797         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3798      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3799 C Now derivative over shield:
3800           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3801      &  (shield_mode.gt.0)) then
3802 C          print *,i,j
3803
3804           do ilist=1,ishield_list(i)
3805            iresshield=shield_list(ilist,i)
3806            do k=1,3
3807            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3808 C     &      *2.0
3809            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3810      &              rlocshield
3811      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3812             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3813      &      +rlocshield
3814            enddo
3815           enddo
3816           do ilist=1,ishield_list(j)
3817            iresshield=shield_list(ilist,j)
3818            do k=1,3
3819            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3820 C     &     *2.0
3821            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3822      &              rlocshield
3823      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3824            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3825      &             +rlocshield
3826
3827            enddo
3828           enddo
3829
3830           do k=1,3
3831             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3832      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3833             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3834      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3835             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3836      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3837             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3838      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3839            enddo
3840            endif
3841 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3842 cd     &    ' eello_turn4_num',8*eello_turn4_num
3843 #ifdef NEWCORR
3844         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3845      &                  -(gs13+gsE13+gsEE1)*wturn4
3846      &  *fac_shield(i)*fac_shield(j)
3847         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3848      &                    -(gs23+gs21+gsEE2)*wturn4
3849      &  *fac_shield(i)*fac_shield(j)
3850
3851         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3852      &                    -(gs32+gsE31+gsEE3)*wturn4
3853      &  *fac_shield(i)*fac_shield(j)
3854
3855 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3856 c     &   gs2
3857 #endif
3858         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3859      &      'eturn4',i,j,-(s1+s2+s3)
3860 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3861 c     &    ' eello_turn4_num',8*eello_turn4_num
3862 C Derivatives in gamma(i)
3863         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3864         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3865         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3866         s1=scalar2(b1(1,i+2),auxvec(1))
3867         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3868         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3869         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3870      &  *fac_shield(i)*fac_shield(j)
3871 C Derivatives in gamma(i+1)
3872         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3873         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3874         s2=scalar2(b1(1,i+1),auxvec(1))
3875         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3876         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3877         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3878         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3879      &  *fac_shield(i)*fac_shield(j)
3880 C Derivatives in gamma(i+2)
3881         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3882         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3883         s1=scalar2(b1(1,i+2),auxvec(1))
3884         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3885         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3886         s2=scalar2(b1(1,i+1),auxvec(1))
3887         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3888         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3889         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3890         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3891      &  *fac_shield(i)*fac_shield(j)
3892         if (calc_grad) then
3893 C Cartesian derivatives
3894 C Derivatives of this turn contributions in DC(i+2)
3895         if (j.lt.nres-1) then
3896           do l=1,3
3897             a_temp(1,1)=agg(l,1)
3898             a_temp(1,2)=agg(l,2)
3899             a_temp(2,1)=agg(l,3)
3900             a_temp(2,2)=agg(l,4)
3901             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3902             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3903             s1=scalar2(b1(1,i+2),auxvec(1))
3904             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3905             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3906             s2=scalar2(b1(1,i+1),auxvec(1))
3907             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3908             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3909             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3910             ggg(l)=-(s1+s2+s3)
3911             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3912      &  *fac_shield(i)*fac_shield(j)
3913           enddo
3914         endif
3915 C Remaining derivatives of this turn contribution
3916         do l=1,3
3917           a_temp(1,1)=aggi(l,1)
3918           a_temp(1,2)=aggi(l,2)
3919           a_temp(2,1)=aggi(l,3)
3920           a_temp(2,2)=aggi(l,4)
3921           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923           s1=scalar2(b1(1,i+2),auxvec(1))
3924           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926           s2=scalar2(b1(1,i+1),auxvec(1))
3927           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3931      &  *fac_shield(i)*fac_shield(j)
3932           a_temp(1,1)=aggi1(l,1)
3933           a_temp(1,2)=aggi1(l,2)
3934           a_temp(2,1)=aggi1(l,3)
3935           a_temp(2,2)=aggi1(l,4)
3936           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3937           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3938           s1=scalar2(b1(1,i+2),auxvec(1))
3939           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3940           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3941           s2=scalar2(b1(1,i+1),auxvec(1))
3942           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3943           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3944           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3945           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3946      &  *fac_shield(i)*fac_shield(j)
3947           a_temp(1,1)=aggj(l,1)
3948           a_temp(1,2)=aggj(l,2)
3949           a_temp(2,1)=aggj(l,3)
3950           a_temp(2,2)=aggj(l,4)
3951           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3952           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3953           s1=scalar2(b1(1,i+2),auxvec(1))
3954           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3955           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3956           s2=scalar2(b1(1,i+1),auxvec(1))
3957           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3958           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3959           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3960           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3961      &  *fac_shield(i)*fac_shield(j)
3962           a_temp(1,1)=aggj1(l,1)
3963           a_temp(1,2)=aggj1(l,2)
3964           a_temp(2,1)=aggj1(l,3)
3965           a_temp(2,2)=aggj1(l,4)
3966           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3967           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3968           s1=scalar2(b1(1,i+2),auxvec(1))
3969           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3970           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3971           s2=scalar2(b1(1,i+1),auxvec(1))
3972           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3973           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3974           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3975 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3976           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3977      &  *fac_shield(i)*fac_shield(j)
3978         enddo
3979
3980         endif ! calc_grad
3981
3982       return
3983       end
3984 C-----------------------------------------------------------------------------
3985       subroutine vecpr(u,v,w)
3986       implicit real*8(a-h,o-z)
3987       dimension u(3),v(3),w(3)
3988       w(1)=u(2)*v(3)-u(3)*v(2)
3989       w(2)=-u(1)*v(3)+u(3)*v(1)
3990       w(3)=u(1)*v(2)-u(2)*v(1)
3991       return
3992       end
3993 C-----------------------------------------------------------------------------
3994       subroutine unormderiv(u,ugrad,unorm,ungrad)
3995 C This subroutine computes the derivatives of a normalized vector u, given
3996 C the derivatives computed without normalization conditions, ugrad. Returns
3997 C ungrad.
3998       implicit none
3999       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4000       double precision vec(3)
4001       double precision scalar
4002       integer i,j
4003 c      write (2,*) 'ugrad',ugrad
4004 c      write (2,*) 'u',u
4005       do i=1,3
4006         vec(i)=scalar(ugrad(1,i),u(1))
4007       enddo
4008 c      write (2,*) 'vec',vec
4009       do i=1,3
4010         do j=1,3
4011           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4012         enddo
4013       enddo
4014 c      write (2,*) 'ungrad',ungrad
4015       return
4016       end
4017 C-----------------------------------------------------------------------------
4018       subroutine escp(evdw2,evdw2_14)
4019 C
4020 C This subroutine calculates the excluded-volume interaction energy between
4021 C peptide-group centers and side chains and its gradient in virtual-bond and
4022 C side-chain vectors.
4023 C
4024       implicit real*8 (a-h,o-z)
4025       include 'DIMENSIONS'
4026       include 'DIMENSIONS.ZSCOPT'
4027       include 'COMMON.CONTROL'
4028       include 'COMMON.GEO'
4029       include 'COMMON.VAR'
4030       include 'COMMON.LOCAL'
4031       include 'COMMON.CHAIN'
4032       include 'COMMON.DERIV'
4033       include 'COMMON.INTERACT'
4034       include 'COMMON.FFIELD'
4035       include 'COMMON.IOUNITS'
4036       dimension ggg(3)
4037       evdw2=0.0D0
4038       evdw2_14=0.0d0
4039 cd    print '(a)','Enter ESCP'
4040 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4041 c     &  ' scal14',scal14
4042       do i=iatscp_s,iatscp_e
4043         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4044         iteli=itel(i)
4045 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4046 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4047         if (iteli.eq.0) goto 1225
4048         xi=0.5D0*(c(1,i)+c(1,i+1))
4049         yi=0.5D0*(c(2,i)+c(2,i+1))
4050         zi=0.5D0*(c(3,i)+c(3,i+1))
4051 C Returning the ith atom to box
4052           xi=mod(xi,boxxsize)
4053           if (xi.lt.0) xi=xi+boxxsize
4054           yi=mod(yi,boxysize)
4055           if (yi.lt.0) yi=yi+boxysize
4056           zi=mod(zi,boxzsize)
4057           if (zi.lt.0) zi=zi+boxzsize
4058         do iint=1,nscp_gr(i)
4059
4060         do j=iscpstart(i,iint),iscpend(i,iint)
4061           itypj=iabs(itype(j))
4062           if (itypj.eq.ntyp1) cycle
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)
4069           yj=c(2,j)
4070           zj=c(3,j)
4071 C returning the jth atom to box
4072           xj=mod(xj,boxxsize)
4073           if (xj.lt.0) xj=xj+boxxsize
4074           yj=mod(yj,boxysize)
4075           if (yj.lt.0) yj=yj+boxysize
4076           zj=mod(zj,boxzsize)
4077           if (zj.lt.0) zj=zj+boxzsize
4078       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4079       xj_safe=xj
4080       yj_safe=yj
4081       zj_safe=zj
4082       subchap=0
4083 C Finding the closest jth atom
4084       do xshift=-1,1
4085       do yshift=-1,1
4086       do zshift=-1,1
4087           xj=xj_safe+xshift*boxxsize
4088           yj=yj_safe+yshift*boxysize
4089           zj=zj_safe+zshift*boxzsize
4090           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4091           if(dist_temp.lt.dist_init) then
4092             dist_init=dist_temp
4093             xj_temp=xj
4094             yj_temp=yj
4095             zj_temp=zj
4096             subchap=1
4097           endif
4098        enddo
4099        enddo
4100        enddo
4101        if (subchap.eq.1) then
4102           xj=xj_temp-xi
4103           yj=yj_temp-yi
4104           zj=zj_temp-zi
4105        else
4106           xj=xj_safe-xi
4107           yj=yj_safe-yi
4108           zj=zj_safe-zi
4109        endif
4110           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4111 C sss is scaling function for smoothing the cutoff gradient otherwise
4112 C the gradient would not be continuouse
4113           sss=sscale(1.0d0/(dsqrt(rrij)))
4114           if (sss.le.0.0d0) cycle
4115           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4116           fac=rrij**expon2
4117           e1=fac*fac*aad(itypj,iteli)
4118           e2=fac*bad(itypj,iteli)
4119           if (iabs(j-i) .le. 2) then
4120             e1=scal14*e1
4121             e2=scal14*e2
4122             evdw2_14=evdw2_14+(e1+e2)*sss
4123           endif
4124           evdwij=e1+e2
4125 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4126 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4127 c     &       bad(itypj,iteli)
4128           evdw2=evdw2+evdwij*sss
4129           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4130      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4131      &       bad(itypj,iteli)
4132
4133           if (calc_grad) then
4134 C
4135 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4136 C
4137           fac=-(evdwij+e1)*rrij*sss
4138           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4139           ggg(1)=xj*fac
4140           ggg(2)=yj*fac
4141           ggg(3)=zj*fac
4142           if (j.lt.i) then
4143 cd          write (iout,*) 'j<i'
4144 C Uncomment following three lines for SC-p interactions
4145 c           do k=1,3
4146 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4147 c           enddo
4148           else
4149 cd          write (iout,*) 'j>i'
4150             do k=1,3
4151               ggg(k)=-ggg(k)
4152 C Uncomment following line for SC-p interactions
4153 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4154             enddo
4155           endif
4156           do k=1,3
4157             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4158           enddo
4159           kstart=min0(i+1,j)
4160           kend=max0(i-1,j-1)
4161 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4162 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4163           do k=kstart,kend
4164             do l=1,3
4165               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4166             enddo
4167           enddo
4168           endif ! calc_grad
4169         enddo
4170         enddo ! iint
4171  1225   continue
4172       enddo ! i
4173       do i=1,nct
4174         do j=1,3
4175           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4176           gradx_scp(j,i)=expon*gradx_scp(j,i)
4177         enddo
4178       enddo
4179 C******************************************************************************
4180 C
4181 C                              N O T E !!!
4182 C
4183 C To save time the factor EXPON has been extracted from ALL components
4184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4185 C use!
4186 C
4187 C******************************************************************************
4188       return
4189       end
4190 C--------------------------------------------------------------------------
4191       subroutine edis(ehpb)
4192 C
4193 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4194 C
4195       implicit real*8 (a-h,o-z)
4196       include 'DIMENSIONS'
4197       include 'DIMENSIONS.ZSCOPT'
4198       include 'COMMON.SBRIDGE'
4199       include 'COMMON.CHAIN'
4200       include 'COMMON.DERIV'
4201       include 'COMMON.VAR'
4202       include 'COMMON.INTERACT'
4203       include 'COMMON.CONTROL'
4204       include 'COMMON.IOUNITS'
4205       dimension ggg(3)
4206       ehpb=0.0D0
4207 c      write (iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4208 c      write (iout,*)'link_start=',link_start,' link_end=',link_end
4209 C      write(iout,*) link_end, "link_end"
4210       if (link_end.eq.0) return
4211       do i=link_start,link_end
4212 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4213 C CA-CA distance used in regularization of structure.
4214         ii=ihpb(i)
4215         jj=jhpb(i)
4216 C iii and jjj point to the residues for which the distance is assigned.
4217         if (ii.gt.nres) then
4218           iii=ii-nres
4219           jjj=jj-nres
4220         else
4221           iii=ii
4222           jjj=jj
4223         endif
4224 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4225 C    distance and angle dependent SS bond potential.
4226 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4227 C     & iabs(itype(jjj)).eq.1) then
4228 C       write(iout,*) constr_dist,"const"
4229        if (.not.dyn_ss .and. i.le.nss) then
4230          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4231      & iabs(itype(jjj)).eq.1) then
4232           call ssbond_ene(iii,jjj,eij)
4233           ehpb=ehpb+2*eij
4234            endif !ii.gt.neres
4235         else if (ii.gt.nres .and. jj.gt.nres) then
4236 c Restraints from contact prediction
4237           dd=dist(ii,jj)
4238           if (constr_dist.eq.11) then
4239 C            ehpb=ehpb+fordepth(i)**4.0d0
4240 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4241             ehpb=ehpb+fordepth(i)!**4.0d0
4242      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4243            if (energy_dec) write (iout,'(a6,2i5,6f10.3)') "edisl",ii,jj,
4244      &    dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),ehpb
4245             fac=fordepth(i)!**4.0d0
4246      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4247 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4248 C     &    ehpb,fordepth(i),dd
4249 C            write(iout,*) ehpb,"atu?"
4250 C            ehpb,"tu?"
4251 C            fac=fordepth(i)**4.0d0
4252 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4253            else
4254           if (dhpb1(i).gt.0.0d0) then
4255             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4256             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4257 c            write (iout,*) "beta nmr",
4258 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4259           else
4260             dd=dist(ii,jj)
4261             rdis=dd-dhpb(i)
4262 C Get the force constant corresponding to this distance.
4263             waga=forcon(i)
4264 C Calculate the contribution to energy.
4265             ehpb=ehpb+waga*rdis*rdis
4266 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4267 C
4268 C Evaluate gradient.
4269 C
4270             fac=waga*rdis/dd
4271           endif !end dhpb1(i).gt.0
4272           endif !end const_dist=11
4273           do j=1,3
4274             ggg(j)=fac*(c(j,jj)-c(j,ii))
4275           enddo
4276           do j=1,3
4277             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4278             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4279           enddo
4280           do k=1,3
4281             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4282             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4283           enddo
4284         else !ii.gt.nres
4285 C          write(iout,*) "before"
4286           dd=dist(ii,jj)
4287 C          write(iout,*) "after",dd
4288           if (constr_dist.eq.11) then
4289             ehpb=ehpb+fordepth(i)!**4.0d0
4290      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4291            if (energy_dec) write (iout,'(a6,2i5,6f10.3)') "edisl",ii,jj,
4292      &    dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),ehpb
4293             fac=fordepth(i)!**4.0d0
4294      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4295 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
4296 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
4297 C            print *,ehpb,"tu?"
4298 C            write(iout,*) ehpb,"btu?",
4299 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
4300 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4301 C     &    ehpb,fordepth(i),dd
4302            else
4303           if (dhpb1(i).gt.0.0d0) then
4304             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4305             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4306 c            write (iout,*) "alph nmr",
4307 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4308           else
4309             rdis=dd-dhpb(i)
4310 C Get the force constant corresponding to this distance.
4311             waga=forcon(i)
4312 C Calculate the contribution to energy.
4313             ehpb=ehpb+waga*rdis*rdis
4314 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4315 C
4316 C Evaluate gradient.
4317 C
4318             fac=waga*rdis/dd
4319           endif
4320           endif
4321
4322         do j=1,3
4323           ggg(j)=fac*(c(j,jj)-c(j,ii))
4324         enddo
4325 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4326 C If this is a SC-SC distance, we need to calculate the contributions to the
4327 C Cartesian gradient in the SC vectors (ghpbx).
4328         if (iii.lt.ii) then
4329           do j=1,3
4330             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4331             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4332           enddo
4333         endif
4334         do j=iii,jjj-1
4335           do k=1,3
4336             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4337           enddo
4338         enddo
4339         endif
4340       enddo
4341       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4342       return
4343       end
4344 C--------------------------------------------------------------------------
4345       subroutine ssbond_ene(i,j,eij)
4346 C
4347 C Calculate the distance and angle dependent SS-bond potential energy
4348 C using a free-energy function derived based on RHF/6-31G** ab initio
4349 C calculations of diethyl disulfide.
4350 C
4351 C A. Liwo and U. Kozlowska, 11/24/03
4352 C
4353       implicit real*8 (a-h,o-z)
4354       include 'DIMENSIONS'
4355       include 'DIMENSIONS.ZSCOPT'
4356       include 'COMMON.SBRIDGE'
4357       include 'COMMON.CHAIN'
4358       include 'COMMON.DERIV'
4359       include 'COMMON.LOCAL'
4360       include 'COMMON.INTERACT'
4361       include 'COMMON.VAR'
4362       include 'COMMON.IOUNITS'
4363       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4364       itypi=iabs(itype(i))
4365       xi=c(1,nres+i)
4366       yi=c(2,nres+i)
4367       zi=c(3,nres+i)
4368       dxi=dc_norm(1,nres+i)
4369       dyi=dc_norm(2,nres+i)
4370       dzi=dc_norm(3,nres+i)
4371       dsci_inv=dsc_inv(itypi)
4372       itypj=iabs(itype(j))
4373       dscj_inv=dsc_inv(itypj)
4374       xj=c(1,nres+j)-xi
4375       yj=c(2,nres+j)-yi
4376       zj=c(3,nres+j)-zi
4377       dxj=dc_norm(1,nres+j)
4378       dyj=dc_norm(2,nres+j)
4379       dzj=dc_norm(3,nres+j)
4380       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4381       rij=dsqrt(rrij)
4382       erij(1)=xj*rij
4383       erij(2)=yj*rij
4384       erij(3)=zj*rij
4385       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4386       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4387       om12=dxi*dxj+dyi*dyj+dzi*dzj
4388       do k=1,3
4389         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4390         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4391       enddo
4392       rij=1.0d0/rij
4393       deltad=rij-d0cm
4394       deltat1=1.0d0-om1
4395       deltat2=1.0d0+om2
4396       deltat12=om2-om1+2.0d0
4397       cosphi=om12-om1*om2
4398       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4399      &  +akct*deltad*deltat12
4400      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4401 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4402 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4403 c     &  " deltat12",deltat12," eij",eij
4404       ed=2*akcm*deltad+akct*deltat12
4405       pom1=akct*deltad
4406       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4407       eom1=-2*akth*deltat1-pom1-om2*pom2
4408       eom2= 2*akth*deltat2+pom1-om1*pom2
4409       eom12=pom2
4410       do k=1,3
4411         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4412       enddo
4413       do k=1,3
4414         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4415      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4416         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4417      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4418       enddo
4419 C
4420 C Calculate the components of the gradient in DC and X
4421 C
4422       do k=i,j-1
4423         do l=1,3
4424           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4425         enddo
4426       enddo
4427       return
4428       end
4429 C--------------------------------------------------------------------------
4430       subroutine ebond(estr)
4431 c
4432 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4433 c
4434       implicit real*8 (a-h,o-z)
4435       include 'DIMENSIONS'
4436       include 'DIMENSIONS.ZSCOPT'
4437       include 'COMMON.LOCAL'
4438       include 'COMMON.GEO'
4439       include 'COMMON.INTERACT'
4440       include 'COMMON.DERIV'
4441       include 'COMMON.VAR'
4442       include 'COMMON.CHAIN'
4443       include 'COMMON.IOUNITS'
4444       include 'COMMON.NAMES'
4445       include 'COMMON.FFIELD'
4446       include 'COMMON.CONTROL'
4447       double precision u(3),ud(3)
4448       estr=0.0d0
4449       estr1=0.0d0
4450 c      write (iout,*) "distchainmax",distchainmax
4451       do i=nnt+1,nct
4452         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4453 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4454 C          do j=1,3
4455 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4456 C     &      *dc(j,i-1)/vbld(i)
4457 C          enddo
4458 C          if (energy_dec) write(iout,*)
4459 C     &       "estr1",i,vbld(i),distchainmax,
4460 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4461 C        else
4462          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4463         diff = vbld(i)-vbldpDUM
4464 C         write(iout,*) i,diff
4465          else
4466           diff = vbld(i)-vbldp0
4467 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4468          endif
4469           estr=estr+diff*diff
4470           do j=1,3
4471             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4472           enddo
4473 C        endif
4474 C        write (iout,'(a7,i5,4f7.3)')
4475 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4476       enddo
4477       estr=0.5d0*AKP*estr+estr1
4478 c
4479 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4480 c
4481       do i=nnt,nct
4482         iti=iabs(itype(i))
4483         if (iti.ne.10 .and. iti.ne.ntyp1) then
4484           nbi=nbondterm(iti)
4485           if (nbi.eq.1) then
4486             diff=vbld(i+nres)-vbldsc0(1,iti)
4487 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4488 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4489             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4490             do j=1,3
4491               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4492             enddo
4493           else
4494             do j=1,nbi
4495               diff=vbld(i+nres)-vbldsc0(j,iti)
4496               ud(j)=aksc(j,iti)*diff
4497               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4498             enddo
4499             uprod=u(1)
4500             do j=2,nbi
4501               uprod=uprod*u(j)
4502             enddo
4503             usum=0.0d0
4504             usumsqder=0.0d0
4505             do j=1,nbi
4506               uprod1=1.0d0
4507               uprod2=1.0d0
4508               do k=1,nbi
4509                 if (k.ne.j) then
4510                   uprod1=uprod1*u(k)
4511                   uprod2=uprod2*u(k)*u(k)
4512                 endif
4513               enddo
4514               usum=usum+uprod1
4515               usumsqder=usumsqder+ud(j)*uprod2
4516             enddo
4517 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4518 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4519             estr=estr+uprod/usum
4520             do j=1,3
4521              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4522             enddo
4523           endif
4524         endif
4525       enddo
4526       return
4527       end
4528 #ifdef CRYST_THETA
4529 C--------------------------------------------------------------------------
4530       subroutine ebend(etheta,ethetacnstr)
4531 C
4532 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4533 C angles gamma and its derivatives in consecutive thetas and gammas.
4534 C
4535       implicit real*8 (a-h,o-z)
4536       include 'DIMENSIONS'
4537       include 'DIMENSIONS.ZSCOPT'
4538       include 'COMMON.LOCAL'
4539       include 'COMMON.GEO'
4540       include 'COMMON.INTERACT'
4541       include 'COMMON.DERIV'
4542       include 'COMMON.VAR'
4543       include 'COMMON.CHAIN'
4544       include 'COMMON.IOUNITS'
4545       include 'COMMON.NAMES'
4546       include 'COMMON.FFIELD'
4547       include 'COMMON.TORCNSTR'
4548       common /calcthet/ term1,term2,termm,diffak,ratak,
4549      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4550      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4551       double precision y(2),z(2)
4552       delta=0.02d0*pi
4553 c      time11=dexp(-2*time)
4554 c      time12=1.0d0
4555       etheta=0.0D0
4556 c      write (iout,*) "nres",nres
4557 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4558 c      write (iout,*) ithet_start,ithet_end
4559       do i=ithet_start,ithet_end
4560 C        if (itype(i-1).eq.ntyp1) cycle
4561         if (i.le.2) cycle
4562         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4563      &  .or.itype(i).eq.ntyp1) cycle
4564 C Zero the energy function and its derivative at 0 or pi.
4565         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4566         it=itype(i-1)
4567         ichir1=isign(1,itype(i-2))
4568         ichir2=isign(1,itype(i))
4569          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4570          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4571          if (itype(i-1).eq.10) then
4572           itype1=isign(10,itype(i-2))
4573           ichir11=isign(1,itype(i-2))
4574           ichir12=isign(1,itype(i-2))
4575           itype2=isign(10,itype(i))
4576           ichir21=isign(1,itype(i))
4577           ichir22=isign(1,itype(i))
4578          endif
4579          if (i.eq.3) then
4580           y(1)=0.0D0
4581           y(2)=0.0D0
4582           else
4583
4584         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4585 #ifdef OSF
4586           phii=phi(i)
4587 c          icrc=0
4588 c          call proc_proc(phii,icrc)
4589           if (icrc.eq.1) phii=150.0
4590 #else
4591           phii=phi(i)
4592 #endif
4593           y(1)=dcos(phii)
4594           y(2)=dsin(phii)
4595         else
4596           y(1)=0.0D0
4597           y(2)=0.0D0
4598         endif
4599         endif
4600         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4601 #ifdef OSF
4602           phii1=phi(i+1)
4603 c          icrc=0
4604 c          call proc_proc(phii1,icrc)
4605           if (icrc.eq.1) phii1=150.0
4606           phii1=pinorm(phii1)
4607           z(1)=cos(phii1)
4608 #else
4609           phii1=phi(i+1)
4610           z(1)=dcos(phii1)
4611 #endif
4612           z(2)=dsin(phii1)
4613         else
4614           z(1)=0.0D0
4615           z(2)=0.0D0
4616         endif
4617 C Calculate the "mean" value of theta from the part of the distribution
4618 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4619 C In following comments this theta will be referred to as t_c.
4620         thet_pred_mean=0.0d0
4621         do k=1,2
4622             athetk=athet(k,it,ichir1,ichir2)
4623             bthetk=bthet(k,it,ichir1,ichir2)
4624           if (it.eq.10) then
4625              athetk=athet(k,itype1,ichir11,ichir12)
4626              bthetk=bthet(k,itype2,ichir21,ichir22)
4627           endif
4628           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4629         enddo
4630 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4631         dthett=thet_pred_mean*ssd
4632         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4633 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4634 C Derivatives of the "mean" values in gamma1 and gamma2.
4635         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4636      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4637          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4638      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4639          if (it.eq.10) then
4640       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4641      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4642         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4643      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4644          endif
4645         if (theta(i).gt.pi-delta) then
4646           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4647      &         E_tc0)
4648           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4649           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4650           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4651      &        E_theta)
4652           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4653      &        E_tc)
4654         else if (theta(i).lt.delta) then
4655           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4656           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4657           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4658      &        E_theta)
4659           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4660           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4661      &        E_tc)
4662         else
4663           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4664      &        E_theta,E_tc)
4665         endif
4666         etheta=etheta+ethetai
4667 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4668 c     &      'ebend',i,ethetai,theta(i),itype(i)
4669 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4670 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4671         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4672         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4673         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4674 c 1215   continue
4675       enddo
4676       ethetacnstr=0.0d0
4677 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4678       do i=1,ntheta_constr
4679         itheta=itheta_constr(i)
4680         thetiii=theta(itheta)
4681         difi=pinorm(thetiii-theta_constr0(i))
4682         if (difi.gt.theta_drange(i)) then
4683           difi=difi-theta_drange(i)
4684           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4685           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4686      &    +for_thet_constr(i)*difi**3
4687         else if (difi.lt.-drange(i)) then
4688           difi=difi+drange(i)
4689           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4690           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4691      &    +for_thet_constr(i)*difi**3
4692         else
4693           difi=0.0
4694         endif
4695 C       if (energy_dec) then
4696 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4697 C     &    i,itheta,rad2deg*thetiii,
4698 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4699 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4700 C     &    gloc(itheta+nphi-2,icg)
4701 C        endif
4702       enddo
4703 C Ufff.... We've done all this!!!
4704       return
4705       end
4706 C---------------------------------------------------------------------------
4707       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4708      &     E_tc)
4709       implicit real*8 (a-h,o-z)
4710       include 'DIMENSIONS'
4711       include 'COMMON.LOCAL'
4712       include 'COMMON.IOUNITS'
4713       common /calcthet/ term1,term2,termm,diffak,ratak,
4714      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4715      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4716 C Calculate the contributions to both Gaussian lobes.
4717 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4718 C The "polynomial part" of the "standard deviation" of this part of
4719 C the distribution.
4720         sig=polthet(3,it)
4721         do j=2,0,-1
4722           sig=sig*thet_pred_mean+polthet(j,it)
4723         enddo
4724 C Derivative of the "interior part" of the "standard deviation of the"
4725 C gamma-dependent Gaussian lobe in t_c.
4726         sigtc=3*polthet(3,it)
4727         do j=2,1,-1
4728           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4729         enddo
4730         sigtc=sig*sigtc
4731 C Set the parameters of both Gaussian lobes of the distribution.
4732 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4733         fac=sig*sig+sigc0(it)
4734         sigcsq=fac+fac
4735         sigc=1.0D0/sigcsq
4736 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4737         sigsqtc=-4.0D0*sigcsq*sigtc
4738 c       print *,i,sig,sigtc,sigsqtc
4739 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4740         sigtc=-sigtc/(fac*fac)
4741 C Following variable is sigma(t_c)**(-2)
4742         sigcsq=sigcsq*sigcsq
4743         sig0i=sig0(it)
4744         sig0inv=1.0D0/sig0i**2
4745         delthec=thetai-thet_pred_mean
4746         delthe0=thetai-theta0i
4747         term1=-0.5D0*sigcsq*delthec*delthec
4748         term2=-0.5D0*sig0inv*delthe0*delthe0
4749 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4750 C NaNs in taking the logarithm. We extract the largest exponent which is added
4751 C to the energy (this being the log of the distribution) at the end of energy
4752 C term evaluation for this virtual-bond angle.
4753         if (term1.gt.term2) then
4754           termm=term1
4755           term2=dexp(term2-termm)
4756           term1=1.0d0
4757         else
4758           termm=term2
4759           term1=dexp(term1-termm)
4760           term2=1.0d0
4761         endif
4762 C The ratio between the gamma-independent and gamma-dependent lobes of
4763 C the distribution is a Gaussian function of thet_pred_mean too.
4764         diffak=gthet(2,it)-thet_pred_mean
4765         ratak=diffak/gthet(3,it)**2
4766         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4767 C Let's differentiate it in thet_pred_mean NOW.
4768         aktc=ak*ratak
4769 C Now put together the distribution terms to make complete distribution.
4770         termexp=term1+ak*term2
4771         termpre=sigc+ak*sig0i
4772 C Contribution of the bending energy from this theta is just the -log of
4773 C the sum of the contributions from the two lobes and the pre-exponential
4774 C factor. Simple enough, isn't it?
4775         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4776 C NOW the derivatives!!!
4777 C 6/6/97 Take into account the deformation.
4778         E_theta=(delthec*sigcsq*term1
4779      &       +ak*delthe0*sig0inv*term2)/termexp
4780         E_tc=((sigtc+aktc*sig0i)/termpre
4781      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4782      &       aktc*term2)/termexp)
4783       return
4784       end
4785 c-----------------------------------------------------------------------------
4786       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4787       implicit real*8 (a-h,o-z)
4788       include 'DIMENSIONS'
4789       include 'COMMON.LOCAL'
4790       include 'COMMON.IOUNITS'
4791       common /calcthet/ term1,term2,termm,diffak,ratak,
4792      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4793      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4794       delthec=thetai-thet_pred_mean
4795       delthe0=thetai-theta0i
4796 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4797       t3 = thetai-thet_pred_mean
4798       t6 = t3**2
4799       t9 = term1
4800       t12 = t3*sigcsq
4801       t14 = t12+t6*sigsqtc
4802       t16 = 1.0d0
4803       t21 = thetai-theta0i
4804       t23 = t21**2
4805       t26 = term2
4806       t27 = t21*t26
4807       t32 = termexp
4808       t40 = t32**2
4809       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4810      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4811      & *(-t12*t9-ak*sig0inv*t27)
4812       return
4813       end
4814 #else
4815 C--------------------------------------------------------------------------
4816       subroutine ebend(etheta)
4817 C
4818 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4819 C angles gamma and its derivatives in consecutive thetas and gammas.
4820 C ab initio-derived potentials from
4821 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4822 C
4823       implicit real*8 (a-h,o-z)
4824       include 'DIMENSIONS'
4825       include 'DIMENSIONS.ZSCOPT'
4826       include 'COMMON.LOCAL'
4827       include 'COMMON.GEO'
4828       include 'COMMON.INTERACT'
4829       include 'COMMON.DERIV'
4830       include 'COMMON.VAR'
4831       include 'COMMON.CHAIN'
4832       include 'COMMON.IOUNITS'
4833       include 'COMMON.NAMES'
4834       include 'COMMON.FFIELD'
4835       include 'COMMON.CONTROL'
4836       include 'COMMON.TORCNSTR'
4837       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4838      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4839      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4840      & sinph1ph2(maxdouble,maxdouble)
4841       logical lprn /.false./, lprn1 /.false./
4842       etheta=0.0D0
4843 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4844       do i=ithet_start,ithet_end
4845 C         if (i.eq.2) cycle
4846 C        if (itype(i-1).eq.ntyp1) cycle
4847         if (i.le.2) cycle
4848         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4849      &  .or.itype(i).eq.ntyp1) cycle
4850         if (iabs(itype(i+1)).eq.20) iblock=2
4851         if (iabs(itype(i+1)).ne.20) iblock=1
4852         dethetai=0.0d0
4853         dephii=0.0d0
4854         dephii1=0.0d0
4855         theti2=0.5d0*theta(i)
4856         ityp2=ithetyp((itype(i-1)))
4857         do k=1,nntheterm
4858           coskt(k)=dcos(k*theti2)
4859           sinkt(k)=dsin(k*theti2)
4860         enddo
4861         if (i.eq.3) then
4862           phii=0.0d0
4863           ityp1=nthetyp+1
4864           do k=1,nsingle
4865             cosph1(k)=0.0d0
4866             sinph1(k)=0.0d0
4867           enddo
4868         else
4869         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4870 #ifdef OSF
4871           phii=phi(i)
4872           if (phii.ne.phii) phii=150.0
4873 #else
4874           phii=phi(i)
4875 #endif
4876           ityp1=ithetyp((itype(i-2)))
4877           do k=1,nsingle
4878             cosph1(k)=dcos(k*phii)
4879             sinph1(k)=dsin(k*phii)
4880           enddo
4881         else
4882           phii=0.0d0
4883 c          ityp1=nthetyp+1
4884           do k=1,nsingle
4885             ityp1=ithetyp((itype(i-2)))
4886             cosph1(k)=0.0d0
4887             sinph1(k)=0.0d0
4888           enddo
4889         endif
4890         endif
4891         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4892 #ifdef OSF
4893           phii1=phi(i+1)
4894           if (phii1.ne.phii1) phii1=150.0
4895           phii1=pinorm(phii1)
4896 #else
4897           phii1=phi(i+1)
4898 #endif
4899           ityp3=ithetyp((itype(i)))
4900           do k=1,nsingle
4901             cosph2(k)=dcos(k*phii1)
4902             sinph2(k)=dsin(k*phii1)
4903           enddo
4904         else
4905           phii1=0.0d0
4906 c          ityp3=nthetyp+1
4907           ityp3=ithetyp((itype(i)))
4908           do k=1,nsingle
4909             cosph2(k)=0.0d0
4910             sinph2(k)=0.0d0
4911           enddo
4912         endif
4913 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4914 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4915 c        call flush(iout)
4916         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4917         do k=1,ndouble
4918           do l=1,k-1
4919             ccl=cosph1(l)*cosph2(k-l)
4920             ssl=sinph1(l)*sinph2(k-l)
4921             scl=sinph1(l)*cosph2(k-l)
4922             csl=cosph1(l)*sinph2(k-l)
4923             cosph1ph2(l,k)=ccl-ssl
4924             cosph1ph2(k,l)=ccl+ssl
4925             sinph1ph2(l,k)=scl+csl
4926             sinph1ph2(k,l)=scl-csl
4927           enddo
4928         enddo
4929         if (lprn) then
4930         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4931      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4932         write (iout,*) "coskt and sinkt"
4933         do k=1,nntheterm
4934           write (iout,*) k,coskt(k),sinkt(k)
4935         enddo
4936         endif
4937         do k=1,ntheterm
4938           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4939           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4940      &      *coskt(k)
4941           if (lprn)
4942      &    write (iout,*) "k",k,"
4943      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4944      &     " ethetai",ethetai
4945         enddo
4946         if (lprn) then
4947         write (iout,*) "cosph and sinph"
4948         do k=1,nsingle
4949           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4950         enddo
4951         write (iout,*) "cosph1ph2 and sinph2ph2"
4952         do k=2,ndouble
4953           do l=1,k-1
4954             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4955      &         sinph1ph2(l,k),sinph1ph2(k,l)
4956           enddo
4957         enddo
4958         write(iout,*) "ethetai",ethetai
4959         endif
4960         do m=1,ntheterm2
4961           do k=1,nsingle
4962             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4963      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4964      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4965      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4966             ethetai=ethetai+sinkt(m)*aux
4967             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4968             dephii=dephii+k*sinkt(m)*(
4969      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4970      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4971             dephii1=dephii1+k*sinkt(m)*(
4972      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4973      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4974             if (lprn)
4975      &      write (iout,*) "m",m," k",k," bbthet",
4976      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4977      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4978      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4979      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4980           enddo
4981         enddo
4982         if (lprn)
4983      &  write(iout,*) "ethetai",ethetai
4984         do m=1,ntheterm3
4985           do k=2,ndouble
4986             do l=1,k-1
4987               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4988      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4989      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4990      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4991               ethetai=ethetai+sinkt(m)*aux
4992               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4993               dephii=dephii+l*sinkt(m)*(
4994      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4995      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4996      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4997      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4998               dephii1=dephii1+(k-l)*sinkt(m)*(
4999      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5000      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5001      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5002      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5003               if (lprn) then
5004               write (iout,*) "m",m," k",k," l",l," ffthet",
5005      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5006      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5007      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5008      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5009      &            " ethetai",ethetai
5010               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5011      &            cosph1ph2(k,l)*sinkt(m),
5012      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5013               endif
5014             enddo
5015           enddo
5016         enddo
5017 10      continue
5018         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5019      &   i,theta(i)*rad2deg,phii*rad2deg,
5020      &   phii1*rad2deg,ethetai
5021         etheta=etheta+ethetai
5022         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5023         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5024 c        gloc(nphi+i-2,icg)=wang*dethetai
5025         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5026       enddo
5027       return
5028       end
5029 #endif
5030 #ifdef CRYST_SC
5031 c-----------------------------------------------------------------------------
5032       subroutine esc(escloc)
5033 C Calculate the local energy of a side chain and its derivatives in the
5034 C corresponding virtual-bond valence angles THETA and the spherical angles
5035 C ALPHA and OMEGA.
5036       implicit real*8 (a-h,o-z)
5037       include 'DIMENSIONS'
5038       include 'DIMENSIONS.ZSCOPT'
5039       include 'COMMON.GEO'
5040       include 'COMMON.LOCAL'
5041       include 'COMMON.VAR'
5042       include 'COMMON.INTERACT'
5043       include 'COMMON.DERIV'
5044       include 'COMMON.CHAIN'
5045       include 'COMMON.IOUNITS'
5046       include 'COMMON.NAMES'
5047       include 'COMMON.FFIELD'
5048       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5049      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5050       common /sccalc/ time11,time12,time112,theti,it,nlobit
5051       delta=0.02d0*pi
5052       escloc=0.0D0
5053 C      write (iout,*) 'ESC'
5054       do i=loc_start,loc_end
5055         it=itype(i)
5056         if (it.eq.ntyp1) cycle
5057         if (it.eq.10) goto 1
5058         nlobit=nlob(iabs(it))
5059 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5060 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5061         theti=theta(i+1)-pipol
5062         x(1)=dtan(theti)
5063         x(2)=alph(i)
5064         x(3)=omeg(i)
5065 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5066
5067         if (x(2).gt.pi-delta) then
5068           xtemp(1)=x(1)
5069           xtemp(2)=pi-delta
5070           xtemp(3)=x(3)
5071           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5072           xtemp(2)=pi
5073           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5074           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5075      &        escloci,dersc(2))
5076           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5077      &        ddersc0(1),dersc(1))
5078           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5079      &        ddersc0(3),dersc(3))
5080           xtemp(2)=pi-delta
5081           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5082           xtemp(2)=pi
5083           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5084           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5085      &            dersc0(2),esclocbi,dersc02)
5086           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5087      &            dersc12,dersc01)
5088           call splinthet(x(2),0.5d0*delta,ss,ssd)
5089           dersc0(1)=dersc01
5090           dersc0(2)=dersc02
5091           dersc0(3)=0.0d0
5092           do k=1,3
5093             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5094           enddo
5095           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5096           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5097      &             esclocbi,ss,ssd
5098           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5099 c         escloci=esclocbi
5100 c         write (iout,*) escloci
5101         else if (x(2).lt.delta) then
5102           xtemp(1)=x(1)
5103           xtemp(2)=delta
5104           xtemp(3)=x(3)
5105           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5106           xtemp(2)=0.0d0
5107           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5108           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5109      &        escloci,dersc(2))
5110           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5111      &        ddersc0(1),dersc(1))
5112           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5113      &        ddersc0(3),dersc(3))
5114           xtemp(2)=delta
5115           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5116           xtemp(2)=0.0d0
5117           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5118           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5119      &            dersc0(2),esclocbi,dersc02)
5120           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5121      &            dersc12,dersc01)
5122           dersc0(1)=dersc01
5123           dersc0(2)=dersc02
5124           dersc0(3)=0.0d0
5125           call splinthet(x(2),0.5d0*delta,ss,ssd)
5126           do k=1,3
5127             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5128           enddo
5129           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5130 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5131 c     &             esclocbi,ss,ssd
5132           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5133 C         write (iout,*) 'i=',i, escloci
5134         else
5135           call enesc(x,escloci,dersc,ddummy,.false.)
5136         endif
5137
5138         escloc=escloc+escloci
5139 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5140             write (iout,'(a6,i5,0pf7.3)')
5141      &     'escloc',i,escloci
5142
5143         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5144      &   wscloc*dersc(1)
5145         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5146         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5147     1   continue
5148       enddo
5149       return
5150       end
5151 C---------------------------------------------------------------------------
5152       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5153       implicit real*8 (a-h,o-z)
5154       include 'DIMENSIONS'
5155       include 'COMMON.GEO'
5156       include 'COMMON.LOCAL'
5157       include 'COMMON.IOUNITS'
5158       common /sccalc/ time11,time12,time112,theti,it,nlobit
5159       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5160       double precision contr(maxlob,-1:1)
5161       logical mixed
5162 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5163         escloc_i=0.0D0
5164         do j=1,3
5165           dersc(j)=0.0D0
5166           if (mixed) ddersc(j)=0.0d0
5167         enddo
5168         x3=x(3)
5169
5170 C Because of periodicity of the dependence of the SC energy in omega we have
5171 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5172 C To avoid underflows, first compute & store the exponents.
5173
5174         do iii=-1,1
5175
5176           x(3)=x3+iii*dwapi
5177
5178           do j=1,nlobit
5179             do k=1,3
5180               z(k)=x(k)-censc(k,j,it)
5181             enddo
5182             do k=1,3
5183               Axk=0.0D0
5184               do l=1,3
5185                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5186               enddo
5187               Ax(k,j,iii)=Axk
5188             enddo
5189             expfac=0.0D0
5190             do k=1,3
5191               expfac=expfac+Ax(k,j,iii)*z(k)
5192             enddo
5193             contr(j,iii)=expfac
5194           enddo ! j
5195
5196         enddo ! iii
5197
5198         x(3)=x3
5199 C As in the case of ebend, we want to avoid underflows in exponentiation and
5200 C subsequent NaNs and INFs in energy calculation.
5201 C Find the largest exponent
5202         emin=contr(1,-1)
5203         do iii=-1,1
5204           do j=1,nlobit
5205             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5206           enddo
5207         enddo
5208         emin=0.5D0*emin
5209 cd      print *,'it=',it,' emin=',emin
5210
5211 C Compute the contribution to SC energy and derivatives
5212         do iii=-1,1
5213
5214           do j=1,nlobit
5215             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5216 cd          print *,'j=',j,' expfac=',expfac
5217             escloc_i=escloc_i+expfac
5218             do k=1,3
5219               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5220             enddo
5221             if (mixed) then
5222               do k=1,3,2
5223                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5224      &            +gaussc(k,2,j,it))*expfac
5225               enddo
5226             endif
5227           enddo
5228
5229         enddo ! iii
5230
5231         dersc(1)=dersc(1)/cos(theti)**2
5232         ddersc(1)=ddersc(1)/cos(theti)**2
5233         ddersc(3)=ddersc(3)
5234
5235         escloci=-(dlog(escloc_i)-emin)
5236         do j=1,3
5237           dersc(j)=dersc(j)/escloc_i
5238         enddo
5239         if (mixed) then
5240           do j=1,3,2
5241             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5242           enddo
5243         endif
5244       return
5245       end
5246 C------------------------------------------------------------------------------
5247       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5248       implicit real*8 (a-h,o-z)
5249       include 'DIMENSIONS'
5250       include 'COMMON.GEO'
5251       include 'COMMON.LOCAL'
5252       include 'COMMON.IOUNITS'
5253       common /sccalc/ time11,time12,time112,theti,it,nlobit
5254       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5255       double precision contr(maxlob)
5256       logical mixed
5257
5258       escloc_i=0.0D0
5259
5260       do j=1,3
5261         dersc(j)=0.0D0
5262       enddo
5263
5264       do j=1,nlobit
5265         do k=1,2
5266           z(k)=x(k)-censc(k,j,it)
5267         enddo
5268         z(3)=dwapi
5269         do k=1,3
5270           Axk=0.0D0
5271           do l=1,3
5272             Axk=Axk+gaussc(l,k,j,it)*z(l)
5273           enddo
5274           Ax(k,j)=Axk
5275         enddo
5276         expfac=0.0D0
5277         do k=1,3
5278           expfac=expfac+Ax(k,j)*z(k)
5279         enddo
5280         contr(j)=expfac
5281       enddo ! j
5282
5283 C As in the case of ebend, we want to avoid underflows in exponentiation and
5284 C subsequent NaNs and INFs in energy calculation.
5285 C Find the largest exponent
5286       emin=contr(1)
5287       do j=1,nlobit
5288         if (emin.gt.contr(j)) emin=contr(j)
5289       enddo
5290       emin=0.5D0*emin
5291
5292 C Compute the contribution to SC energy and derivatives
5293
5294       dersc12=0.0d0
5295       do j=1,nlobit
5296         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5297         escloc_i=escloc_i+expfac
5298         do k=1,2
5299           dersc(k)=dersc(k)+Ax(k,j)*expfac
5300         enddo
5301         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5302      &            +gaussc(1,2,j,it))*expfac
5303         dersc(3)=0.0d0
5304       enddo
5305
5306       dersc(1)=dersc(1)/cos(theti)**2
5307       dersc12=dersc12/cos(theti)**2
5308       escloci=-(dlog(escloc_i)-emin)
5309       do j=1,2
5310         dersc(j)=dersc(j)/escloc_i
5311       enddo
5312       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5313       return
5314       end
5315 #else
5316 c----------------------------------------------------------------------------------
5317       subroutine esc(escloc)
5318 C Calculate the local energy of a side chain and its derivatives in the
5319 C corresponding virtual-bond valence angles THETA and the spherical angles
5320 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5321 C added by Urszula Kozlowska. 07/11/2007
5322 C
5323       implicit real*8 (a-h,o-z)
5324       include 'DIMENSIONS'
5325       include 'DIMENSIONS.ZSCOPT'
5326       include 'COMMON.GEO'
5327       include 'COMMON.LOCAL'
5328       include 'COMMON.VAR'
5329       include 'COMMON.SCROT'
5330       include 'COMMON.INTERACT'
5331       include 'COMMON.DERIV'
5332       include 'COMMON.CHAIN'
5333       include 'COMMON.IOUNITS'
5334       include 'COMMON.NAMES'
5335       include 'COMMON.FFIELD'
5336       include 'COMMON.CONTROL'
5337       include 'COMMON.VECTORS'
5338       double precision x_prime(3),y_prime(3),z_prime(3)
5339      &    , sumene,dsc_i,dp2_i,x(65),
5340      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5341      &    de_dxx,de_dyy,de_dzz,de_dt
5342       double precision s1_t,s1_6_t,s2_t,s2_6_t
5343       double precision
5344      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5345      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5346      & dt_dCi(3),dt_dCi1(3)
5347       common /sccalc/ time11,time12,time112,theti,it,nlobit
5348       delta=0.02d0*pi
5349       escloc=0.0D0
5350       do i=loc_start,loc_end
5351         if (itype(i).eq.ntyp1) cycle
5352         costtab(i+1) =dcos(theta(i+1))
5353         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5354         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5355         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5356         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5357         cosfac=dsqrt(cosfac2)
5358         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5359         sinfac=dsqrt(sinfac2)
5360         it=iabs(itype(i))
5361         if (it.eq.10) goto 1
5362 c
5363 C  Compute the axes of tghe local cartesian coordinates system; store in
5364 c   x_prime, y_prime and z_prime
5365 c
5366         do j=1,3
5367           x_prime(j) = 0.00
5368           y_prime(j) = 0.00
5369           z_prime(j) = 0.00
5370         enddo
5371 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5372 C     &   dc_norm(3,i+nres)
5373         do j = 1,3
5374           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5375           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5376         enddo
5377         do j = 1,3
5378           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5379         enddo
5380 c       write (2,*) "i",i
5381 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5382 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5383 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5384 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5385 c      & " xy",scalar(x_prime(1),y_prime(1)),
5386 c      & " xz",scalar(x_prime(1),z_prime(1)),
5387 c      & " yy",scalar(y_prime(1),y_prime(1)),
5388 c      & " yz",scalar(y_prime(1),z_prime(1)),
5389 c      & " zz",scalar(z_prime(1),z_prime(1))
5390 c
5391 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5392 C to local coordinate system. Store in xx, yy, zz.
5393 c
5394         xx=0.0d0
5395         yy=0.0d0
5396         zz=0.0d0
5397         do j = 1,3
5398           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5399           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5400           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5401         enddo
5402
5403         xxtab(i)=xx
5404         yytab(i)=yy
5405         zztab(i)=zz
5406 C
5407 C Compute the energy of the ith side cbain
5408 C
5409 c        write (2,*) "xx",xx," yy",yy," zz",zz
5410         it=iabs(itype(i))
5411         do j = 1,65
5412           x(j) = sc_parmin(j,it)
5413         enddo
5414 #ifdef CHECK_COORD
5415 Cc diagnostics - remove later
5416         xx1 = dcos(alph(2))
5417         yy1 = dsin(alph(2))*dcos(omeg(2))
5418         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5419         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5420      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5421      &    xx1,yy1,zz1
5422 C,"  --- ", xx_w,yy_w,zz_w
5423 c end diagnostics
5424 #endif
5425         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5426      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5427      &   + x(10)*yy*zz
5428         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5429      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5430      & + x(20)*yy*zz
5431         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5432      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5433      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5434      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5435      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5436      &  +x(40)*xx*yy*zz
5437         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5438      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5439      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5440      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5441      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5442      &  +x(60)*xx*yy*zz
5443         dsc_i   = 0.743d0+x(61)
5444         dp2_i   = 1.9d0+x(62)
5445         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5446      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5447         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5448      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5449         s1=(1+x(63))/(0.1d0 + dscp1)
5450         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5451         s2=(1+x(65))/(0.1d0 + dscp2)
5452         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5453         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5454      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5455 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5456 c     &   sumene4,
5457 c     &   dscp1,dscp2,sumene
5458 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5459         escloc = escloc + sumene
5460 c        write (2,*) "escloc",escloc
5461 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5462 c     &  zz,xx,yy
5463         if (.not. calc_grad) goto 1
5464 #ifdef DEBUG
5465 C
5466 C This section to check the numerical derivatives of the energy of ith side
5467 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5468 C #define DEBUG in the code to turn it on.
5469 C
5470         write (2,*) "sumene               =",sumene
5471         aincr=1.0d-7
5472         xxsave=xx
5473         xx=xx+aincr
5474         write (2,*) xx,yy,zz
5475         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5476         de_dxx_num=(sumenep-sumene)/aincr
5477         xx=xxsave
5478         write (2,*) "xx+ sumene from enesc=",sumenep
5479         yysave=yy
5480         yy=yy+aincr
5481         write (2,*) xx,yy,zz
5482         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5483         de_dyy_num=(sumenep-sumene)/aincr
5484         yy=yysave
5485         write (2,*) "yy+ sumene from enesc=",sumenep
5486         zzsave=zz
5487         zz=zz+aincr
5488         write (2,*) xx,yy,zz
5489         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5490         de_dzz_num=(sumenep-sumene)/aincr
5491         zz=zzsave
5492         write (2,*) "zz+ sumene from enesc=",sumenep
5493         costsave=cost2tab(i+1)
5494         sintsave=sint2tab(i+1)
5495         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5496         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5497         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5498         de_dt_num=(sumenep-sumene)/aincr
5499         write (2,*) " t+ sumene from enesc=",sumenep
5500         cost2tab(i+1)=costsave
5501         sint2tab(i+1)=sintsave
5502 C End of diagnostics section.
5503 #endif
5504 C
5505 C Compute the gradient of esc
5506 C
5507         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5508         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5509         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5510         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5511         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5512         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5513         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5514         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5515         pom1=(sumene3*sint2tab(i+1)+sumene1)
5516      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5517         pom2=(sumene4*cost2tab(i+1)+sumene2)
5518      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5519         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5520         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5521      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5522      &  +x(40)*yy*zz
5523         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5524         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5525      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5526      &  +x(60)*yy*zz
5527         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5528      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5529      &        +(pom1+pom2)*pom_dx
5530 #ifdef DEBUG
5531         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5532 #endif
5533 C
5534         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5535         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5536      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5537      &  +x(40)*xx*zz
5538         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5539         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5540      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5541      &  +x(59)*zz**2 +x(60)*xx*zz
5542         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5543      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5544      &        +(pom1-pom2)*pom_dy
5545 #ifdef DEBUG
5546         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5547 #endif
5548 C
5549         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5550      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5551      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5552      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5553      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5554      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5555      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5556      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5557 #ifdef DEBUG
5558         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5559 #endif
5560 C
5561         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5562      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5563      &  +pom1*pom_dt1+pom2*pom_dt2
5564 #ifdef DEBUG
5565         write(2,*), "de_dt = ", de_dt,de_dt_num
5566 #endif
5567 c
5568 C
5569        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5570        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5571        cosfac2xx=cosfac2*xx
5572        sinfac2yy=sinfac2*yy
5573        do k = 1,3
5574          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5575      &      vbld_inv(i+1)
5576          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5577      &      vbld_inv(i)
5578          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5579          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5580 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5581 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5582 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5583 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5584          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5585          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5586          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5587          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5588          dZZ_Ci1(k)=0.0d0
5589          dZZ_Ci(k)=0.0d0
5590          do j=1,3
5591            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5592      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5593            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5594      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5595          enddo
5596
5597          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5598          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5599          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5600 c
5601          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5602          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5603        enddo
5604
5605        do k=1,3
5606          dXX_Ctab(k,i)=dXX_Ci(k)
5607          dXX_C1tab(k,i)=dXX_Ci1(k)
5608          dYY_Ctab(k,i)=dYY_Ci(k)
5609          dYY_C1tab(k,i)=dYY_Ci1(k)
5610          dZZ_Ctab(k,i)=dZZ_Ci(k)
5611          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5612          dXX_XYZtab(k,i)=dXX_XYZ(k)
5613          dYY_XYZtab(k,i)=dYY_XYZ(k)
5614          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5615        enddo
5616
5617        do k = 1,3
5618 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5619 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5620 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5621 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5622 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5623 c     &    dt_dci(k)
5624 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5625 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5626          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5627      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5628          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5629      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5630          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5631      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5632        enddo
5633 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5634 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5635
5636 C to check gradient call subroutine check_grad
5637
5638     1 continue
5639       enddo
5640       return
5641       end
5642 #endif
5643 c------------------------------------------------------------------------------
5644       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5645 C
5646 C This procedure calculates two-body contact function g(rij) and its derivative:
5647 C
5648 C           eps0ij                                     !       x < -1
5649 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5650 C            0                                         !       x > 1
5651 C
5652 C where x=(rij-r0ij)/delta
5653 C
5654 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5655 C
5656       implicit none
5657       double precision rij,r0ij,eps0ij,fcont,fprimcont
5658       double precision x,x2,x4,delta
5659 c     delta=0.02D0*r0ij
5660 c      delta=0.2D0*r0ij
5661       x=(rij-r0ij)/delta
5662       if (x.lt.-1.0D0) then
5663         fcont=eps0ij
5664         fprimcont=0.0D0
5665       else if (x.le.1.0D0) then
5666         x2=x*x
5667         x4=x2*x2
5668         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5669         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5670       else
5671         fcont=0.0D0
5672         fprimcont=0.0D0
5673       endif
5674       return
5675       end
5676 c------------------------------------------------------------------------------
5677       subroutine splinthet(theti,delta,ss,ssder)
5678       implicit real*8 (a-h,o-z)
5679       include 'DIMENSIONS'
5680       include 'DIMENSIONS.ZSCOPT'
5681       include 'COMMON.VAR'
5682       include 'COMMON.GEO'
5683       thetup=pi-delta
5684       thetlow=delta
5685       if (theti.gt.pipol) then
5686         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5687       else
5688         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5689         ssder=-ssder
5690       endif
5691       return
5692       end
5693 c------------------------------------------------------------------------------
5694       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5695       implicit none
5696       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5697       double precision ksi,ksi2,ksi3,a1,a2,a3
5698       a1=fprim0*delta/(f1-f0)
5699       a2=3.0d0-2.0d0*a1
5700       a3=a1-2.0d0
5701       ksi=(x-x0)/delta
5702       ksi2=ksi*ksi
5703       ksi3=ksi2*ksi
5704       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5705       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5706       return
5707       end
5708 c------------------------------------------------------------------------------
5709       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5710       implicit none
5711       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5712       double precision ksi,ksi2,ksi3,a1,a2,a3
5713       ksi=(x-x0)/delta
5714       ksi2=ksi*ksi
5715       ksi3=ksi2*ksi
5716       a1=fprim0x*delta
5717       a2=3*(f1x-f0x)-2*fprim0x*delta
5718       a3=fprim0x*delta-2*(f1x-f0x)
5719       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5720       return
5721       end
5722 C-----------------------------------------------------------------------------
5723 #ifdef CRYST_TOR
5724 C-----------------------------------------------------------------------------
5725       subroutine etor(etors,fact)
5726       implicit real*8 (a-h,o-z)
5727       include 'DIMENSIONS'
5728       include 'DIMENSIONS.ZSCOPT'
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=0.0D0
5745       do i=iphi_start,iphi_end
5746         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5747      &      .or. itype(i).eq.ntyp1) cycle
5748         itori=itortyp(itype(i-2))
5749         itori1=itortyp(itype(i-1))
5750         phii=phi(i)
5751         gloci=0.0D0
5752 C Proline-Proline pair is a special case...
5753         if (itori.eq.3 .and. itori1.eq.3) then
5754           if (phii.gt.-dwapi3) then
5755             cosphi=dcos(3*phii)
5756             fac=1.0D0/(1.0D0-cosphi)
5757             etorsi=v1(1,3,3)*fac
5758             etorsi=etorsi+etorsi
5759             etors=etors+etorsi-v1(1,3,3)
5760             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5761           endif
5762           do j=1,3
5763             v1ij=v1(j+1,itori,itori1)
5764             v2ij=v2(j+1,itori,itori1)
5765             cosphi=dcos(j*phii)
5766             sinphi=dsin(j*phii)
5767             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5768             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5769           enddo
5770         else
5771           do j=1,nterm_old
5772             v1ij=v1(j,itori,itori1)
5773             v2ij=v2(j,itori,itori1)
5774             cosphi=dcos(j*phii)
5775             sinphi=dsin(j*phii)
5776             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5777             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5778           enddo
5779         endif
5780         if (lprn)
5781      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5782      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5783      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5784         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5785 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5786       enddo
5787       return
5788       end
5789 c------------------------------------------------------------------------------
5790 #else
5791       subroutine etor(etors,fact)
5792       implicit real*8 (a-h,o-z)
5793       include 'DIMENSIONS'
5794       include 'DIMENSIONS.ZSCOPT'
5795       include 'COMMON.VAR'
5796       include 'COMMON.GEO'
5797       include 'COMMON.LOCAL'
5798       include 'COMMON.TORSION'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.CHAIN'
5802       include 'COMMON.NAMES'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.FFIELD'
5805       include 'COMMON.TORCNSTR'
5806       logical lprn
5807 C Set lprn=.true. for debugging
5808       lprn=.false.
5809 c      lprn=.true.
5810       etors=0.0D0
5811       do i=iphi_start,iphi_end
5812         if (i.le.2) cycle
5813         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5814      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5815 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5816 C     &       .or. itype(i).eq.ntyp1) cycle
5817         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5818          if (iabs(itype(i)).eq.20) then
5819          iblock=2
5820          else
5821          iblock=1
5822          endif
5823         itori=itortyp(itype(i-2))
5824         itori1=itortyp(itype(i-1))
5825         phii=phi(i)
5826         gloci=0.0D0
5827 C Regular cosine and sine terms
5828         do j=1,nterm(itori,itori1,iblock)
5829           v1ij=v1(j,itori,itori1,iblock)
5830           v2ij=v2(j,itori,itori1,iblock)
5831           cosphi=dcos(j*phii)
5832           sinphi=dsin(j*phii)
5833           etors=etors+v1ij*cosphi+v2ij*sinphi
5834           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5835         enddo
5836 C Lorentz terms
5837 C                         v1
5838 C  E = SUM ----------------------------------- - v1
5839 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5840 C
5841         cosphi=dcos(0.5d0*phii)
5842         sinphi=dsin(0.5d0*phii)
5843         do j=1,nlor(itori,itori1,iblock)
5844           vl1ij=vlor1(j,itori,itori1)
5845           vl2ij=vlor2(j,itori,itori1)
5846           vl3ij=vlor3(j,itori,itori1)
5847           pom=vl2ij*cosphi+vl3ij*sinphi
5848           pom1=1.0d0/(pom*pom+1.0d0)
5849           etors=etors+vl1ij*pom1
5850 c          if (energy_dec) etors_ii=etors_ii+
5851 c     &                vl1ij*pom1
5852           pom=-pom*pom1*pom1
5853           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5854         enddo
5855 C Subtract the constant term
5856         etors=etors-v0(itori,itori1,iblock)
5857         if (lprn)
5858      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5859      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5860      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5861         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5862 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5863  1215   continue
5864       enddo
5865       return
5866       end
5867 c----------------------------------------------------------------------------
5868       subroutine etor_d(etors_d,fact2)
5869 C 6/23/01 Compute double torsional energy
5870       implicit real*8 (a-h,o-z)
5871       include 'DIMENSIONS'
5872       include 'DIMENSIONS.ZSCOPT'
5873       include 'COMMON.VAR'
5874       include 'COMMON.GEO'
5875       include 'COMMON.LOCAL'
5876       include 'COMMON.TORSION'
5877       include 'COMMON.INTERACT'
5878       include 'COMMON.DERIV'
5879       include 'COMMON.CHAIN'
5880       include 'COMMON.NAMES'
5881       include 'COMMON.IOUNITS'
5882       include 'COMMON.FFIELD'
5883       include 'COMMON.TORCNSTR'
5884       logical lprn
5885 C Set lprn=.true. for debugging
5886       lprn=.false.
5887 c     lprn=.true.
5888       etors_d=0.0D0
5889       do i=iphi_start,iphi_end-1
5890         if (i.le.3) cycle
5891 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5892 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5893          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5894      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5895      &  (itype(i+1).eq.ntyp1)) cycle
5896         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5897      &     goto 1215
5898         itori=itortyp(itype(i-2))
5899         itori1=itortyp(itype(i-1))
5900         itori2=itortyp(itype(i))
5901         phii=phi(i)
5902         phii1=phi(i+1)
5903         gloci1=0.0D0
5904         gloci2=0.0D0
5905         iblock=1
5906         if (iabs(itype(i+1)).eq.20) iblock=2
5907 C Regular cosine and sine terms
5908         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5909           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5910           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5911           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5912           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5913           cosphi1=dcos(j*phii)
5914           sinphi1=dsin(j*phii)
5915           cosphi2=dcos(j*phii1)
5916           sinphi2=dsin(j*phii1)
5917           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5918      &     v2cij*cosphi2+v2sij*sinphi2
5919           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5920           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5921         enddo
5922         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5923           do l=1,k-1
5924             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5925             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5926             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5927             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5928             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5929             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5930             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5931             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5932             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5933      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5934             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5935      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5936             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5937      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5938           enddo
5939         enddo
5940         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5941         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5942  1215   continue
5943       enddo
5944       return
5945       end
5946 #endif
5947 c---------------------------------------------------------------------------
5948 C The rigorous attempt to derive energy function
5949       subroutine etor_kcc(etors,fact)
5950       implicit real*8 (a-h,o-z)
5951       include 'DIMENSIONS'
5952       include 'DIMENSIONS.ZSCOPT'
5953       include 'COMMON.VAR'
5954       include 'COMMON.GEO'
5955       include 'COMMON.LOCAL'
5956       include 'COMMON.TORSION'
5957       include 'COMMON.INTERACT'
5958       include 'COMMON.DERIV'
5959       include 'COMMON.CHAIN'
5960       include 'COMMON.NAMES'
5961       include 'COMMON.IOUNITS'
5962       include 'COMMON.FFIELD'
5963       include 'COMMON.TORCNSTR'
5964       include 'COMMON.CONTROL'
5965       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5966       logical lprn
5967 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5968 C Set lprn=.true. for debugging
5969       lprn=energy_dec
5970 c     lprn=.true.
5971 C      print *,"wchodze kcc"
5972       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5973       etors=0.0D0
5974       do i=iphi_start,iphi_end
5975 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5976 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5977 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5978 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5979         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5980      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5981         itori=itortyp(itype(i-2))
5982         itori1=itortyp(itype(i-1))
5983         phii=phi(i)
5984         glocig=0.0D0
5985         glocit1=0.0d0
5986         glocit2=0.0d0
5987 C to avoid multiple devision by 2
5988 c        theti22=0.5d0*theta(i)
5989 C theta 12 is the theta_1 /2
5990 C theta 22 is theta_2 /2
5991 c        theti12=0.5d0*theta(i-1)
5992 C and appropriate sinus function
5993         sinthet1=dsin(theta(i-1))
5994         sinthet2=dsin(theta(i))
5995         costhet1=dcos(theta(i-1))
5996         costhet2=dcos(theta(i))
5997 C to speed up lets store its mutliplication
5998         sint1t2=sinthet2*sinthet1
5999         sint1t2n=1.0d0
6000 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6001 C +d_n*sin(n*gamma)) *
6002 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6003 C we have two sum 1) Non-Chebyshev which is with n and gamma
6004         nval=nterm_kcc_Tb(itori,itori1)
6005         c1(0)=0.0d0
6006         c2(0)=0.0d0
6007         c1(1)=1.0d0
6008         c2(1)=1.0d0
6009         do j=2,nval
6010           c1(j)=c1(j-1)*costhet1
6011           c2(j)=c2(j-1)*costhet2
6012         enddo
6013         etori=0.0d0
6014         do j=1,nterm_kcc(itori,itori1)
6015           cosphi=dcos(j*phii)
6016           sinphi=dsin(j*phii)
6017           sint1t2n1=sint1t2n
6018           sint1t2n=sint1t2n*sint1t2
6019           sumvalc=0.0d0
6020           gradvalct1=0.0d0
6021           gradvalct2=0.0d0
6022           do k=1,nval
6023             do l=1,nval
6024               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6025               gradvalct1=gradvalct1+
6026      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6027               gradvalct2=gradvalct2+
6028      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6029             enddo
6030           enddo
6031           gradvalct1=-gradvalct1*sinthet1
6032           gradvalct2=-gradvalct2*sinthet2
6033           sumvals=0.0d0
6034           gradvalst1=0.0d0
6035           gradvalst2=0.0d0
6036           do k=1,nval
6037             do l=1,nval
6038               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6039               gradvalst1=gradvalst1+
6040      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6041               gradvalst2=gradvalst2+
6042      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6043             enddo
6044           enddo
6045           gradvalst1=-gradvalst1*sinthet1
6046           gradvalst2=-gradvalst2*sinthet2
6047           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6048 C glocig is the gradient local i site in gamma
6049           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6050 C now gradient over theta_1
6051           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6052      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6053           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6054      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6055         enddo ! j
6056         etors=etors+etori
6057 C derivative over gamma
6058         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6059 C derivative over theta1
6060         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6061 C now derivative over theta2
6062         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6063         if (lprn) then
6064           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6065      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6066           write (iout,*) "c1",(c1(k),k=0,nval),
6067      &    " c2",(c2(k),k=0,nval)
6068           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6069         endif
6070       enddo
6071       return
6072       end
6073 c---------------------------------------------------------------------------------------------
6074       subroutine etor_constr(edihcnstr)
6075       implicit real*8 (a-h,o-z)
6076       include 'DIMENSIONS'
6077       include 'DIMENSIONS.ZSCOPT'
6078       include 'COMMON.VAR'
6079       include 'COMMON.GEO'
6080       include 'COMMON.LOCAL'
6081       include 'COMMON.TORSION'
6082       include 'COMMON.INTERACT'
6083       include 'COMMON.DERIV'
6084       include 'COMMON.CHAIN'
6085       include 'COMMON.NAMES'
6086       include 'COMMON.IOUNITS'
6087       include 'COMMON.FFIELD'
6088       include 'COMMON.TORCNSTR'
6089       include 'COMMON.CONTROL'
6090 ! 6/20/98 - dihedral angle constraints
6091       edihcnstr=0.0d0
6092 c      do i=1,ndih_constr
6093 c      write (iout,*) "idihconstr_start",idihconstr_start,
6094 c     &  " idihconstr_end",idihconstr_end
6095
6096       if (raw_psipred) then
6097         do i=idihconstr_start,idihconstr_end
6098           itori=idih_constr(i)
6099           phii=phi(itori)
6100           gaudih_i=vpsipred(1,i)
6101           gauder_i=0.0d0
6102           do j=1,2
6103             s = sdihed(j,i)
6104             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6105             dexpcos_i=dexp(-cos_i*cos_i)
6106             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6107             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6108      &            *cos_i*dexpcos_i/s**2
6109           enddo
6110           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6111           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6112           if (energy_dec)
6113      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6114      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6115      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6116      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6117      &     -wdihc*dlog(gaudih_i)
6118         enddo
6119       else
6120
6121       do i=idihconstr_start,idihconstr_end
6122         itori=idih_constr(i)
6123         phii=phi(itori)
6124         difi=pinorm(phii-phi0(i))
6125         if (difi.gt.drange(i)) then
6126           difi=difi-drange(i)
6127           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6128           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6129         else if (difi.lt.-drange(i)) then
6130           difi=difi+drange(i)
6131           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6132           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6133         else
6134           difi=0.0
6135         endif
6136       enddo
6137
6138       endif
6139
6140 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6141       return
6142       end
6143 c----------------------------------------------------------------------------
6144 C The rigorous attempt to derive energy function
6145       subroutine ebend_kcc(etheta)
6146
6147       implicit real*8 (a-h,o-z)
6148       include 'DIMENSIONS'
6149       include 'DIMENSIONS.ZSCOPT'
6150       include 'COMMON.VAR'
6151       include 'COMMON.GEO'
6152       include 'COMMON.LOCAL'
6153       include 'COMMON.TORSION'
6154       include 'COMMON.INTERACT'
6155       include 'COMMON.DERIV'
6156       include 'COMMON.CHAIN'
6157       include 'COMMON.NAMES'
6158       include 'COMMON.IOUNITS'
6159       include 'COMMON.FFIELD'
6160       include 'COMMON.TORCNSTR'
6161       include 'COMMON.CONTROL'
6162       logical lprn
6163       double precision thybt1(maxang_kcc)
6164 C Set lprn=.true. for debugging
6165       lprn=energy_dec
6166 c     lprn=.true.
6167 C      print *,"wchodze kcc"
6168       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6169       etheta=0.0D0
6170       do i=ithet_start,ithet_end
6171 c        print *,i,itype(i-1),itype(i),itype(i-2)
6172         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6173      &  .or.itype(i).eq.ntyp1) cycle
6174         iti=iabs(itortyp(itype(i-1)))
6175         sinthet=dsin(theta(i))
6176         costhet=dcos(theta(i))
6177         do j=1,nbend_kcc_Tb(iti)
6178           thybt1(j)=v1bend_chyb(j,iti)
6179         enddo
6180         sumth1thyb=v1bend_chyb(0,iti)+
6181      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6182         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6183      &    sumth1thyb
6184         ihelp=nbend_kcc_Tb(iti)-1
6185         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6186         etheta=etheta+sumth1thyb
6187 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6188         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6189       enddo
6190       return
6191       end
6192 c-------------------------------------------------------------------------------------
6193       subroutine etheta_constr(ethetacnstr)
6194
6195       implicit real*8 (a-h,o-z)
6196       include 'DIMENSIONS'
6197       include 'DIMENSIONS.ZSCOPT'
6198       include 'COMMON.VAR'
6199       include 'COMMON.GEO'
6200       include 'COMMON.LOCAL'
6201       include 'COMMON.TORSION'
6202       include 'COMMON.INTERACT'
6203       include 'COMMON.DERIV'
6204       include 'COMMON.CHAIN'
6205       include 'COMMON.NAMES'
6206       include 'COMMON.IOUNITS'
6207       include 'COMMON.FFIELD'
6208       include 'COMMON.TORCNSTR'
6209       include 'COMMON.CONTROL'
6210       ethetacnstr=0.0d0
6211 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6212       do i=ithetaconstr_start,ithetaconstr_end
6213         itheta=itheta_constr(i)
6214         thetiii=theta(itheta)
6215         difi=pinorm(thetiii-theta_constr0(i))
6216         if (difi.gt.theta_drange(i)) then
6217           difi=difi-theta_drange(i)
6218           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6219           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6220      &    +for_thet_constr(i)*difi**3
6221         else if (difi.lt.-drange(i)) then
6222           difi=difi+drange(i)
6223           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6224           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6225      &    +for_thet_constr(i)*difi**3
6226         else
6227           difi=0.0
6228         endif
6229        if (energy_dec) then
6230         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6231      &    i,itheta,rad2deg*thetiii,
6232      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6233      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6234      &    gloc(itheta+nphi-2,icg)
6235         endif
6236       enddo
6237       return
6238       end
6239 c------------------------------------------------------------------------------
6240 c------------------------------------------------------------------------------
6241       subroutine eback_sc_corr(esccor)
6242 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6243 c        conformational states; temporarily implemented as differences
6244 c        between UNRES torsional potentials (dependent on three types of
6245 c        residues) and the torsional potentials dependent on all 20 types
6246 c        of residues computed from AM1 energy surfaces of terminally-blocked
6247 c        amino-acid residues.
6248       implicit real*8 (a-h,o-z)
6249       include 'DIMENSIONS'
6250       include 'DIMENSIONS.ZSCOPT'
6251       include 'COMMON.VAR'
6252       include 'COMMON.GEO'
6253       include 'COMMON.LOCAL'
6254       include 'COMMON.TORSION'
6255       include 'COMMON.SCCOR'
6256       include 'COMMON.INTERACT'
6257       include 'COMMON.DERIV'
6258       include 'COMMON.CHAIN'
6259       include 'COMMON.NAMES'
6260       include 'COMMON.IOUNITS'
6261       include 'COMMON.FFIELD'
6262       include 'COMMON.CONTROL'
6263       logical lprn
6264 C Set lprn=.true. for debugging
6265       lprn=.false.
6266 c      lprn=.true.
6267 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6268       esccor=0.0D0
6269       do i=itau_start,itau_end
6270         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6271         esccor_ii=0.0D0
6272         isccori=isccortyp(itype(i-2))
6273         isccori1=isccortyp(itype(i-1))
6274         phii=phi(i)
6275         do intertyp=1,3 !intertyp
6276 cc Added 09 May 2012 (Adasko)
6277 cc  Intertyp means interaction type of backbone mainchain correlation:
6278 c   1 = SC...Ca...Ca...Ca
6279 c   2 = Ca...Ca...Ca...SC
6280 c   3 = SC...Ca...Ca...SCi
6281         gloci=0.0D0
6282         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6283      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6284      &      (itype(i-1).eq.ntyp1)))
6285      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6286      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6287      &     .or.(itype(i).eq.ntyp1)))
6288      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6289      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6290      &      (itype(i-3).eq.ntyp1)))) cycle
6291         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6292         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6293      & cycle
6294        do j=1,nterm_sccor(isccori,isccori1)
6295           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6296           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6297           cosphi=dcos(j*tauangle(intertyp,i))
6298           sinphi=dsin(j*tauangle(intertyp,i))
6299            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6300            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6301          enddo
6302 C      write (iout,*)"EBACK_SC_COR",esccor,i
6303 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6304 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6305 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6306         if (lprn)
6307      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6308      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6309      &  (v1sccor(j,1,itori,itori1),j=1,6)
6310      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6311 c        gsccor_loc(i-3)=gloci
6312        enddo !intertyp
6313       enddo
6314       return
6315       end
6316 c------------------------------------------------------------------------------
6317       subroutine multibody(ecorr)
6318 C This subroutine calculates multi-body contributions to energy following
6319 C the idea of Skolnick et al. If side chains I and J make a contact and
6320 C at the same time side chains I+1 and J+1 make a contact, an extra
6321 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6322       implicit real*8 (a-h,o-z)
6323       include 'DIMENSIONS'
6324       include 'COMMON.IOUNITS'
6325       include 'COMMON.DERIV'
6326       include 'COMMON.INTERACT'
6327       include 'COMMON.CONTACTS'
6328       double precision gx(3),gx1(3)
6329       logical lprn
6330
6331 C Set lprn=.true. for debugging
6332       lprn=.false.
6333
6334       if (lprn) then
6335         write (iout,'(a)') 'Contact function values:'
6336         do i=nnt,nct-2
6337           write (iout,'(i2,20(1x,i2,f10.5))')
6338      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6339         enddo
6340       endif
6341       ecorr=0.0D0
6342       do i=nnt,nct
6343         do j=1,3
6344           gradcorr(j,i)=0.0D0
6345           gradxorr(j,i)=0.0D0
6346         enddo
6347       enddo
6348       do i=nnt,nct-2
6349
6350         DO ISHIFT = 3,4
6351
6352         i1=i+ishift
6353         num_conti=num_cont(i)
6354         num_conti1=num_cont(i1)
6355         do jj=1,num_conti
6356           j=jcont(jj,i)
6357           do kk=1,num_conti1
6358             j1=jcont(kk,i1)
6359             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6360 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6361 cd   &                   ' ishift=',ishift
6362 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6363 C The system gains extra energy.
6364               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6365             endif   ! j1==j+-ishift
6366           enddo     ! kk
6367         enddo       ! jj
6368
6369         ENDDO ! ISHIFT
6370
6371       enddo         ! i
6372       return
6373       end
6374 c------------------------------------------------------------------------------
6375       double precision function esccorr(i,j,k,l,jj,kk)
6376       implicit real*8 (a-h,o-z)
6377       include 'DIMENSIONS'
6378       include 'COMMON.IOUNITS'
6379       include 'COMMON.DERIV'
6380       include 'COMMON.INTERACT'
6381       include 'COMMON.CONTACTS'
6382       double precision gx(3),gx1(3)
6383       logical lprn
6384       lprn=.false.
6385       eij=facont(jj,i)
6386       ekl=facont(kk,k)
6387 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6388 C Calculate the multi-body contribution to energy.
6389 C Calculate multi-body contributions to the gradient.
6390 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6391 cd   & k,l,(gacont(m,kk,k),m=1,3)
6392       do m=1,3
6393         gx(m) =ekl*gacont(m,jj,i)
6394         gx1(m)=eij*gacont(m,kk,k)
6395         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6396         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6397         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6398         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6399       enddo
6400       do m=i,j-1
6401         do ll=1,3
6402           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6403         enddo
6404       enddo
6405       do m=k,l-1
6406         do ll=1,3
6407           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6408         enddo
6409       enddo
6410       esccorr=-eij*ekl
6411       return
6412       end
6413 c------------------------------------------------------------------------------
6414       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6415 C This subroutine calculates multi-body contributions to hydrogen-bonding
6416       implicit real*8 (a-h,o-z)
6417       include 'DIMENSIONS'
6418       include 'DIMENSIONS.ZSCOPT'
6419       include 'COMMON.IOUNITS'
6420       include 'COMMON.FFIELD'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.INTERACT'
6423       include 'COMMON.CONTACTS'
6424       double precision gx(3),gx1(3)
6425       logical lprn,ldone
6426
6427 C Set lprn=.true. for debugging
6428       lprn=.false.
6429       if (lprn) then
6430         write (iout,'(a)') 'Contact function values:'
6431         do i=nnt,nct-2
6432           write (iout,'(2i3,50(1x,i2,f5.2))')
6433      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6434      &    j=1,num_cont_hb(i))
6435         enddo
6436       endif
6437       ecorr=0.0D0
6438 C Remove the loop below after debugging !!!
6439       do i=nnt,nct
6440         do j=1,3
6441           gradcorr(j,i)=0.0D0
6442           gradxorr(j,i)=0.0D0
6443         enddo
6444       enddo
6445 C Calculate the local-electrostatic correlation terms
6446       do i=iatel_s,iatel_e+1
6447         i1=i+1
6448         num_conti=num_cont_hb(i)
6449         num_conti1=num_cont_hb(i+1)
6450         do jj=1,num_conti
6451           j=jcont_hb(jj,i)
6452           do kk=1,num_conti1
6453             j1=jcont_hb(kk,i1)
6454 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6455 c     &         ' jj=',jj,' kk=',kk
6456             if (j1.eq.j+1 .or. j1.eq.j-1) then
6457 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6458 C The system gains extra energy.
6459               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6460               n_corr=n_corr+1
6461             else if (j1.eq.j) then
6462 C Contacts I-J and I-(J+1) occur simultaneously.
6463 C The system loses extra energy.
6464 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6465             endif
6466           enddo ! kk
6467           do kk=1,num_conti
6468             j1=jcont_hb(kk,i)
6469 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6470 c    &         ' jj=',jj,' kk=',kk
6471             if (j1.eq.j+1) then
6472 C Contacts I-J and (I+1)-J occur simultaneously.
6473 C The system loses extra energy.
6474 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6475             endif ! j1==j+1
6476           enddo ! kk
6477         enddo ! jj
6478       enddo ! i
6479       return
6480       end
6481 c------------------------------------------------------------------------------
6482       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6483      &  n_corr1)
6484 C This subroutine calculates multi-body contributions to hydrogen-bonding
6485       implicit real*8 (a-h,o-z)
6486       include 'DIMENSIONS'
6487       include 'DIMENSIONS.ZSCOPT'
6488       include 'COMMON.IOUNITS'
6489 #ifdef MPI
6490       include "mpif.h"
6491 #endif
6492       include 'COMMON.FFIELD'
6493       include 'COMMON.DERIV'
6494       include 'COMMON.LOCAL'
6495       include 'COMMON.INTERACT'
6496       include 'COMMON.CONTACTS'
6497       include 'COMMON.CHAIN'
6498       include 'COMMON.CONTROL'
6499       include 'COMMON.SHIELD'
6500       double precision gx(3),gx1(3)
6501       integer num_cont_hb_old(maxres)
6502       logical lprn,ldone
6503       double precision eello4,eello5,eelo6,eello_turn6
6504       external eello4,eello5,eello6,eello_turn6
6505 C Set lprn=.true. for debugging
6506       lprn=.false.
6507       eturn6=0.0d0
6508       if (lprn) then
6509         write (iout,'(a)') 'Contact function values:'
6510         do i=nnt,nct-2
6511           write (iout,'(2i3,50(1x,i2,5f6.3))')
6512      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6513      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6514         enddo
6515       endif
6516       ecorr=0.0D0
6517       ecorr5=0.0d0
6518       ecorr6=0.0d0
6519 C Remove the loop below after debugging !!!
6520       do i=nnt,nct
6521         do j=1,3
6522           gradcorr(j,i)=0.0D0
6523           gradxorr(j,i)=0.0D0
6524         enddo
6525       enddo
6526 C Calculate the dipole-dipole interaction energies
6527       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6528       do i=iatel_s,iatel_e+1
6529         num_conti=num_cont_hb(i)
6530         do jj=1,num_conti
6531           j=jcont_hb(jj,i)
6532 #ifdef MOMENT
6533           call dipole(i,j,jj)
6534 #endif
6535         enddo
6536       enddo
6537       endif
6538 C Calculate the local-electrostatic correlation terms
6539 c                write (iout,*) "gradcorr5 in eello5 before loop"
6540 c                do iii=1,nres
6541 c                  write (iout,'(i5,3f10.5)')
6542 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6543 c                enddo
6544       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6545 c        write (iout,*) "corr loop i",i
6546         i1=i+1
6547         num_conti=num_cont_hb(i)
6548         num_conti1=num_cont_hb(i+1)
6549         do jj=1,num_conti
6550           j=jcont_hb(jj,i)
6551           jp=iabs(j)
6552           do kk=1,num_conti1
6553             j1=jcont_hb(kk,i1)
6554             jp1=iabs(j1)
6555 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6556 c     &         ' jj=',jj,' kk=',kk
6557 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6558             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6559      &          .or. j.lt.0 .and. j1.gt.0) .and.
6560      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6561 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6562 C The system gains extra energy.
6563               n_corr=n_corr+1
6564               sqd1=dsqrt(d_cont(jj,i))
6565               sqd2=dsqrt(d_cont(kk,i1))
6566               sred_geom = sqd1*sqd2
6567               IF (sred_geom.lt.cutoff_corr) THEN
6568                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6569      &            ekont,fprimcont)
6570 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6571 cd     &         ' jj=',jj,' kk=',kk
6572                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6573                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6574                 do l=1,3
6575                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6576                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6577                 enddo
6578                 n_corr1=n_corr1+1
6579 cd               write (iout,*) 'sred_geom=',sred_geom,
6580 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6581 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6582 cd               write (iout,*) "g_contij",g_contij
6583 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6584 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6585                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6586                 if (wcorr4.gt.0.0d0)
6587      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6588 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6589                   if (energy_dec.and.wcorr4.gt.0.0d0)
6590      1                 write (iout,'(a6,4i5,0pf7.3)')
6591      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6592 c                write (iout,*) "gradcorr5 before eello5"
6593 c                do iii=1,nres
6594 c                  write (iout,'(i5,3f10.5)')
6595 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6596 c                enddo
6597                 if (wcorr5.gt.0.0d0)
6598      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6599 c                write (iout,*) "gradcorr5 after eello5"
6600 c                do iii=1,nres
6601 c                  write (iout,'(i5,3f10.5)')
6602 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6603 c                enddo
6604                   if (energy_dec.and.wcorr5.gt.0.0d0)
6605      1                 write (iout,'(a6,4i5,0pf7.3)')
6606      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6607 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6608 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6609                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6610      &               .or. wturn6.eq.0.0d0))then
6611 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6612                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6613                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6614      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6615 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6616 cd     &            'ecorr6=',ecorr6
6617 cd                write (iout,'(4e15.5)') sred_geom,
6618 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6619 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6620 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6621                 else if (wturn6.gt.0.0d0
6622      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6623 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6624                   eturn6=eturn6+eello_turn6(i,jj,kk)
6625                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6626      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6627 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6628                 endif
6629               ENDIF
6630 1111          continue
6631             endif
6632           enddo ! kk
6633         enddo ! jj
6634       enddo ! i
6635       do i=1,nres
6636         num_cont_hb(i)=num_cont_hb_old(i)
6637       enddo
6638 c                write (iout,*) "gradcorr5 in eello5"
6639 c                do iii=1,nres
6640 c                  write (iout,'(i5,3f10.5)')
6641 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6642 c                enddo
6643       return
6644       end
6645 c------------------------------------------------------------------------------
6646       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6647       implicit real*8 (a-h,o-z)
6648       include 'DIMENSIONS'
6649       include 'DIMENSIONS.ZSCOPT'
6650       include 'COMMON.IOUNITS'
6651       include 'COMMON.DERIV'
6652       include 'COMMON.INTERACT'
6653       include 'COMMON.CONTACTS'
6654       include 'COMMON.SHIELD'
6655       include 'COMMON.CONTROL'
6656       double precision gx(3),gx1(3)
6657       logical lprn
6658       lprn=.false.
6659 C      print *,"wchodze",fac_shield(i),shield_mode
6660       eij=facont_hb(jj,i)
6661       ekl=facont_hb(kk,k)
6662       ees0pij=ees0p(jj,i)
6663       ees0pkl=ees0p(kk,k)
6664       ees0mij=ees0m(jj,i)
6665       ees0mkl=ees0m(kk,k)
6666       ekont=eij*ekl
6667       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6668 C*
6669 C     & fac_shield(i)**2*fac_shield(j)**2
6670 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6671 C Following 4 lines for diagnostics.
6672 cd    ees0pkl=0.0D0
6673 cd    ees0pij=1.0D0
6674 cd    ees0mkl=0.0D0
6675 cd    ees0mij=1.0D0
6676 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6677 c     & 'Contacts ',i,j,
6678 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6679 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6680 c     & 'gradcorr_long'
6681 C Calculate the multi-body contribution to energy.
6682 C      ecorr=ecorr+ekont*ees
6683 C Calculate multi-body contributions to the gradient.
6684       coeffpees0pij=coeffp*ees0pij
6685       coeffmees0mij=coeffm*ees0mij
6686       coeffpees0pkl=coeffp*ees0pkl
6687       coeffmees0mkl=coeffm*ees0mkl
6688       do ll=1,3
6689 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6690         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6691      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6692      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6693         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6694      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6695      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6696 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6697         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6698      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6699      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6700         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6701      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6702      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6703         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6704      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6705      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6706         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6707         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6708         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6709      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6710      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6711         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6712         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6713 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6714       enddo
6715 c      write (iout,*)
6716 cgrad      do m=i+1,j-1
6717 cgrad        do ll=1,3
6718 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6719 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6720 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6721 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6722 cgrad        enddo
6723 cgrad      enddo
6724 cgrad      do m=k+1,l-1
6725 cgrad        do ll=1,3
6726 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6727 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6728 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6729 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6730 cgrad        enddo
6731 cgrad      enddo
6732 c      write (iout,*) "ehbcorr",ekont*ees
6733 C      print *,ekont,ees,i,k
6734       ehbcorr=ekont*ees
6735 C now gradient over shielding
6736 C      return
6737       if (shield_mode.gt.0) then
6738        j=ees0plist(jj,i)
6739        l=ees0plist(kk,k)
6740 C        print *,i,j,fac_shield(i),fac_shield(j),
6741 C     &fac_shield(k),fac_shield(l)
6742         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6743      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6744           do ilist=1,ishield_list(i)
6745            iresshield=shield_list(ilist,i)
6746            do m=1,3
6747            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6748 C     &      *2.0
6749            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6750      &              rlocshield
6751      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6752             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6753      &+rlocshield
6754            enddo
6755           enddo
6756           do ilist=1,ishield_list(j)
6757            iresshield=shield_list(ilist,j)
6758            do m=1,3
6759            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6760 C     &     *2.0
6761            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6762      &              rlocshield
6763      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6764            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6765      &     +rlocshield
6766            enddo
6767           enddo
6768
6769           do ilist=1,ishield_list(k)
6770            iresshield=shield_list(ilist,k)
6771            do m=1,3
6772            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6773 C     &     *2.0
6774            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6775      &              rlocshield
6776      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6777            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6778      &     +rlocshield
6779            enddo
6780           enddo
6781           do ilist=1,ishield_list(l)
6782            iresshield=shield_list(ilist,l)
6783            do m=1,3
6784            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6785 C     &     *2.0
6786            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6787      &              rlocshield
6788      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6789            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6790      &     +rlocshield
6791            enddo
6792           enddo
6793 C          print *,gshieldx(m,iresshield)
6794           do m=1,3
6795             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6796      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6797             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6798      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6799             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6800      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6801             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6802      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6803
6804             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6805      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6806             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6807      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6808             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6809      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6810             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6811      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6812
6813            enddo
6814       endif
6815       endif
6816       return
6817       end
6818 #ifdef MOMENT
6819 C---------------------------------------------------------------------------
6820       subroutine dipole(i,j,jj)
6821       implicit real*8 (a-h,o-z)
6822       include 'DIMENSIONS'
6823       include 'DIMENSIONS.ZSCOPT'
6824       include 'COMMON.IOUNITS'
6825       include 'COMMON.CHAIN'
6826       include 'COMMON.FFIELD'
6827       include 'COMMON.DERIV'
6828       include 'COMMON.INTERACT'
6829       include 'COMMON.CONTACTS'
6830       include 'COMMON.TORSION'
6831       include 'COMMON.VAR'
6832       include 'COMMON.GEO'
6833       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6834      &  auxmat(2,2)
6835       iti1 = itortyp(itype(i+1))
6836       if (j.lt.nres-1) then
6837         itj1 = itype2loc(itype(j+1))
6838       else
6839         itj1=nloctyp
6840       endif
6841       do iii=1,2
6842         dipi(iii,1)=Ub2(iii,i)
6843         dipderi(iii)=Ub2der(iii,i)
6844         dipi(iii,2)=b1(iii,i+1)
6845         dipj(iii,1)=Ub2(iii,j)
6846         dipderj(iii)=Ub2der(iii,j)
6847         dipj(iii,2)=b1(iii,j+1)
6848       enddo
6849       kkk=0
6850       do iii=1,2
6851         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6852         do jjj=1,2
6853           kkk=kkk+1
6854           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6855         enddo
6856       enddo
6857       do kkk=1,5
6858         do lll=1,3
6859           mmm=0
6860           do iii=1,2
6861             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6862      &        auxvec(1))
6863             do jjj=1,2
6864               mmm=mmm+1
6865               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6866             enddo
6867           enddo
6868         enddo
6869       enddo
6870       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6871       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6872       do iii=1,2
6873         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6874       enddo
6875       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6876       do iii=1,2
6877         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6878       enddo
6879       return
6880       end
6881 #endif
6882 C---------------------------------------------------------------------------
6883       subroutine calc_eello(i,j,k,l,jj,kk)
6884 C
6885 C This subroutine computes matrices and vectors needed to calculate
6886 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6887 C
6888       implicit real*8 (a-h,o-z)
6889       include 'DIMENSIONS'
6890       include 'DIMENSIONS.ZSCOPT'
6891       include 'COMMON.IOUNITS'
6892       include 'COMMON.CHAIN'
6893       include 'COMMON.DERIV'
6894       include 'COMMON.INTERACT'
6895       include 'COMMON.CONTACTS'
6896       include 'COMMON.TORSION'
6897       include 'COMMON.VAR'
6898       include 'COMMON.GEO'
6899       include 'COMMON.FFIELD'
6900       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6901      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6902       logical lprn
6903       common /kutas/ lprn
6904 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6905 cd     & ' jj=',jj,' kk=',kk
6906 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6907 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6908 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6909       do iii=1,2
6910         do jjj=1,2
6911           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6912           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6913         enddo
6914       enddo
6915       call transpose2(aa1(1,1),aa1t(1,1))
6916       call transpose2(aa2(1,1),aa2t(1,1))
6917       do kkk=1,5
6918         do lll=1,3
6919           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6920      &      aa1tder(1,1,lll,kkk))
6921           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6922      &      aa2tder(1,1,lll,kkk))
6923         enddo
6924       enddo
6925       if (l.eq.j+1) then
6926 C parallel orientation of the two CA-CA-CA frames.
6927         if (i.gt.1) then
6928           iti=itype2loc(itype(i))
6929         else
6930           iti=nloctyp
6931         endif
6932         itk1=itype2loc(itype(k+1))
6933         itj=itype2loc(itype(j))
6934         if (l.lt.nres-1) then
6935           itl1=itype2loc(itype(l+1))
6936         else
6937           itl1=nloctyp
6938         endif
6939 C A1 kernel(j+1) A2T
6940 cd        do iii=1,2
6941 cd          write (iout,'(3f10.5,5x,3f10.5)')
6942 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6943 cd        enddo
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6945      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6946      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6947 C Following matrices are needed only for 6-th order cumulants
6948         IF (wcorr6.gt.0.0d0) THEN
6949         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6950      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6951      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6953      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6954      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6955      &   ADtEAderx(1,1,1,1,1,1))
6956         lprn=.false.
6957         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6958      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6959      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6960      &   ADtEA1derx(1,1,1,1,1,1))
6961         ENDIF
6962 C End 6-th order cumulants
6963 cd        lprn=.false.
6964 cd        if (lprn) then
6965 cd        write (2,*) 'In calc_eello6'
6966 cd        do iii=1,2
6967 cd          write (2,*) 'iii=',iii
6968 cd          do kkk=1,5
6969 cd            write (2,*) 'kkk=',kkk
6970 cd            do jjj=1,2
6971 cd              write (2,'(3(2f10.5),5x)')
6972 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6973 cd            enddo
6974 cd          enddo
6975 cd        enddo
6976 cd        endif
6977         call transpose2(EUgder(1,1,k),auxmat(1,1))
6978         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6979         call transpose2(EUg(1,1,k),auxmat(1,1))
6980         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6981         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6982         do iii=1,2
6983           do kkk=1,5
6984             do lll=1,3
6985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6986      &          EAEAderx(1,1,lll,kkk,iii,1))
6987             enddo
6988           enddo
6989         enddo
6990 C A1T kernel(i+1) A2
6991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6992      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6993      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6994 C Following matrices are needed only for 6-th order cumulants
6995         IF (wcorr6.gt.0.0d0) THEN
6996         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6997      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6998      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6999         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7000      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7001      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7002      &   ADtEAderx(1,1,1,1,1,2))
7003         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7004      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7005      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7006      &   ADtEA1derx(1,1,1,1,1,2))
7007         ENDIF
7008 C End 6-th order cumulants
7009         call transpose2(EUgder(1,1,l),auxmat(1,1))
7010         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7011         call transpose2(EUg(1,1,l),auxmat(1,1))
7012         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7013         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7014         do iii=1,2
7015           do kkk=1,5
7016             do lll=1,3
7017               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7018      &          EAEAderx(1,1,lll,kkk,iii,2))
7019             enddo
7020           enddo
7021         enddo
7022 C AEAb1 and AEAb2
7023 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7024 C They are needed only when the fifth- or the sixth-order cumulants are
7025 C indluded.
7026         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7027         call transpose2(AEA(1,1,1),auxmat(1,1))
7028         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7029         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7030         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7031         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7032         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7034         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7035         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7036         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7037         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7038         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7039         call transpose2(AEA(1,1,2),auxmat(1,1))
7040         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7041         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7042         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7043         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7044         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7045         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7046         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7047         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7048         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7049         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7050         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7051 C Calculate the Cartesian derivatives of the vectors.
7052         do iii=1,2
7053           do kkk=1,5
7054             do lll=1,3
7055               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7056               call matvec2(auxmat(1,1),b1(1,i),
7057      &          AEAb1derx(1,lll,kkk,iii,1,1))
7058               call matvec2(auxmat(1,1),Ub2(1,i),
7059      &          AEAb2derx(1,lll,kkk,iii,1,1))
7060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7061      &          AEAb1derx(1,lll,kkk,iii,2,1))
7062               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7063      &          AEAb2derx(1,lll,kkk,iii,2,1))
7064               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7065               call matvec2(auxmat(1,1),b1(1,j),
7066      &          AEAb1derx(1,lll,kkk,iii,1,2))
7067               call matvec2(auxmat(1,1),Ub2(1,j),
7068      &          AEAb2derx(1,lll,kkk,iii,1,2))
7069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7070      &          AEAb1derx(1,lll,kkk,iii,2,2))
7071               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7072      &          AEAb2derx(1,lll,kkk,iii,2,2))
7073             enddo
7074           enddo
7075         enddo
7076         ENDIF
7077 C End vectors
7078       else
7079 C Antiparallel orientation of the two CA-CA-CA frames.
7080         if (i.gt.1) then
7081           iti=itype2loc(itype(i))
7082         else
7083           iti=nloctyp
7084         endif
7085         itk1=itype2loc(itype(k+1))
7086         itl=itype2loc(itype(l))
7087         itj=itype2loc(itype(j))
7088         if (j.lt.nres-1) then
7089           itj1=itype2loc(itype(j+1))
7090         else
7091           itj1=nloctyp
7092         endif
7093 C A2 kernel(j-1)T A1T
7094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7095      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7096      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7097 C Following matrices are needed only for 6-th order cumulants
7098         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7099      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7101      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7102      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7103         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7104      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7105      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7106      &   ADtEAderx(1,1,1,1,1,1))
7107         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7108      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7109      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7110      &   ADtEA1derx(1,1,1,1,1,1))
7111         ENDIF
7112 C End 6-th order cumulants
7113         call transpose2(EUgder(1,1,k),auxmat(1,1))
7114         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7115         call transpose2(EUg(1,1,k),auxmat(1,1))
7116         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7117         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7118         do iii=1,2
7119           do kkk=1,5
7120             do lll=1,3
7121               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7122      &          EAEAderx(1,1,lll,kkk,iii,1))
7123             enddo
7124           enddo
7125         enddo
7126 C A2T kernel(i+1)T A1
7127         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7128      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7129      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7130 C Following matrices are needed only for 6-th order cumulants
7131         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7132      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7133         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7134      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7135      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7136         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7137      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7138      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7139      &   ADtEAderx(1,1,1,1,1,2))
7140         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7141      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7142      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7143      &   ADtEA1derx(1,1,1,1,1,2))
7144         ENDIF
7145 C End 6-th order cumulants
7146         call transpose2(EUgder(1,1,j),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7148         call transpose2(EUg(1,1,j),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7150         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7151         do iii=1,2
7152           do kkk=1,5
7153             do lll=1,3
7154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7155      &          EAEAderx(1,1,lll,kkk,iii,2))
7156             enddo
7157           enddo
7158         enddo
7159 C AEAb1 and AEAb2
7160 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7161 C They are needed only when the fifth- or the sixth-order cumulants are
7162 C indluded.
7163         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7164      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7165         call transpose2(AEA(1,1,1),auxmat(1,1))
7166         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7168         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7169         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7170         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7172         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7173         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7174         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7175         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7176         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7177         call transpose2(AEA(1,1,2),auxmat(1,1))
7178         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7179         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7180         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7181         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7182         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7183         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7184         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7185         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7186         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7187         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7188         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7189 C Calculate the Cartesian derivatives of the vectors.
7190         do iii=1,2
7191           do kkk=1,5
7192             do lll=1,3
7193               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7194               call matvec2(auxmat(1,1),b1(1,i),
7195      &          AEAb1derx(1,lll,kkk,iii,1,1))
7196               call matvec2(auxmat(1,1),Ub2(1,i),
7197      &          AEAb2derx(1,lll,kkk,iii,1,1))
7198               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7199      &          AEAb1derx(1,lll,kkk,iii,2,1))
7200               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7201      &          AEAb2derx(1,lll,kkk,iii,2,1))
7202               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7203               call matvec2(auxmat(1,1),b1(1,l),
7204      &          AEAb1derx(1,lll,kkk,iii,1,2))
7205               call matvec2(auxmat(1,1),Ub2(1,l),
7206      &          AEAb2derx(1,lll,kkk,iii,1,2))
7207               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7208      &          AEAb1derx(1,lll,kkk,iii,2,2))
7209               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7210      &          AEAb2derx(1,lll,kkk,iii,2,2))
7211             enddo
7212           enddo
7213         enddo
7214         ENDIF
7215 C End vectors
7216       endif
7217       return
7218       end
7219 C---------------------------------------------------------------------------
7220       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7221      &  KK,KKderg,AKA,AKAderg,AKAderx)
7222       implicit none
7223       integer nderg
7224       logical transp
7225       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7226      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7227      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7228       integer iii,kkk,lll
7229       integer jjj,mmm
7230       logical lprn
7231       common /kutas/ lprn
7232       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7233       do iii=1,nderg
7234         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7235      &    AKAderg(1,1,iii))
7236       enddo
7237 cd      if (lprn) write (2,*) 'In kernel'
7238       do kkk=1,5
7239 cd        if (lprn) write (2,*) 'kkk=',kkk
7240         do lll=1,3
7241           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7242      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7243 cd          if (lprn) then
7244 cd            write (2,*) 'lll=',lll
7245 cd            write (2,*) 'iii=1'
7246 cd            do jjj=1,2
7247 cd              write (2,'(3(2f10.5),5x)')
7248 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7249 cd            enddo
7250 cd          endif
7251           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7252      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7253 cd          if (lprn) then
7254 cd            write (2,*) 'lll=',lll
7255 cd            write (2,*) 'iii=2'
7256 cd            do jjj=1,2
7257 cd              write (2,'(3(2f10.5),5x)')
7258 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7259 cd            enddo
7260 cd          endif
7261         enddo
7262       enddo
7263       return
7264       end
7265 C---------------------------------------------------------------------------
7266       double precision function eello4(i,j,k,l,jj,kk)
7267       implicit real*8 (a-h,o-z)
7268       include 'DIMENSIONS'
7269       include 'DIMENSIONS.ZSCOPT'
7270       include 'COMMON.IOUNITS'
7271       include 'COMMON.CHAIN'
7272       include 'COMMON.DERIV'
7273       include 'COMMON.INTERACT'
7274       include 'COMMON.CONTACTS'
7275       include 'COMMON.TORSION'
7276       include 'COMMON.VAR'
7277       include 'COMMON.GEO'
7278       double precision pizda(2,2),ggg1(3),ggg2(3)
7279 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7280 cd        eello4=0.0d0
7281 cd        return
7282 cd      endif
7283 cd      print *,'eello4:',i,j,k,l,jj,kk
7284 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7285 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7286 cold      eij=facont_hb(jj,i)
7287 cold      ekl=facont_hb(kk,k)
7288 cold      ekont=eij*ekl
7289       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7290       if (calc_grad) then
7291 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7292       gcorr_loc(k-1)=gcorr_loc(k-1)
7293      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7294       if (l.eq.j+1) then
7295         gcorr_loc(l-1)=gcorr_loc(l-1)
7296      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7297       else
7298         gcorr_loc(j-1)=gcorr_loc(j-1)
7299      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7300       endif
7301       do iii=1,2
7302         do kkk=1,5
7303           do lll=1,3
7304             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7305      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7306 cd            derx(lll,kkk,iii)=0.0d0
7307           enddo
7308         enddo
7309       enddo
7310 cd      gcorr_loc(l-1)=0.0d0
7311 cd      gcorr_loc(j-1)=0.0d0
7312 cd      gcorr_loc(k-1)=0.0d0
7313 cd      eel4=1.0d0
7314 cd      write (iout,*)'Contacts have occurred for peptide groups',
7315 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7316 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7317       if (j.lt.nres-1) then
7318         j1=j+1
7319         j2=j-1
7320       else
7321         j1=j-1
7322         j2=j-2
7323       endif
7324       if (l.lt.nres-1) then
7325         l1=l+1
7326         l2=l-1
7327       else
7328         l1=l-1
7329         l2=l-2
7330       endif
7331       do ll=1,3
7332 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7333 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7334         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7335         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7336 cgrad        ghalf=0.5d0*ggg1(ll)
7337         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7338         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7339         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7340         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7341         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7342         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7343 cgrad        ghalf=0.5d0*ggg2(ll)
7344         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7345         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7346         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7347         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7348         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7349         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7350       enddo
7351 cgrad      do m=i+1,j-1
7352 cgrad        do ll=1,3
7353 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7354 cgrad        enddo
7355 cgrad      enddo
7356 cgrad      do m=k+1,l-1
7357 cgrad        do ll=1,3
7358 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7359 cgrad        enddo
7360 cgrad      enddo
7361 cgrad      do m=i+2,j2
7362 cgrad        do ll=1,3
7363 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7364 cgrad        enddo
7365 cgrad      enddo
7366 cgrad      do m=k+2,l2
7367 cgrad        do ll=1,3
7368 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7369 cgrad        enddo
7370 cgrad      enddo
7371 cd      do iii=1,nres-3
7372 cd        write (2,*) iii,gcorr_loc(iii)
7373 cd      enddo
7374       endif ! calc_grad
7375       eello4=ekont*eel4
7376 cd      write (2,*) 'ekont',ekont
7377 cd      write (iout,*) 'eello4',ekont*eel4
7378       return
7379       end
7380 C---------------------------------------------------------------------------
7381       double precision function eello5(i,j,k,l,jj,kk)
7382       implicit real*8 (a-h,o-z)
7383       include 'DIMENSIONS'
7384       include 'DIMENSIONS.ZSCOPT'
7385       include 'COMMON.IOUNITS'
7386       include 'COMMON.CHAIN'
7387       include 'COMMON.DERIV'
7388       include 'COMMON.INTERACT'
7389       include 'COMMON.CONTACTS'
7390       include 'COMMON.TORSION'
7391       include 'COMMON.VAR'
7392       include 'COMMON.GEO'
7393       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7394       double precision ggg1(3),ggg2(3)
7395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7396 C                                                                              C
7397 C                            Parallel chains                                   C
7398 C                                                                              C
7399 C          o             o                   o             o                   C
7400 C         /l\           / \             \   / \           / \   /              C
7401 C        /   \         /   \             \ /   \         /   \ /               C
7402 C       j| o |l1       | o |              o| o |         | o |o                C
7403 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7404 C      \i/   \         /   \ /             /   \         /   \                 C
7405 C       o    k1             o                                                  C
7406 C         (I)          (II)                (III)          (IV)                 C
7407 C                                                                              C
7408 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7409 C                                                                              C
7410 C                            Antiparallel chains                               C
7411 C                                                                              C
7412 C          o             o                   o             o                   C
7413 C         /j\           / \             \   / \           / \   /              C
7414 C        /   \         /   \             \ /   \         /   \ /               C
7415 C      j1| o |l        | o |              o| o |         | o |o                C
7416 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7417 C      \i/   \         /   \ /             /   \         /   \                 C
7418 C       o     k1            o                                                  C
7419 C         (I)          (II)                (III)          (IV)                 C
7420 C                                                                              C
7421 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7422 C                                                                              C
7423 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7424 C                                                                              C
7425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7426 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7427 cd        eello5=0.0d0
7428 cd        return
7429 cd      endif
7430 cd      write (iout,*)
7431 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7432 cd     &   ' and',k,l
7433       itk=itype2loc(itype(k))
7434       itl=itype2loc(itype(l))
7435       itj=itype2loc(itype(j))
7436       eello5_1=0.0d0
7437       eello5_2=0.0d0
7438       eello5_3=0.0d0
7439       eello5_4=0.0d0
7440 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7441 cd     &   eel5_3_num,eel5_4_num)
7442       do iii=1,2
7443         do kkk=1,5
7444           do lll=1,3
7445             derx(lll,kkk,iii)=0.0d0
7446           enddo
7447         enddo
7448       enddo
7449 cd      eij=facont_hb(jj,i)
7450 cd      ekl=facont_hb(kk,k)
7451 cd      ekont=eij*ekl
7452 cd      write (iout,*)'Contacts have occurred for peptide groups',
7453 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7454 cd      goto 1111
7455 C Contribution from the graph I.
7456 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7457 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7458       call transpose2(EUg(1,1,k),auxmat(1,1))
7459       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7460       vv(1)=pizda(1,1)-pizda(2,2)
7461       vv(2)=pizda(1,2)+pizda(2,1)
7462       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7463      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7464       if (calc_grad) then
7465 C Explicit gradient in virtual-dihedral angles.
7466       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7467      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7468      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7469       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7470       call matmat2(AEA(1,1,1),auxmat1(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(AEAb2(1,1,1),Ub2der(1,k))
7475      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7476       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7477       vv(1)=pizda(1,1)-pizda(2,2)
7478       vv(2)=pizda(1,2)+pizda(2,1)
7479       if (l.eq.j+1) then
7480         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7481      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7483       else
7484         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7485      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7486      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7487       endif
7488 C Cartesian gradient
7489       do iii=1,2
7490         do kkk=1,5
7491           do lll=1,3
7492             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7493      &        pizda(1,1))
7494             vv(1)=pizda(1,1)-pizda(2,2)
7495             vv(2)=pizda(1,2)+pizda(2,1)
7496             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7497      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7498      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7499           enddo
7500         enddo
7501       enddo
7502       endif ! calc_grad
7503 c      goto 1112
7504 c1111  continue
7505 C Contribution from graph II
7506       call transpose2(EE(1,1,k),auxmat(1,1))
7507       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7508       vv(1)=pizda(1,1)+pizda(2,2)
7509       vv(2)=pizda(2,1)-pizda(1,2)
7510       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7511      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7512       if (calc_grad) then
7513 C Explicit gradient in virtual-dihedral angles.
7514       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7515      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7516       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7517       vv(1)=pizda(1,1)+pizda(2,2)
7518       vv(2)=pizda(2,1)-pizda(1,2)
7519       if (l.eq.j+1) then
7520         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7521      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7522      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7523       else
7524         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7525      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7526      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7527       endif
7528 C Cartesian gradient
7529       do iii=1,2
7530         do kkk=1,5
7531           do lll=1,3
7532             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7533      &        pizda(1,1))
7534             vv(1)=pizda(1,1)+pizda(2,2)
7535             vv(2)=pizda(2,1)-pizda(1,2)
7536             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7537      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7538      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7539           enddo
7540         enddo
7541       enddo
7542       endif ! calc_grad
7543 cd      goto 1112
7544 cd1111  continue
7545       if (l.eq.j+1) then
7546 cd        goto 1110
7547 C Parallel orientation
7548 C Contribution from graph III
7549         call transpose2(EUg(1,1,l),auxmat(1,1))
7550         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7551         vv(1)=pizda(1,1)-pizda(2,2)
7552         vv(2)=pizda(1,2)+pizda(2,1)
7553         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7554      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7555         if (calc_grad) then
7556 C Explicit gradient in virtual-dihedral angles.
7557         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7558      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7559      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7560         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7561         vv(1)=pizda(1,1)-pizda(2,2)
7562         vv(2)=pizda(1,2)+pizda(2,1)
7563         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7564      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7565      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7566         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7567         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7568         vv(1)=pizda(1,1)-pizda(2,2)
7569         vv(2)=pizda(1,2)+pizda(2,1)
7570         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7571      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7572      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7573 C Cartesian gradient
7574         do iii=1,2
7575           do kkk=1,5
7576             do lll=1,3
7577               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7578      &          pizda(1,1))
7579               vv(1)=pizda(1,1)-pizda(2,2)
7580               vv(2)=pizda(1,2)+pizda(2,1)
7581               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7582      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7583      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7584             enddo
7585           enddo
7586         enddo
7587 cd        goto 1112
7588 C Contribution from graph IV
7589 cd1110    continue
7590         call transpose2(EE(1,1,l),auxmat(1,1))
7591         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7592         vv(1)=pizda(1,1)+pizda(2,2)
7593         vv(2)=pizda(2,1)-pizda(1,2)
7594         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7595      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7596 C Explicit gradient in virtual-dihedral angles.
7597         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7598      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7599         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7600         vv(1)=pizda(1,1)+pizda(2,2)
7601         vv(2)=pizda(2,1)-pizda(1,2)
7602         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7603      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7604      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7605 C Cartesian gradient
7606         do iii=1,2
7607           do kkk=1,5
7608             do lll=1,3
7609               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7610      &          pizda(1,1))
7611               vv(1)=pizda(1,1)+pizda(2,2)
7612               vv(2)=pizda(2,1)-pizda(1,2)
7613               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7614      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7615      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7616             enddo
7617           enddo
7618         enddo
7619         endif ! calc_grad
7620       else
7621 C Antiparallel orientation
7622 C Contribution from graph III
7623 c        goto 1110
7624         call transpose2(EUg(1,1,j),auxmat(1,1))
7625         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7626         vv(1)=pizda(1,1)-pizda(2,2)
7627         vv(2)=pizda(1,2)+pizda(2,1)
7628         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7630         if (calc_grad) then
7631 C Explicit gradient in virtual-dihedral angles.
7632         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7633      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7634      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7635         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7636         vv(1)=pizda(1,1)-pizda(2,2)
7637         vv(2)=pizda(1,2)+pizda(2,1)
7638         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7639      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7640      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7641         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7642         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7643         vv(1)=pizda(1,1)-pizda(2,2)
7644         vv(2)=pizda(1,2)+pizda(2,1)
7645         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7646      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7648 C Cartesian gradient
7649         do iii=1,2
7650           do kkk=1,5
7651             do lll=1,3
7652               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7653      &          pizda(1,1))
7654               vv(1)=pizda(1,1)-pizda(2,2)
7655               vv(2)=pizda(1,2)+pizda(2,1)
7656               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7657      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7658      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7659             enddo
7660           enddo
7661         enddo
7662         endif ! calc_grad
7663 cd        goto 1112
7664 C Contribution from graph IV
7665 1110    continue
7666         call transpose2(EE(1,1,j),auxmat(1,1))
7667         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7668         vv(1)=pizda(1,1)+pizda(2,2)
7669         vv(2)=pizda(2,1)-pizda(1,2)
7670         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7671      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7672         if (calc_grad) then
7673 C Explicit gradient in virtual-dihedral angles.
7674         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7675      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7676         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7677         vv(1)=pizda(1,1)+pizda(2,2)
7678         vv(2)=pizda(2,1)-pizda(1,2)
7679         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7680      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7681      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7682 C Cartesian gradient
7683         do iii=1,2
7684           do kkk=1,5
7685             do lll=1,3
7686               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7687      &          pizda(1,1))
7688               vv(1)=pizda(1,1)+pizda(2,2)
7689               vv(2)=pizda(2,1)-pizda(1,2)
7690               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7691      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7692      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7693             enddo
7694           enddo
7695         enddo
7696         endif ! calc_grad
7697       endif
7698 1112  continue
7699       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7700 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7701 cd        write (2,*) 'ijkl',i,j,k,l
7702 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7703 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7704 cd      endif
7705 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7706 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7707 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7708 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7709       if (calc_grad) then
7710       if (j.lt.nres-1) then
7711         j1=j+1
7712         j2=j-1
7713       else
7714         j1=j-1
7715         j2=j-2
7716       endif
7717       if (l.lt.nres-1) then
7718         l1=l+1
7719         l2=l-1
7720       else
7721         l1=l-1
7722         l2=l-2
7723       endif
7724 cd      eij=1.0d0
7725 cd      ekl=1.0d0
7726 cd      ekont=1.0d0
7727 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7728 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7729 C        summed up outside the subrouine as for the other subroutines
7730 C        handling long-range interactions. The old code is commented out
7731 C        with "cgrad" to keep track of changes.
7732       do ll=1,3
7733 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7734 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7735         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7736         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7737 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7738 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7739 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7740 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7741 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7742 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7743 c     &   gradcorr5ij,
7744 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7745 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7746 cgrad        ghalf=0.5d0*ggg1(ll)
7747 cd        ghalf=0.0d0
7748         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7749         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7750         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7751         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7752         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7753         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7754 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7755 cgrad        ghalf=0.5d0*ggg2(ll)
7756 cd        ghalf=0.0d0
7757         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7758         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7759         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7760         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7761         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7762         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7763       enddo
7764       endif ! calc_grad
7765 cd      goto 1112
7766 cgrad      do m=i+1,j-1
7767 cgrad        do ll=1,3
7768 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7769 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7770 cgrad        enddo
7771 cgrad      enddo
7772 cgrad      do m=k+1,l-1
7773 cgrad        do ll=1,3
7774 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7775 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7776 cgrad        enddo
7777 cgrad      enddo
7778 c1112  continue
7779 cgrad      do m=i+2,j2
7780 cgrad        do ll=1,3
7781 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7782 cgrad        enddo
7783 cgrad      enddo
7784 cgrad      do m=k+2,l2
7785 cgrad        do ll=1,3
7786 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7787 cgrad        enddo
7788 cgrad      enddo
7789 cd      do iii=1,nres-3
7790 cd        write (2,*) iii,g_corr5_loc(iii)
7791 cd      enddo
7792       eello5=ekont*eel5
7793 cd      write (2,*) 'ekont',ekont
7794 cd      write (iout,*) 'eello5',ekont*eel5
7795       return
7796       end
7797 c--------------------------------------------------------------------------
7798       double precision function eello6(i,j,k,l,jj,kk)
7799       implicit real*8 (a-h,o-z)
7800       include 'DIMENSIONS'
7801       include 'DIMENSIONS.ZSCOPT'
7802       include 'COMMON.IOUNITS'
7803       include 'COMMON.CHAIN'
7804       include 'COMMON.DERIV'
7805       include 'COMMON.INTERACT'
7806       include 'COMMON.CONTACTS'
7807       include 'COMMON.TORSION'
7808       include 'COMMON.VAR'
7809       include 'COMMON.GEO'
7810       include 'COMMON.FFIELD'
7811       double precision ggg1(3),ggg2(3)
7812 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7813 cd        eello6=0.0d0
7814 cd        return
7815 cd      endif
7816 cd      write (iout,*)
7817 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7818 cd     &   ' and',k,l
7819       eello6_1=0.0d0
7820       eello6_2=0.0d0
7821       eello6_3=0.0d0
7822       eello6_4=0.0d0
7823       eello6_5=0.0d0
7824       eello6_6=0.0d0
7825 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7826 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7827       do iii=1,2
7828         do kkk=1,5
7829           do lll=1,3
7830             derx(lll,kkk,iii)=0.0d0
7831           enddo
7832         enddo
7833       enddo
7834 cd      eij=facont_hb(jj,i)
7835 cd      ekl=facont_hb(kk,k)
7836 cd      ekont=eij*ekl
7837 cd      eij=1.0d0
7838 cd      ekl=1.0d0
7839 cd      ekont=1.0d0
7840       if (l.eq.j+1) then
7841         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7842         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7843         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7844         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7845         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7846         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7847       else
7848         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7849         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7850         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7851         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7852         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7853           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7854         else
7855           eello6_5=0.0d0
7856         endif
7857         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7858       endif
7859 C If turn contributions are considered, they will be handled separately.
7860       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7861 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7862 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7863 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7864 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7865 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7866 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7867 cd      goto 1112
7868       if (calc_grad) then
7869       if (j.lt.nres-1) then
7870         j1=j+1
7871         j2=j-1
7872       else
7873         j1=j-1
7874         j2=j-2
7875       endif
7876       if (l.lt.nres-1) then
7877         l1=l+1
7878         l2=l-1
7879       else
7880         l1=l-1
7881         l2=l-2
7882       endif
7883       do ll=1,3
7884 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7885 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7886 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7887 cgrad        ghalf=0.5d0*ggg1(ll)
7888 cd        ghalf=0.0d0
7889         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7890         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7891         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7892         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7893         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7894         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7895         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7896         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7897 cgrad        ghalf=0.5d0*ggg2(ll)
7898 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7899 cd        ghalf=0.0d0
7900         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7901         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7902         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7903         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7904         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7905         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7906       enddo
7907       endif ! calc_grad
7908 cd      goto 1112
7909 cgrad      do m=i+1,j-1
7910 cgrad        do ll=1,3
7911 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7912 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7913 cgrad        enddo
7914 cgrad      enddo
7915 cgrad      do m=k+1,l-1
7916 cgrad        do ll=1,3
7917 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7918 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7919 cgrad        enddo
7920 cgrad      enddo
7921 cgrad1112  continue
7922 cgrad      do m=i+2,j2
7923 cgrad        do ll=1,3
7924 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7925 cgrad        enddo
7926 cgrad      enddo
7927 cgrad      do m=k+2,l2
7928 cgrad        do ll=1,3
7929 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7930 cgrad        enddo
7931 cgrad      enddo
7932 cd      do iii=1,nres-3
7933 cd        write (2,*) iii,g_corr6_loc(iii)
7934 cd      enddo
7935       eello6=ekont*eel6
7936 cd      write (2,*) 'ekont',ekont
7937 cd      write (iout,*) 'eello6',ekont*eel6
7938       return
7939       end
7940 c--------------------------------------------------------------------------
7941       double precision function eello6_graph1(i,j,k,l,imat,swap)
7942       implicit real*8 (a-h,o-z)
7943       include 'DIMENSIONS'
7944       include 'DIMENSIONS.ZSCOPT'
7945       include 'COMMON.IOUNITS'
7946       include 'COMMON.CHAIN'
7947       include 'COMMON.DERIV'
7948       include 'COMMON.INTERACT'
7949       include 'COMMON.CONTACTS'
7950       include 'COMMON.TORSION'
7951       include 'COMMON.VAR'
7952       include 'COMMON.GEO'
7953       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7954       logical swap
7955       logical lprn
7956       common /kutas/ lprn
7957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7958 C                                                                              C
7959 C      Parallel       Antiparallel                                             C
7960 C                                                                              C
7961 C          o             o                                                     C
7962 C         /l\           /j\                                                    C
7963 C        /   \         /   \                                                   C
7964 C       /| o |         | o |\                                                  C
7965 C     \ j|/k\|  /   \  |/k\|l /                                                C
7966 C      \ /   \ /     \ /   \ /                                                 C
7967 C       o     o       o     o                                                  C
7968 C       i             i                                                        C
7969 C                                                                              C
7970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7971       itk=itype2loc(itype(k))
7972       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7973       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7974       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7975       call transpose2(EUgC(1,1,k),auxmat(1,1))
7976       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7977       vv1(1)=pizda1(1,1)-pizda1(2,2)
7978       vv1(2)=pizda1(1,2)+pizda1(2,1)
7979       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7980       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7981       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7982       s5=scalar2(vv(1),Dtobr2(1,i))
7983 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7984       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7985       if (calc_grad) then
7986       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7987      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7988      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7989      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7990      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7991      & +scalar2(vv(1),Dtobr2der(1,i)))
7992       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7993       vv1(1)=pizda1(1,1)-pizda1(2,2)
7994       vv1(2)=pizda1(1,2)+pizda1(2,1)
7995       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7996       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7997       if (l.eq.j+1) then
7998         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7999      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8000      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8001      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8002      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8003       else
8004         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8005      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8006      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8007      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8008      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8009       endif
8010       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8011       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8012       vv1(1)=pizda1(1,1)-pizda1(2,2)
8013       vv1(2)=pizda1(1,2)+pizda1(2,1)
8014       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8015      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8016      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8017      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8018       do iii=1,2
8019         if (swap) then
8020           ind=3-iii
8021         else
8022           ind=iii
8023         endif
8024         do kkk=1,5
8025           do lll=1,3
8026             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8027             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8028             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8029             call transpose2(EUgC(1,1,k),auxmat(1,1))
8030             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8031      &        pizda1(1,1))
8032             vv1(1)=pizda1(1,1)-pizda1(2,2)
8033             vv1(2)=pizda1(1,2)+pizda1(2,1)
8034             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8035             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8036      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8037             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8038      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8039             s5=scalar2(vv(1),Dtobr2(1,i))
8040             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8041           enddo
8042         enddo
8043       enddo
8044       endif ! calc_grad
8045       return
8046       end
8047 c----------------------------------------------------------------------------
8048       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8049       implicit real*8 (a-h,o-z)
8050       include 'DIMENSIONS'
8051       include 'DIMENSIONS.ZSCOPT'
8052       include 'COMMON.IOUNITS'
8053       include 'COMMON.CHAIN'
8054       include 'COMMON.DERIV'
8055       include 'COMMON.INTERACT'
8056       include 'COMMON.CONTACTS'
8057       include 'COMMON.TORSION'
8058       include 'COMMON.VAR'
8059       include 'COMMON.GEO'
8060       logical swap
8061       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8062      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8063       logical lprn
8064       common /kutas/ lprn
8065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8066 C                                                                              C
8067 C      Parallel       Antiparallel                                             C
8068 C                                                                              C
8069 C          o             o                                                     C
8070 C     \   /l\           /j\   /                                                C
8071 C      \ /   \         /   \ /                                                 C
8072 C       o| o |         | o |o                                                  C
8073 C     \ j|/k\|      \  |/k\|l                                                  C
8074 C      \ /   \       \ /   \                                                   C
8075 C       o             o                                                        C
8076 C       i             i                                                        C
8077 C                                                                              C
8078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8079 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8080 C AL 7/4/01 s1 would occur in the sixth-order moment,
8081 C           but not in a cluster cumulant
8082 #ifdef MOMENT
8083       s1=dip(1,jj,i)*dip(1,kk,k)
8084 #endif
8085       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8086       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8087       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8088       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8089       call transpose2(EUg(1,1,k),auxmat(1,1))
8090       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8091       vv(1)=pizda(1,1)-pizda(2,2)
8092       vv(2)=pizda(1,2)+pizda(2,1)
8093       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8094 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8095 #ifdef MOMENT
8096       eello6_graph2=-(s1+s2+s3+s4)
8097 #else
8098       eello6_graph2=-(s2+s3+s4)
8099 #endif
8100 c      eello6_graph2=-s3
8101 C Derivatives in gamma(i-1)
8102       if (calc_grad) then
8103       if (i.gt.1) then
8104 #ifdef MOMENT
8105         s1=dipderg(1,jj,i)*dip(1,kk,k)
8106 #endif
8107         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8108         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8109         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8110         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8111 #ifdef MOMENT
8112         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8113 #else
8114         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8115 #endif
8116 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8117       endif
8118 C Derivatives in gamma(k-1)
8119 #ifdef MOMENT
8120       s1=dip(1,jj,i)*dipderg(1,kk,k)
8121 #endif
8122       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8123       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8124       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8125       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8126       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8127       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8128       vv(1)=pizda(1,1)-pizda(2,2)
8129       vv(2)=pizda(1,2)+pizda(2,1)
8130       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8131 #ifdef MOMENT
8132       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8133 #else
8134       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8135 #endif
8136 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8137 C Derivatives in gamma(j-1) or gamma(l-1)
8138       if (j.gt.1) then
8139 #ifdef MOMENT
8140         s1=dipderg(3,jj,i)*dip(1,kk,k)
8141 #endif
8142         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8143         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8144         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8145         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8146         vv(1)=pizda(1,1)-pizda(2,2)
8147         vv(2)=pizda(1,2)+pizda(2,1)
8148         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8149 #ifdef MOMENT
8150         if (swap) then
8151           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8152         else
8153           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8154         endif
8155 #endif
8156         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8157 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8158       endif
8159 C Derivatives in gamma(l-1) or gamma(j-1)
8160       if (l.gt.1) then
8161 #ifdef MOMENT
8162         s1=dip(1,jj,i)*dipderg(3,kk,k)
8163 #endif
8164         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8165         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8166         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8167         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8168         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8169         vv(1)=pizda(1,1)-pizda(2,2)
8170         vv(2)=pizda(1,2)+pizda(2,1)
8171         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8172 #ifdef MOMENT
8173         if (swap) then
8174           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8175         else
8176           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8177         endif
8178 #endif
8179         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8180 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8181       endif
8182 C Cartesian derivatives.
8183       if (lprn) then
8184         write (2,*) 'In eello6_graph2'
8185         do iii=1,2
8186           write (2,*) 'iii=',iii
8187           do kkk=1,5
8188             write (2,*) 'kkk=',kkk
8189             do jjj=1,2
8190               write (2,'(3(2f10.5),5x)')
8191      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8192             enddo
8193           enddo
8194         enddo
8195       endif
8196       do iii=1,2
8197         do kkk=1,5
8198           do lll=1,3
8199 #ifdef MOMENT
8200             if (iii.eq.1) then
8201               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8202             else
8203               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8204             endif
8205 #endif
8206             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8207      &        auxvec(1))
8208             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8209             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8210      &        auxvec(1))
8211             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8212             call transpose2(EUg(1,1,k),auxmat(1,1))
8213             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8214      &        pizda(1,1))
8215             vv(1)=pizda(1,1)-pizda(2,2)
8216             vv(2)=pizda(1,2)+pizda(2,1)
8217             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8218 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8219 #ifdef MOMENT
8220             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8221 #else
8222             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8223 #endif
8224             if (swap) then
8225               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8226             else
8227               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8228             endif
8229           enddo
8230         enddo
8231       enddo
8232       endif ! calc_grad
8233       return
8234       end
8235 c----------------------------------------------------------------------------
8236       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8237       implicit real*8 (a-h,o-z)
8238       include 'DIMENSIONS'
8239       include 'DIMENSIONS.ZSCOPT'
8240       include 'COMMON.IOUNITS'
8241       include 'COMMON.CHAIN'
8242       include 'COMMON.DERIV'
8243       include 'COMMON.INTERACT'
8244       include 'COMMON.CONTACTS'
8245       include 'COMMON.TORSION'
8246       include 'COMMON.VAR'
8247       include 'COMMON.GEO'
8248       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8249       logical swap
8250 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8251 C                                                                              C
8252 C      Parallel       Antiparallel                                             C
8253 C                                                                              C
8254 C          o             o                                                     C
8255 C         /l\   /   \   /j\                                                    C
8256 C        /   \ /     \ /   \                                                   C
8257 C       /| o |o       o| o |\                                                  C
8258 C       j|/k\|  /      |/k\|l /                                                C
8259 C        /   \ /       /   \ /                                                 C
8260 C       /     o       /     o                                                  C
8261 C       i             i                                                        C
8262 C                                                                              C
8263 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8264 C
8265 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8266 C           energy moment and not to the cluster cumulant.
8267       iti=itortyp(itype(i))
8268       if (j.lt.nres-1) then
8269         itj1=itype2loc(itype(j+1))
8270       else
8271         itj1=nloctyp
8272       endif
8273       itk=itype2loc(itype(k))
8274       itk1=itype2loc(itype(k+1))
8275       if (l.lt.nres-1) then
8276         itl1=itype2loc(itype(l+1))
8277       else
8278         itl1=nloctyp
8279       endif
8280 #ifdef MOMENT
8281       s1=dip(4,jj,i)*dip(4,kk,k)
8282 #endif
8283       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8284       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8285       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8286       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8287       call transpose2(EE(1,1,k),auxmat(1,1))
8288       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8289       vv(1)=pizda(1,1)+pizda(2,2)
8290       vv(2)=pizda(2,1)-pizda(1,2)
8291       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8292 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8293 cd     & "sum",-(s2+s3+s4)
8294 #ifdef MOMENT
8295       eello6_graph3=-(s1+s2+s3+s4)
8296 #else
8297       eello6_graph3=-(s2+s3+s4)
8298 #endif
8299 c      eello6_graph3=-s4
8300 C Derivatives in gamma(k-1)
8301       if (calc_grad) then
8302       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8303       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8304       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8305       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8306 C Derivatives in gamma(l-1)
8307       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8308       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8309       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8310       vv(1)=pizda(1,1)+pizda(2,2)
8311       vv(2)=pizda(2,1)-pizda(1,2)
8312       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8313       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8314 C Cartesian derivatives.
8315       do iii=1,2
8316         do kkk=1,5
8317           do lll=1,3
8318 #ifdef MOMENT
8319             if (iii.eq.1) then
8320               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8321             else
8322               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8323             endif
8324 #endif
8325             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8326      &        auxvec(1))
8327             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8328             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8329      &        auxvec(1))
8330             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8331             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8332      &        pizda(1,1))
8333             vv(1)=pizda(1,1)+pizda(2,2)
8334             vv(2)=pizda(2,1)-pizda(1,2)
8335             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8336 #ifdef MOMENT
8337             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8338 #else
8339             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8340 #endif
8341             if (swap) then
8342               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8343             else
8344               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8345             endif
8346 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8347           enddo
8348         enddo
8349       enddo
8350       endif ! calc_grad
8351       return
8352       end
8353 c----------------------------------------------------------------------------
8354       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8355       implicit real*8 (a-h,o-z)
8356       include 'DIMENSIONS'
8357       include 'DIMENSIONS.ZSCOPT'
8358       include 'COMMON.IOUNITS'
8359       include 'COMMON.CHAIN'
8360       include 'COMMON.DERIV'
8361       include 'COMMON.INTERACT'
8362       include 'COMMON.CONTACTS'
8363       include 'COMMON.TORSION'
8364       include 'COMMON.VAR'
8365       include 'COMMON.GEO'
8366       include 'COMMON.FFIELD'
8367       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8368      & auxvec1(2),auxmat1(2,2)
8369       logical swap
8370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8371 C                                                                              C
8372 C      Parallel       Antiparallel                                             C
8373 C                                                                              C
8374 C          o             o                                                     C
8375 C         /l\   /   \   /j\                                                    C
8376 C        /   \ /     \ /   \                                                   C
8377 C       /| o |o       o| o |\                                                  C
8378 C     \ j|/k\|      \  |/k\|l                                                  C
8379 C      \ /   \       \ /   \                                                   C
8380 C       o     \       o     \                                                  C
8381 C       i             i                                                        C
8382 C                                                                              C
8383 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8384 C
8385 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8386 C           energy moment and not to the cluster cumulant.
8387 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8388       iti=itype2loc(itype(i))
8389       itj=itype2loc(itype(j))
8390       if (j.lt.nres-1) then
8391         itj1=itype2loc(itype(j+1))
8392       else
8393         itj1=nloctyp
8394       endif
8395       itk=itype2loc(itype(k))
8396       if (k.lt.nres-1) then
8397         itk1=itype2loc(itype(k+1))
8398       else
8399         itk1=nloctyp
8400       endif
8401       itl=itype2loc(itype(l))
8402       if (l.lt.nres-1) then
8403         itl1=itype2loc(itype(l+1))
8404       else
8405         itl1=nloctyp
8406       endif
8407 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8408 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8409 cd     & ' itl',itl,' itl1',itl1
8410 #ifdef MOMENT
8411       if (imat.eq.1) then
8412         s1=dip(3,jj,i)*dip(3,kk,k)
8413       else
8414         s1=dip(2,jj,j)*dip(2,kk,l)
8415       endif
8416 #endif
8417       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8418       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8419       if (j.eq.l+1) then
8420         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8421         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8422       else
8423         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8424         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8425       endif
8426       call transpose2(EUg(1,1,k),auxmat(1,1))
8427       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8428       vv(1)=pizda(1,1)-pizda(2,2)
8429       vv(2)=pizda(2,1)+pizda(1,2)
8430       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8431 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8432 #ifdef MOMENT
8433       eello6_graph4=-(s1+s2+s3+s4)
8434 #else
8435       eello6_graph4=-(s2+s3+s4)
8436 #endif
8437 C Derivatives in gamma(i-1)
8438       if (calc_grad) then
8439       if (i.gt.1) then
8440 #ifdef MOMENT
8441         if (imat.eq.1) then
8442           s1=dipderg(2,jj,i)*dip(3,kk,k)
8443         else
8444           s1=dipderg(4,jj,j)*dip(2,kk,l)
8445         endif
8446 #endif
8447         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8448         if (j.eq.l+1) then
8449           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8450           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8451         else
8452           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8453           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8454         endif
8455         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8456         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8457 cd          write (2,*) 'turn6 derivatives'
8458 #ifdef MOMENT
8459           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8460 #else
8461           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8462 #endif
8463         else
8464 #ifdef MOMENT
8465           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8466 #else
8467           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8468 #endif
8469         endif
8470       endif
8471 C Derivatives in gamma(k-1)
8472 #ifdef MOMENT
8473       if (imat.eq.1) then
8474         s1=dip(3,jj,i)*dipderg(2,kk,k)
8475       else
8476         s1=dip(2,jj,j)*dipderg(4,kk,l)
8477       endif
8478 #endif
8479       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8480       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8481       if (j.eq.l+1) then
8482         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8483         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8484       else
8485         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8486         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8487       endif
8488       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8489       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8490       vv(1)=pizda(1,1)-pizda(2,2)
8491       vv(2)=pizda(2,1)+pizda(1,2)
8492       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8493       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8494 #ifdef MOMENT
8495         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8496 #else
8497         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8498 #endif
8499       else
8500 #ifdef MOMENT
8501         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8502 #else
8503         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8504 #endif
8505       endif
8506 C Derivatives in gamma(j-1) or gamma(l-1)
8507       if (l.eq.j+1 .and. l.gt.1) then
8508         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8509         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8510         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8511         vv(1)=pizda(1,1)-pizda(2,2)
8512         vv(2)=pizda(2,1)+pizda(1,2)
8513         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8514         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8515       else if (j.gt.1) then
8516         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8517         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8518         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8519         vv(1)=pizda(1,1)-pizda(2,2)
8520         vv(2)=pizda(2,1)+pizda(1,2)
8521         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8522         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8523           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8524         else
8525           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8526         endif
8527       endif
8528 C Cartesian derivatives.
8529       do iii=1,2
8530         do kkk=1,5
8531           do lll=1,3
8532 #ifdef MOMENT
8533             if (iii.eq.1) then
8534               if (imat.eq.1) then
8535                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8536               else
8537                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8538               endif
8539             else
8540               if (imat.eq.1) then
8541                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8542               else
8543                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8544               endif
8545             endif
8546 #endif
8547             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8548      &        auxvec(1))
8549             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8550             if (j.eq.l+1) then
8551               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8552      &          b1(1,j+1),auxvec(1))
8553               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8554             else
8555               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8556      &          b1(1,l+1),auxvec(1))
8557               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8558             endif
8559             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8560      &        pizda(1,1))
8561             vv(1)=pizda(1,1)-pizda(2,2)
8562             vv(2)=pizda(2,1)+pizda(1,2)
8563             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8564             if (swap) then
8565               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8566 #ifdef MOMENT
8567                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8568      &             -(s1+s2+s4)
8569 #else
8570                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8571      &             -(s2+s4)
8572 #endif
8573                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8574               else
8575 #ifdef MOMENT
8576                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8577 #else
8578                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8579 #endif
8580                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8581               endif
8582             else
8583 #ifdef MOMENT
8584               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8585 #else
8586               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8587 #endif
8588               if (l.eq.j+1) then
8589                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8590               else
8591                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8592               endif
8593             endif
8594           enddo
8595         enddo
8596       enddo
8597       endif ! calc_grad
8598       return
8599       end
8600 c----------------------------------------------------------------------------
8601       double precision function eello_turn6(i,jj,kk)
8602       implicit real*8 (a-h,o-z)
8603       include 'DIMENSIONS'
8604       include 'DIMENSIONS.ZSCOPT'
8605       include 'COMMON.IOUNITS'
8606       include 'COMMON.CHAIN'
8607       include 'COMMON.DERIV'
8608       include 'COMMON.INTERACT'
8609       include 'COMMON.CONTACTS'
8610       include 'COMMON.TORSION'
8611       include 'COMMON.VAR'
8612       include 'COMMON.GEO'
8613       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8614      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8615      &  ggg1(3),ggg2(3)
8616       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8617      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8618 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8619 C           the respective energy moment and not to the cluster cumulant.
8620       s1=0.0d0
8621       s8=0.0d0
8622       s13=0.0d0
8623 c
8624       eello_turn6=0.0d0
8625       j=i+4
8626       k=i+1
8627       l=i+3
8628       iti=itype2loc(itype(i))
8629       itk=itype2loc(itype(k))
8630       itk1=itype2loc(itype(k+1))
8631       itl=itype2loc(itype(l))
8632       itj=itype2loc(itype(j))
8633 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8634 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8635 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8636 cd        eello6=0.0d0
8637 cd        return
8638 cd      endif
8639 cd      write (iout,*)
8640 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8641 cd     &   ' and',k,l
8642 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8643       do iii=1,2
8644         do kkk=1,5
8645           do lll=1,3
8646             derx_turn(lll,kkk,iii)=0.0d0
8647           enddo
8648         enddo
8649       enddo
8650 cd      eij=1.0d0
8651 cd      ekl=1.0d0
8652 cd      ekont=1.0d0
8653       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8654 cd      eello6_5=0.0d0
8655 cd      write (2,*) 'eello6_5',eello6_5
8656 #ifdef MOMENT
8657       call transpose2(AEA(1,1,1),auxmat(1,1))
8658       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8659       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8660       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8661 #endif
8662       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8663       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8664       s2 = scalar2(b1(1,k),vtemp1(1))
8665 #ifdef MOMENT
8666       call transpose2(AEA(1,1,2),atemp(1,1))
8667       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8668       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8669       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8670 #endif
8671       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8672       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8673       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8674 #ifdef MOMENT
8675       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8676       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8677       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8678       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8679       ss13 = scalar2(b1(1,k),vtemp4(1))
8680       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8681 #endif
8682 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8683 c      s1=0.0d0
8684 c      s2=0.0d0
8685 c      s8=0.0d0
8686 c      s12=0.0d0
8687 c      s13=0.0d0
8688       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8689 C Derivatives in gamma(i+2)
8690       if (calc_grad) then
8691       s1d =0.0d0
8692       s8d =0.0d0
8693 #ifdef MOMENT
8694       call transpose2(AEA(1,1,1),auxmatd(1,1))
8695       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8696       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8697       call transpose2(AEAderg(1,1,2),atempd(1,1))
8698       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8699       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8700 #endif
8701       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8702       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8703       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8704 c      s1d=0.0d0
8705 c      s2d=0.0d0
8706 c      s8d=0.0d0
8707 c      s12d=0.0d0
8708 c      s13d=0.0d0
8709       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8710 C Derivatives in gamma(i+3)
8711 #ifdef MOMENT
8712       call transpose2(AEA(1,1,1),auxmatd(1,1))
8713       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8714       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8715       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8716 #endif
8717       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8718       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8719       s2d = scalar2(b1(1,k),vtemp1d(1))
8720 #ifdef MOMENT
8721       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8722       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8723 #endif
8724       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8725 #ifdef MOMENT
8726       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8727       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8728       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8729 #endif
8730 c      s1d=0.0d0
8731 c      s2d=0.0d0
8732 c      s8d=0.0d0
8733 c      s12d=0.0d0
8734 c      s13d=0.0d0
8735 #ifdef MOMENT
8736       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8737      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8738 #else
8739       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8740      &               -0.5d0*ekont*(s2d+s12d)
8741 #endif
8742 C Derivatives in gamma(i+4)
8743       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8744       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8745       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8746 #ifdef MOMENT
8747       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8748       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8749       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8750 #endif
8751 c      s1d=0.0d0
8752 c      s2d=0.0d0
8753 c      s8d=0.0d0
8754 C      s12d=0.0d0
8755 c      s13d=0.0d0
8756 #ifdef MOMENT
8757       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8758 #else
8759       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8760 #endif
8761 C Derivatives in gamma(i+5)
8762 #ifdef MOMENT
8763       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8764       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8765       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8766 #endif
8767       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8768       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8769       s2d = scalar2(b1(1,k),vtemp1d(1))
8770 #ifdef MOMENT
8771       call transpose2(AEA(1,1,2),atempd(1,1))
8772       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8773       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8774 #endif
8775       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8776       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8777 #ifdef MOMENT
8778       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8779       ss13d = scalar2(b1(1,k),vtemp4d(1))
8780       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8781 #endif
8782 c      s1d=0.0d0
8783 c      s2d=0.0d0
8784 c      s8d=0.0d0
8785 c      s12d=0.0d0
8786 c      s13d=0.0d0
8787 #ifdef MOMENT
8788       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8789      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8790 #else
8791       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8792      &               -0.5d0*ekont*(s2d+s12d)
8793 #endif
8794 C Cartesian derivatives
8795       do iii=1,2
8796         do kkk=1,5
8797           do lll=1,3
8798 #ifdef MOMENT
8799             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8800             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8801             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8802 #endif
8803             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8804             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8805      &          vtemp1d(1))
8806             s2d = scalar2(b1(1,k),vtemp1d(1))
8807 #ifdef MOMENT
8808             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8809             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8810             s8d = -(atempd(1,1)+atempd(2,2))*
8811      &           scalar2(cc(1,1,l),vtemp2(1))
8812 #endif
8813             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8814      &           auxmatd(1,1))
8815             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8816             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8817 c      s1d=0.0d0
8818 c      s2d=0.0d0
8819 c      s8d=0.0d0
8820 c      s12d=0.0d0
8821 c      s13d=0.0d0
8822 #ifdef MOMENT
8823             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8824      &        - 0.5d0*(s1d+s2d)
8825 #else
8826             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8827      &        - 0.5d0*s2d
8828 #endif
8829 #ifdef MOMENT
8830             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8831      &        - 0.5d0*(s8d+s12d)
8832 #else
8833             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8834      &        - 0.5d0*s12d
8835 #endif
8836           enddo
8837         enddo
8838       enddo
8839 #ifdef MOMENT
8840       do kkk=1,5
8841         do lll=1,3
8842           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8843      &      achuj_tempd(1,1))
8844           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8845           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8846           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8847           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8848           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8849      &      vtemp4d(1))
8850           ss13d = scalar2(b1(1,k),vtemp4d(1))
8851           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8852           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8853         enddo
8854       enddo
8855 #endif
8856 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8857 cd     &  16*eel_turn6_num
8858 cd      goto 1112
8859       if (j.lt.nres-1) then
8860         j1=j+1
8861         j2=j-1
8862       else
8863         j1=j-1
8864         j2=j-2
8865       endif
8866       if (l.lt.nres-1) then
8867         l1=l+1
8868         l2=l-1
8869       else
8870         l1=l-1
8871         l2=l-2
8872       endif
8873       do ll=1,3
8874 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8875 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8876 cgrad        ghalf=0.5d0*ggg1(ll)
8877 cd        ghalf=0.0d0
8878         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8879         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8880         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8881      &    +ekont*derx_turn(ll,2,1)
8882         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8883         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8884      &    +ekont*derx_turn(ll,4,1)
8885         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8886         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8887         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8888 cgrad        ghalf=0.5d0*ggg2(ll)
8889 cd        ghalf=0.0d0
8890         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8891      &    +ekont*derx_turn(ll,2,2)
8892         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8893         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8894      &    +ekont*derx_turn(ll,4,2)
8895         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8896         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8897         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8898       enddo
8899 cd      goto 1112
8900 cgrad      do m=i+1,j-1
8901 cgrad        do ll=1,3
8902 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8903 cgrad        enddo
8904 cgrad      enddo
8905 cgrad      do m=k+1,l-1
8906 cgrad        do ll=1,3
8907 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8908 cgrad        enddo
8909 cgrad      enddo
8910 cgrad1112  continue
8911 cgrad      do m=i+2,j2
8912 cgrad        do ll=1,3
8913 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8914 cgrad        enddo
8915 cgrad      enddo
8916 cgrad      do m=k+2,l2
8917 cgrad        do ll=1,3
8918 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8919 cgrad        enddo
8920 cgrad      enddo
8921 cd      do iii=1,nres-3
8922 cd        write (2,*) iii,g_corr6_loc(iii)
8923 cd      enddo
8924       endif ! calc_grad
8925       eello_turn6=ekont*eel_turn6
8926 cd      write (2,*) 'ekont',ekont
8927 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8928       return
8929       end
8930
8931 crc-------------------------------------------------
8932 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8933       subroutine Eliptransfer(eliptran)
8934       implicit real*8 (a-h,o-z)
8935       include 'DIMENSIONS'
8936       include 'DIMENSIONS.ZSCOPT'
8937       include 'COMMON.GEO'
8938       include 'COMMON.VAR'
8939       include 'COMMON.LOCAL'
8940       include 'COMMON.CHAIN'
8941       include 'COMMON.DERIV'
8942       include 'COMMON.INTERACT'
8943       include 'COMMON.IOUNITS'
8944       include 'COMMON.CALC'
8945       include 'COMMON.CONTROL'
8946       include 'COMMON.SPLITELE'
8947       include 'COMMON.SBRIDGE'
8948 C this is done by Adasko
8949 C      print *,"wchodze"
8950 C structure of box:
8951 C      water
8952 C--bordliptop-- buffore starts
8953 C--bufliptop--- here true lipid starts
8954 C      lipid
8955 C--buflipbot--- lipid ends buffore starts
8956 C--bordlipbot--buffore ends
8957       eliptran=0.0
8958       do i=1,nres
8959 C       do i=1,1
8960         if (itype(i).eq.ntyp1) cycle
8961
8962         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8963         if (positi.le.0) positi=positi+boxzsize
8964 C        print *,i
8965 C first for peptide groups
8966 c for each residue check if it is in lipid or lipid water border area
8967        if ((positi.gt.bordlipbot)
8968      &.and.(positi.lt.bordliptop)) then
8969 C the energy transfer exist
8970         if (positi.lt.buflipbot) then
8971 C what fraction I am in
8972          fracinbuf=1.0d0-
8973      &        ((positi-bordlipbot)/lipbufthick)
8974 C lipbufthick is thickenes of lipid buffore
8975          sslip=sscalelip(fracinbuf)
8976          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8977          eliptran=eliptran+sslip*pepliptran
8978          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8979          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8980 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8981         elseif (positi.gt.bufliptop) then
8982          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8983          sslip=sscalelip(fracinbuf)
8984          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8985          eliptran=eliptran+sslip*pepliptran
8986          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8987          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8988 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8989 C          print *, "doing sscalefor top part"
8990 C         print *,i,sslip,fracinbuf,ssgradlip
8991         else
8992          eliptran=eliptran+pepliptran
8993 C         print *,"I am in true lipid"
8994         endif
8995 C       else
8996 C       eliptran=elpitran+0.0 ! I am in water
8997        endif
8998        enddo
8999 C       print *, "nic nie bylo w lipidzie?"
9000 C now multiply all by the peptide group transfer factor
9001 C       eliptran=eliptran*pepliptran
9002 C now the same for side chains
9003 CV       do i=1,1
9004        do i=1,nres
9005         if (itype(i).eq.ntyp1) cycle
9006         positi=(mod(c(3,i+nres),boxzsize))
9007         if (positi.le.0) positi=positi+boxzsize
9008 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9009 c for each residue check if it is in lipid or lipid water border area
9010 C       respos=mod(c(3,i+nres),boxzsize)
9011 C       print *,positi,bordlipbot,buflipbot
9012        if ((positi.gt.bordlipbot)
9013      & .and.(positi.lt.bordliptop)) then
9014 C the energy transfer exist
9015         if (positi.lt.buflipbot) then
9016          fracinbuf=1.0d0-
9017      &     ((positi-bordlipbot)/lipbufthick)
9018 C lipbufthick is thickenes of lipid buffore
9019          sslip=sscalelip(fracinbuf)
9020          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9021          eliptran=eliptran+sslip*liptranene(itype(i))
9022          gliptranx(3,i)=gliptranx(3,i)
9023      &+ssgradlip*liptranene(itype(i))
9024          gliptranc(3,i-1)= gliptranc(3,i-1)
9025      &+ssgradlip*liptranene(itype(i))
9026 C         print *,"doing sccale for lower part"
9027         elseif (positi.gt.bufliptop) then
9028          fracinbuf=1.0d0-
9029      &((bordliptop-positi)/lipbufthick)
9030          sslip=sscalelip(fracinbuf)
9031          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9032          eliptran=eliptran+sslip*liptranene(itype(i))
9033          gliptranx(3,i)=gliptranx(3,i)
9034      &+ssgradlip*liptranene(itype(i))
9035          gliptranc(3,i-1)= gliptranc(3,i-1)
9036      &+ssgradlip*liptranene(itype(i))
9037 C          print *, "doing sscalefor top part",sslip,fracinbuf
9038         else
9039          eliptran=eliptran+liptranene(itype(i))
9040 C         print *,"I am in true lipid"
9041         endif
9042         endif ! if in lipid or buffor
9043 C       else
9044 C       eliptran=elpitran+0.0 ! I am in water
9045        enddo
9046        return
9047        end
9048
9049
9050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9051
9052       SUBROUTINE MATVEC2(A1,V1,V2)
9053       implicit real*8 (a-h,o-z)
9054       include 'DIMENSIONS'
9055       DIMENSION A1(2,2),V1(2),V2(2)
9056 c      DO 1 I=1,2
9057 c        VI=0.0
9058 c        DO 3 K=1,2
9059 c    3     VI=VI+A1(I,K)*V1(K)
9060 c        Vaux(I)=VI
9061 c    1 CONTINUE
9062
9063       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9064       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9065
9066       v2(1)=vaux1
9067       v2(2)=vaux2
9068       END
9069 C---------------------------------------
9070       SUBROUTINE MATMAT2(A1,A2,A3)
9071       implicit real*8 (a-h,o-z)
9072       include 'DIMENSIONS'
9073       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9074 c      DIMENSION AI3(2,2)
9075 c        DO  J=1,2
9076 c          A3IJ=0.0
9077 c          DO K=1,2
9078 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9079 c          enddo
9080 c          A3(I,J)=A3IJ
9081 c       enddo
9082 c      enddo
9083
9084       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9085       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9086       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9087       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9088
9089       A3(1,1)=AI3_11
9090       A3(2,1)=AI3_21
9091       A3(1,2)=AI3_12
9092       A3(2,2)=AI3_22
9093       END
9094
9095 c-------------------------------------------------------------------------
9096       double precision function scalar2(u,v)
9097       implicit none
9098       double precision u(2),v(2)
9099       double precision sc
9100       integer i
9101       scalar2=u(1)*v(1)+u(2)*v(2)
9102       return
9103       end
9104
9105 C-----------------------------------------------------------------------------
9106
9107       subroutine transpose2(a,at)
9108       implicit none
9109       double precision a(2,2),at(2,2)
9110       at(1,1)=a(1,1)
9111       at(1,2)=a(2,1)
9112       at(2,1)=a(1,2)
9113       at(2,2)=a(2,2)
9114       return
9115       end
9116 c--------------------------------------------------------------------------
9117       subroutine transpose(n,a,at)
9118       implicit none
9119       integer n,i,j
9120       double precision a(n,n),at(n,n)
9121       do i=1,n
9122         do j=1,n
9123           at(j,i)=a(i,j)
9124         enddo
9125       enddo
9126       return
9127       end
9128 C---------------------------------------------------------------------------
9129       subroutine prodmat3(a1,a2,kk,transp,prod)
9130       implicit none
9131       integer i,j
9132       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9133       logical transp
9134 crc      double precision auxmat(2,2),prod_(2,2)
9135
9136       if (transp) then
9137 crc        call transpose2(kk(1,1),auxmat(1,1))
9138 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9139 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9140
9141            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9142      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9143            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9144      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9145            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9146      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9147            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9148      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9149
9150       else
9151 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9152 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9153
9154            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9155      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9156            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9157      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9158            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9159      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9160            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9161      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9162
9163       endif
9164 c      call transpose2(a2(1,1),a2t(1,1))
9165
9166 crc      print *,transp
9167 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9168 crc      print *,((prod(i,j),i=1,2),j=1,2)
9169
9170       return
9171       end
9172 C-----------------------------------------------------------------------------
9173       double precision function scalar(u,v)
9174       implicit none
9175       double precision u(3),v(3)
9176       double precision sc
9177       integer i
9178       sc=0.0d0
9179       do i=1,3
9180         sc=sc+u(i)*v(i)
9181       enddo
9182       scalar=sc
9183       return
9184       end
9185 C-----------------------------------------------------------------------
9186       double precision function sscale(r)
9187       double precision r,gamm
9188       include "COMMON.SPLITELE"
9189       if(r.lt.r_cut-rlamb) then
9190         sscale=1.0d0
9191       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9192         gamm=(r-(r_cut-rlamb))/rlamb
9193         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9194       else
9195         sscale=0d0
9196       endif
9197       return
9198       end
9199 C-----------------------------------------------------------------------
9200 C-----------------------------------------------------------------------
9201       double precision function sscagrad(r)
9202       double precision r,gamm
9203       include "COMMON.SPLITELE"
9204       if(r.lt.r_cut-rlamb) then
9205         sscagrad=0.0d0
9206       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9207         gamm=(r-(r_cut-rlamb))/rlamb
9208         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9209       else
9210         sscagrad=0.0d0
9211       endif
9212       return
9213       end
9214 C-----------------------------------------------------------------------
9215 C-----------------------------------------------------------------------
9216       double precision function sscalelip(r)
9217       double precision r,gamm
9218       include "COMMON.SPLITELE"
9219 C      if(r.lt.r_cut-rlamb) then
9220 C        sscale=1.0d0
9221 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9222 C        gamm=(r-(r_cut-rlamb))/rlamb
9223         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9224 C      else
9225 C        sscale=0d0
9226 C      endif
9227       return
9228       end
9229 C-----------------------------------------------------------------------
9230       double precision function sscagradlip(r)
9231       double precision r,gamm
9232       include "COMMON.SPLITELE"
9233 C     if(r.lt.r_cut-rlamb) then
9234 C        sscagrad=0.0d0
9235 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9236 C        gamm=(r-(r_cut-rlamb))/rlamb
9237         sscagradlip=r*(6*r-6.0d0)
9238 C      else
9239 C        sscagrad=0.0d0
9240 C      endif
9241       return
9242       end
9243
9244 C-----------------------------------------------------------------------
9245        subroutine set_shield_fac
9246       implicit real*8 (a-h,o-z)
9247       include 'DIMENSIONS'
9248       include 'DIMENSIONS.ZSCOPT'
9249       include 'COMMON.CHAIN'
9250       include 'COMMON.DERIV'
9251       include 'COMMON.IOUNITS'
9252       include 'COMMON.SHIELD'
9253       include 'COMMON.INTERACT'
9254 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9255       double precision div77_81/0.974996043d0/,
9256      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9257
9258 C the vector between center of side_chain and peptide group
9259        double precision pep_side(3),long,side_calf(3),
9260      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9261      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9262 C the line belowe needs to be changed for FGPROC>1
9263       do i=1,nres-1
9264       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9265       ishield_list(i)=0
9266 Cif there two consequtive dummy atoms there is no peptide group between them
9267 C the line below has to be changed for FGPROC>1
9268       VolumeTotal=0.0
9269       do k=1,nres
9270        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9271        dist_pep_side=0.0
9272        dist_side_calf=0.0
9273        do j=1,3
9274 C first lets set vector conecting the ithe side-chain with kth side-chain
9275       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9276 C      pep_side(j)=2.0d0
9277 C and vector conecting the side-chain with its proper calfa
9278       side_calf(j)=c(j,k+nres)-c(j,k)
9279 C      side_calf(j)=2.0d0
9280       pept_group(j)=c(j,i)-c(j,i+1)
9281 C lets have their lenght
9282       dist_pep_side=pep_side(j)**2+dist_pep_side
9283       dist_side_calf=dist_side_calf+side_calf(j)**2
9284       dist_pept_group=dist_pept_group+pept_group(j)**2
9285       enddo
9286        dist_pep_side=dsqrt(dist_pep_side)
9287        dist_pept_group=dsqrt(dist_pept_group)
9288        dist_side_calf=dsqrt(dist_side_calf)
9289       do j=1,3
9290         pep_side_norm(j)=pep_side(j)/dist_pep_side
9291         side_calf_norm(j)=dist_side_calf
9292       enddo
9293 C now sscale fraction
9294        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9295 C       print *,buff_shield,"buff"
9296 C now sscale
9297         if (sh_frac_dist.le.0.0) cycle
9298 C If we reach here it means that this side chain reaches the shielding sphere
9299 C Lets add him to the list for gradient
9300         ishield_list(i)=ishield_list(i)+1
9301 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9302 C this list is essential otherwise problem would be O3
9303         shield_list(ishield_list(i),i)=k
9304 C Lets have the sscale value
9305         if (sh_frac_dist.gt.1.0) then
9306          scale_fac_dist=1.0d0
9307          do j=1,3
9308          sh_frac_dist_grad(j)=0.0d0
9309          enddo
9310         else
9311          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9312      &                   *(2.0*sh_frac_dist-3.0d0)
9313          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9314      &                  /dist_pep_side/buff_shield*0.5
9315 C remember for the final gradient multiply sh_frac_dist_grad(j)
9316 C for side_chain by factor -2 !
9317          do j=1,3
9318          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9319 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9320 C     &                    sh_frac_dist_grad(j)
9321          enddo
9322         endif
9323 C        if ((i.eq.3).and.(k.eq.2)) then
9324 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9325 C     & ,"TU"
9326 C        endif
9327
9328 C this is what is now we have the distance scaling now volume...
9329       short=short_r_sidechain(itype(k))
9330       long=long_r_sidechain(itype(k))
9331       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9332 C now costhet_grad
9333 C       costhet=0.0d0
9334        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9335 C       costhet_fac=0.0d0
9336        do j=1,3
9337          costhet_grad(j)=costhet_fac*pep_side(j)
9338        enddo
9339 C remember for the final gradient multiply costhet_grad(j)
9340 C for side_chain by factor -2 !
9341 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9342 C pep_side0pept_group is vector multiplication
9343       pep_side0pept_group=0.0
9344       do j=1,3
9345       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9346       enddo
9347       cosalfa=(pep_side0pept_group/
9348      & (dist_pep_side*dist_side_calf))
9349       fac_alfa_sin=1.0-cosalfa**2
9350       fac_alfa_sin=dsqrt(fac_alfa_sin)
9351       rkprim=fac_alfa_sin*(long-short)+short
9352 C now costhet_grad
9353        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9354        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9355
9356        do j=1,3
9357          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9358      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9359      &*(long-short)/fac_alfa_sin*cosalfa/
9360      &((dist_pep_side*dist_side_calf))*
9361      &((side_calf(j))-cosalfa*
9362      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9363
9364         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9365      &*(long-short)/fac_alfa_sin*cosalfa
9366      &/((dist_pep_side*dist_side_calf))*
9367      &(pep_side(j)-
9368      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9369        enddo
9370
9371       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9372      &                    /VSolvSphere_div
9373      &                    *wshield
9374 C now the gradient...
9375 C grad_shield is gradient of Calfa for peptide groups
9376 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9377 C     &               costhet,cosphi
9378 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9379 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9380       do j=1,3
9381       grad_shield(j,i)=grad_shield(j,i)
9382 C gradient po skalowaniu
9383      &                +(sh_frac_dist_grad(j)
9384 C  gradient po costhet
9385      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9386      &-scale_fac_dist*(cosphi_grad_long(j))
9387      &/(1.0-cosphi) )*div77_81
9388      &*VofOverlap
9389 C grad_shield_side is Cbeta sidechain gradient
9390       grad_shield_side(j,ishield_list(i),i)=
9391      &        (sh_frac_dist_grad(j)*(-2.0d0)
9392      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9393      &       +scale_fac_dist*(cosphi_grad_long(j))
9394      &        *2.0d0/(1.0-cosphi))
9395      &        *div77_81*VofOverlap
9396
9397        grad_shield_loc(j,ishield_list(i),i)=
9398      &   scale_fac_dist*cosphi_grad_loc(j)
9399      &        *2.0d0/(1.0-cosphi)
9400      &        *div77_81*VofOverlap
9401       enddo
9402       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9403       enddo
9404       fac_shield(i)=VolumeTotal*div77_81+div4_81
9405 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9406       enddo
9407       return
9408       end
9409 C--------------------------------------------------------------------------
9410 C first for shielding is setting of function of side-chains
9411        subroutine set_shield_fac2
9412       implicit real*8 (a-h,o-z)
9413       include 'DIMENSIONS'
9414       include 'DIMENSIONS.ZSCOPT'
9415       include 'COMMON.CHAIN'
9416       include 'COMMON.DERIV'
9417       include 'COMMON.IOUNITS'
9418       include 'COMMON.SHIELD'
9419       include 'COMMON.INTERACT'
9420 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9421       double precision div77_81/0.974996043d0/,
9422      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9423
9424 C the vector between center of side_chain and peptide group
9425        double precision pep_side(3),long,side_calf(3),
9426      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9427      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9428 C the line belowe needs to be changed for FGPROC>1
9429       do i=1,nres-1
9430       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9431       ishield_list(i)=0
9432 Cif there two consequtive dummy atoms there is no peptide group between them
9433 C the line below has to be changed for FGPROC>1
9434       VolumeTotal=0.0
9435       do k=1,nres
9436        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9437        dist_pep_side=0.0
9438        dist_side_calf=0.0
9439        do j=1,3
9440 C first lets set vector conecting the ithe side-chain with kth side-chain
9441       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9442 C      pep_side(j)=2.0d0
9443 C and vector conecting the side-chain with its proper calfa
9444       side_calf(j)=c(j,k+nres)-c(j,k)
9445 C      side_calf(j)=2.0d0
9446       pept_group(j)=c(j,i)-c(j,i+1)
9447 C lets have their lenght
9448       dist_pep_side=pep_side(j)**2+dist_pep_side
9449       dist_side_calf=dist_side_calf+side_calf(j)**2
9450       dist_pept_group=dist_pept_group+pept_group(j)**2
9451       enddo
9452        dist_pep_side=dsqrt(dist_pep_side)
9453        dist_pept_group=dsqrt(dist_pept_group)
9454        dist_side_calf=dsqrt(dist_side_calf)
9455       do j=1,3
9456         pep_side_norm(j)=pep_side(j)/dist_pep_side
9457         side_calf_norm(j)=dist_side_calf
9458       enddo
9459 C now sscale fraction
9460        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9461 C       print *,buff_shield,"buff"
9462 C now sscale
9463         if (sh_frac_dist.le.0.0) cycle
9464 C If we reach here it means that this side chain reaches the shielding sphere
9465 C Lets add him to the list for gradient
9466         ishield_list(i)=ishield_list(i)+1
9467 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9468 C this list is essential otherwise problem would be O3
9469         shield_list(ishield_list(i),i)=k
9470 C Lets have the sscale value
9471         if (sh_frac_dist.gt.1.0) then
9472          scale_fac_dist=1.0d0
9473          do j=1,3
9474          sh_frac_dist_grad(j)=0.0d0
9475          enddo
9476         else
9477          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9478      &                   *(2.0d0*sh_frac_dist-3.0d0)
9479          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9480      &                  /dist_pep_side/buff_shield*0.5d0
9481 C remember for the final gradient multiply sh_frac_dist_grad(j)
9482 C for side_chain by factor -2 !
9483          do j=1,3
9484          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9485 C         sh_frac_dist_grad(j)=0.0d0
9486 C         scale_fac_dist=1.0d0
9487 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9488 C     &                    sh_frac_dist_grad(j)
9489          enddo
9490         endif
9491 C this is what is now we have the distance scaling now volume...
9492       short=short_r_sidechain(itype(k))
9493       long=long_r_sidechain(itype(k))
9494       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9495       sinthet=short/dist_pep_side*costhet
9496 C now costhet_grad
9497 C       costhet=0.6d0
9498 C       sinthet=0.8
9499        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9500 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9501 C     &             -short/dist_pep_side**2/costhet)
9502 C       costhet_fac=0.0d0
9503        do j=1,3
9504          costhet_grad(j)=costhet_fac*pep_side(j)
9505        enddo
9506 C remember for the final gradient multiply costhet_grad(j)
9507 C for side_chain by factor -2 !
9508 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9509 C pep_side0pept_group is vector multiplication
9510       pep_side0pept_group=0.0d0
9511       do j=1,3
9512       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9513       enddo
9514       cosalfa=(pep_side0pept_group/
9515      & (dist_pep_side*dist_side_calf))
9516       fac_alfa_sin=1.0d0-cosalfa**2
9517       fac_alfa_sin=dsqrt(fac_alfa_sin)
9518       rkprim=fac_alfa_sin*(long-short)+short
9519 C      rkprim=short
9520
9521 C now costhet_grad
9522        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9523 C       cosphi=0.6
9524        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9525        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9526      &      dist_pep_side**2)
9527 C       sinphi=0.8
9528        do j=1,3
9529          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9530      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9531      &*(long-short)/fac_alfa_sin*cosalfa/
9532      &((dist_pep_side*dist_side_calf))*
9533      &((side_calf(j))-cosalfa*
9534      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9535 C       cosphi_grad_long(j)=0.0d0
9536         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9537      &*(long-short)/fac_alfa_sin*cosalfa
9538      &/((dist_pep_side*dist_side_calf))*
9539      &(pep_side(j)-
9540      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9541 C       cosphi_grad_loc(j)=0.0d0
9542        enddo
9543 C      print *,sinphi,sinthet
9544       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9545      &                    /VSolvSphere_div
9546 C     &                    *wshield
9547 C now the gradient...
9548       do j=1,3
9549       grad_shield(j,i)=grad_shield(j,i)
9550 C gradient po skalowaniu
9551      &                +(sh_frac_dist_grad(j)*VofOverlap
9552 C  gradient po costhet
9553      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9554      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9555      &       sinphi/sinthet*costhet*costhet_grad(j)
9556      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9557      & )*wshield
9558 C grad_shield_side is Cbeta sidechain gradient
9559       grad_shield_side(j,ishield_list(i),i)=
9560      &        (sh_frac_dist_grad(j)*(-2.0d0)
9561      &        *VofOverlap
9562      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9563      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9564      &       sinphi/sinthet*costhet*costhet_grad(j)
9565      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9566      &       )*wshield
9567
9568        grad_shield_loc(j,ishield_list(i),i)=
9569      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9570      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9571      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9572      &        ))
9573      &        *wshield
9574       enddo
9575       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9576       enddo
9577       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9578 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
9579 c     &  " wshield",wshield
9580 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9581       enddo
9582       return
9583       end
9584 C--------------------------------------------------------------------------
9585       double precision function tschebyshev(m,n,x,y)
9586       implicit none
9587       include "DIMENSIONS"
9588       integer i,m,n
9589       double precision x(n),y,yy(0:maxvar),aux
9590 c Tschebyshev polynomial. Note that the first term is omitted
9591 c m=0: the constant term is included
9592 c m=1: the constant term is not included
9593       yy(0)=1.0d0
9594       yy(1)=y
9595       do i=2,n
9596         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9597       enddo
9598       aux=0.0d0
9599       do i=m,n
9600         aux=aux+x(i)*yy(i)
9601       enddo
9602       tschebyshev=aux
9603       return
9604       end
9605 C--------------------------------------------------------------------------
9606       double precision function gradtschebyshev(m,n,x,y)
9607       implicit none
9608       include "DIMENSIONS"
9609       integer i,m,n
9610       double precision x(n+1),y,yy(0:maxvar),aux
9611 c Tschebyshev polynomial. Note that the first term is omitted
9612 c m=0: the constant term is included
9613 c m=1: the constant term is not included
9614       yy(0)=1.0d0
9615       yy(1)=2.0d0*y
9616       do i=2,n
9617         yy(i)=2*y*yy(i-1)-yy(i-2)
9618       enddo
9619       aux=0.0d0
9620       do i=m,n
9621         aux=aux+x(i+1)*yy(i)*(i+1)
9622 C        print *, x(i+1),yy(i),i
9623       enddo
9624       gradtschebyshev=aux
9625       return
9626       end
9627