source/maxlik/src_MD_T_maxlik-NEWCORR-PMF-5/energy_p_new_sc.F

   1       subroutine etotal(energia)
   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       include 'COMMON.WEIGHTS'
  24       include 'COMMON.WEIGHTDER'
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105,106) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 107
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 107
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 107
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 107
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47       goto 107
  48 C New SC-SC potential
  49   106 call emomo(evdw,evdw_p,evdw_m)
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   107 continue
  54       call vec_and_deriv
  55       if (shield_mode.eq.1) then
  56        call set_shield_fac
  57       else if  (shield_mode.eq.2) then
  58        call set_shield_fac2
  59       endif
  60       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  61 C            write(iout,*) 'po eelec'
  62
  63 C Calculate excluded-volume interaction energy between peptide groups
  64 C and side chains.
  65 C
  66       call escp(evdw2,evdw2_14)
  67 c
  68 c Calculate the bond-stretching energy
  69 c
  70
  71       call ebond(estr)
  72 C       write (iout,*) "estr",estr
  73 C
  74 C Calculate the disulfide-bridge and other energy and the contributions
  75 C from other distance constraints.
  76 cd    print *,'Calling EHPB'
  77       call edis(ehpb)
  78 cd    print *,'EHPB exitted succesfully.'
  79 C
  80 C Calculate the virtual-bond-angle energy.
  81 C
  82 C      print *,'Bend energy finished.'
  83       if (wang.gt.0d0) then
  84        if (tor_mode.eq.0) then
  85          call ebend(ebe)
  86        else
  87 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  88 C energy function
  89          call ebend_kcc(ebe)
  90        endif
  91       else
  92         ebe=0.0d0
  93       endif
  94       ethetacnstr=0.0d0
  95       if (with_theta_constr) call etheta_constr(ethetacnstr)
  96 c      call ebend(ebe,ethetacnstr)
  97 cd    print *,'Bend energy finished.'
  98 C
  99 C Calculate the SC local energy.
 100 C
 101       call esc(escloc)
 102 C       print *,'SCLOC energy finished.'
 103 C
 104 C Calculate the virtual-bond torsional energy.
 105 C
 106       if (wtor.gt.0.0d0) then
 107          if (tor_mode.eq.0) then
 108            call etor(etors)
 109          else
 110 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 111 C energy function
 112            call etor_kcc(etors)
 113          endif
 114       else
 115         etors=0.0d0
 116       endif
 117       edihcnstr=0.0d0
 118       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 119 c      print *,"Processor",myrank," computed Utor"
 120 C
 121 C 6/23/01 Calculate double-torsional energy
 122 C
 123       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 124         call etor_d(etors_d)
 125       else
 126         etors_d=0
 127       endif
 128 c      print *,"Processor",myrank," computed Utord"
 129 C
 130       call eback_sc_corr(esccor)
 131
 132       eliptran=0.0d0
 133       if (wliptran.gt.0) then
 134         call Eliptransfer(eliptran)
 135       endif
 136
 137 C
 138 C 12/1/95 Multi-body terms
 139 C
 140       n_corr=0
 141       n_corr1=0
 142       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 143      &    .or. wturn6.gt.0.0d0) then
 144 c         write(iout,*)"calling multibody_eello"
 145          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 146 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 147 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 148       else
 149          ecorr=0.0d0
 150          ecorr5=0.0d0
 151          ecorr6=0.0d0
 152          eturn6=0.0d0
 153       endif
 154       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 155 c         write (iout,*) "Calling multibody_hbond"
 156          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 157       endif
 158 #ifdef SPLITELE
 159       if (shield_mode.gt.0) then
 160       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 161      & +welec*ees
 162      & +wvdwpp*evdw1
 163      & +wang*ebe+wtor*etors+wscloc*escloc
 164      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 165      & +wcorr6*ecorr6+wturn4*eello_turn4
 166      & +wturn3*eello_turn3+wturn6*eturn6
 167      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 168      & +wbond*estr+wsccor*esccor+ethetacnstr
 169      & +wliptran*eliptran
 170       else
 171       etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees
 172      & +wvdwpp*evdw1
 173      & +wang*ebe+wtor*etors+wscloc*escloc
 174      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 175      & +wcorr6*ecorr6+wturn4*eello_turn4
 176      & +wturn3*eello_turn3+wturn6*eturn6
 177      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 178      & +wbond*estr+wsccor*esccor+ethetacnstr
 179      & +wliptran*eliptran
 180       endif
 181 #else
 182       if (shield_mode.gt.0) then
 183       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 184      & +welec*(ees+evdw1)
 185      & +wang*ebe+wtor*etors+wscloc*escloc
 186      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 187      & +wcorr6*ecorr6+wturn4*eello_turn4
 188      & +wturn3*eello_turn3+wturn6*eturn6
 189      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 190      & +wbond*estr+wsccor*esccor+ethetacnstr
 191      & +wliptran*eliptran
 192       else
 193       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 194      & +welec*(ees+evdw1)
 195      & +wang*ebe+wtor*etors+wscloc*escloc
 196      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 197      & +wcorr6*ecorr6+wturn4*eello_turn4
 198      & +wturn3*eello_turn3+wturn6*eturn6
 199      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 200      & +wbond*estr+wsccor*esccor+ethetacnstr
 201      & +wliptran*eliptran
 202       endif
 203 #endif
 204       energia(0)=etot
 205       energia(1)=evdw
 206 #ifdef SCP14
 207       energia(2)=evdw2-evdw2_14
 208       energia(17)=evdw2_14
 209 #else
 210       energia(2)=evdw2
 211       energia(17)=0.0d0
 212 #endif
 213 #ifdef SPLITELE
 214       energia(3)=ees
 215       energia(16)=evdw1
 216 #else
 217       energia(3)=ees+evdw1
 218       energia(16)=0.0d0
 219 #endif
 220       energia(4)=ecorr
 221       energia(5)=ecorr5
 222       energia(6)=ecorr6
 223       energia(7)=eel_loc
 224       energia(8)=eello_turn3
 225       energia(9)=eello_turn4
 226       energia(10)=eturn6
 227       energia(11)=ebe
 228       energia(12)=escloc
 229       energia(13)=etors
 230       energia(14)=etors_d
 231       energia(15)=ehpb
 232       energia(17)=estr
 233       energia(19)=esccor
 234       energia(20)=edihcnstr
 235       energia(21)=evdw_t
 236       energia(24)=ethetacnstr
 237       energia(22)=eliptran
 238 c detecting NaNQ
 239 #ifdef ISNAN
 240 #ifdef AIX
 241       if (isnan(etot).ne.0) energia(0)=1.0d+99
 242 #else
 243       if (isnan(etot)) energia(0)=1.0d+99
 244 #endif
 245 #else
 246       i=0
 247 #ifdef WINPGI
 248       idumm=proc_proc(etot,i)
 249 #else
 250       call proc_proc(etot,i)
 251 #endif
 252       if(i.eq.1)energia(0)=1.0d+99
 253 #endif
 254 #ifdef MPL
 255 c     endif
 256 #endif
 257 #ifdef DEBUG
 258       call enerprint(energia)
 259 #endif
 260       if (calc_grad) then
 261 C
 262 C Sum up the components of the Cartesian gradient.
 263 C
 264 #ifdef SPLITELE
 265       do i=1,nct
 266         do j=1,3
 267       if (shield_mode.eq.0) then
 268           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 269      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 270      &                wbond*gradb(j,i)+
 271      &                wstrain*ghpbc(j,i)+
 272      &                wcorr*gradcorr(j,i)+
 273      &                wel_loc*gel_loc(j,i)+
 274      &                wturn3*gcorr3_turn(j,i)+
 275      &                wturn4*gcorr4_turn(j,i)+
 276      &                wcorr5*gradcorr5(j,i)+
 277      &                wcorr6*gradcorr6(j,i)+
 278      &                wturn6*gcorr6_turn(j,i)+
 279      &                wsccor*gsccorc(j,i)
 280      &               +wliptran*gliptranc(j,i)
 281           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 282      &                  wbond*gradbx(j,i)+
 283      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 284      &                  wsccor*gsccorx(j,i)
 285      &                 +wliptran*gliptranx(j,i)
 286         else
 287           gradc(j,i,icg)=wsc*gvdwc(j,i)
 288      &                +wscp*gvdwc_scp(j,i)+
 289      &               welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 290      &                wbond*gradb(j,i)+
 291      &                wstrain*ghpbc(j,i)+
 292      &                wcorr*gradcorr(j,i)+
 293      &                wel_loc*gel_loc(j,i)+
 294      &                wturn3*gcorr3_turn(j,i)+
 295      &                wturn4*gcorr4_turn(j,i)+
 296      &                wcorr5*gradcorr5(j,i)+
 297      &                wcorr6*gradcorr6(j,i)+
 298      &                wturn6*gcorr6_turn(j,i)+
 299      &                wsccor*gsccorc(j,i)
 300      &               +wliptran*gliptranc(j,i)
 301      &                 +welec*gshieldc(j,i)
 302      &                 +welec*gshieldc_loc(j,i)
 303      &                 +wcorr*gshieldc_ec(j,i)
 304      &                 +wcorr*gshieldc_loc_ec(j,i)
 305      &                 +wturn3*gshieldc_t3(j,i)
 306      &                 +wturn3*gshieldc_loc_t3(j,i)
 307      &                 +wturn4*gshieldc_t4(j,i)
 308      &                 +wturn4*gshieldc_loc_t4(j,i)
 309      &                 +wel_loc*gshieldc_ll(j,i)
 310      &                 +wel_loc*gshieldc_loc_ll(j,i)
 311
 312           gradx(j,i,icg)=wsc*gvdwx(j,i)
 313      &                 +wscp*gradx_scp(j,i)+
 314      &                  wbond*gradbx(j,i)+
 315      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 316      &                  wsccor*gsccorx(j,i)
 317      &                 +wliptran*gliptranx(j,i)
 318      &                 +welec*gshieldx(j,i)
 319      &                 +wcorr*gshieldx_ec(j,i)
 320      &                 +wturn3*gshieldx_t3(j,i)
 321      &                 +wturn4*gshieldx_t4(j,i)
 322      &                 +wel_loc*gshieldx_ll(j,i)
 323
 324
 325         endif
 326         enddo
 327 #else
 328       do i=1,nct
 329         do j=1,3
 330                 if (shield_mode.eq.0) then
 331           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 332      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 333      &                wbond*gradb(j,i)+
 334      &                wcorr*gradcorr(j,i)+
 335      &                wel_loc*gel_loc(j,i)+
 336      &                wturn3*gcorr3_turn(j,i)+
 337      &                wturn4*gcorr4_turn(j,i)+
 338      &                wcorr5*gradcorr5(j,i)+
 339      &                wcorr6*gradcorr6(j,i)+
 340      &                wturn6*gcorr6_turn(j,i)+
 341      &                wsccor*gsccorc(j,i)
 342      &               +wliptran*gliptranc(j,i)
 343           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 344      &                  wbond*gradbx(j,i)+
 345      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 346      &                  wsccor*gsccorx(j,i)
 347      &                 +wliptran*gliptranx(j,i)
 348               else
 349           gradc(j,i,icg)=wsc*gvdwc(j,i)+
 350      &                   wscp*gvdwc_scp(j,i)+
 351      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 352      &                wbond*gradb(j,i)+
 353      &                wcorr*gradcorr(j,i)+
 354      &                wel_loc*gel_loc(j,i)+
 355      &                wturn3*gcorr3_turn(j,i)+
 356      &                wturn4*gcorr4_turn(j,i)+
 357      &                wcorr5*gradcorr5(j,i)+
 358      &                wcorr6*gradcorr6(j,i)+
 359      &                wturn6*gcorr6_turn(j,i)+
 360      &                wsccor*gsccorc(j,i)
 361      &               +wliptran*gliptranc(j,i)
 362      &                 +welec*gshieldc(j,i)
 363      &                 +welec*gshieldc_loc(j,i)
 364      &                 +wcorr*gshieldc_ec(j,i)
 365      &                 +wcorr*gshieldc_loc_ec(j,i)
 366      &                 +wturn3*gshieldc_t3(j,i)
 367      &                 +wturn3*gshieldc_loc_t3(j,i)
 368      &                 +wturn4*gshieldc_t4(j,i)
 369      &                 +wturn4*gshieldc_loc_t4(j,i)
 370      &                 +wel_loc*gshieldc_ll(j,i)
 371      &                 +wel_loc*gshieldc_loc_ll(j,i)
 372
 373           gradx(j,i,icg)=wsc*gvdwx(j,i)+
 374      &                  wscp*gradx_scp(j,i)+
 375      &                  wbond*gradbx(j,i)+
 376      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 377      &                  wsccor*gsccorx(j,i)
 378      &                 +wliptran*gliptranx(j,i)
 379      &                 +welec*gshieldx(j,i)
 380      &                 +wcorr*gshieldx_ec(j,i)
 381      &                 +wturn3*gshieldx_t3(j,i)
 382      &                 +wturn4*gshieldx_t4(j,i)
 383      &                 +wel_loc*gshieldx_ll(j,i)
 384
 385          endif
 386         enddo
 387 #endif
 388       enddo
 389
 390
 391       do i=1,nres-3
 392         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 393      &   +wcorr5*g_corr5_loc(i)
 394      &   +wcorr6*g_corr6_loc(i)
 395      &   +wturn4*gel_loc_turn4(i)
 396      &   +wturn3*gel_loc_turn3(i)
 397      &   +wturn6*gel_loc_turn6(i)
 398      &   +wel_loc*gel_loc_loc(i)
 399 c     &   +wsccor*gsccor_loc(i)
 400 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 401       enddo
 402       endif
 403 c      if (dyn_ss) call dyn_set_nss
 404       return
 405       end
 406 C------------------------------------------------------------------------
 407       subroutine enerprint(energia)
 408       implicit real*8 (a-h,o-z)
 409       include 'DIMENSIONS'
 410       include 'DIMENSIONS.ZSCOPT'
 411       include 'COMMON.IOUNITS'
 412       include 'COMMON.FFIELD'
 413       include 'COMMON.SBRIDGE'
 414       double precision energia(0:max_ene)
 415       etot=energia(0)
 416       evdw=energia(1)+energia(21)
 417 #ifdef SCP14
 418       evdw2=energia(2)+energia(17)
 419 #else
 420       evdw2=energia(2)
 421 #endif
 422       ees=energia(3)
 423 #ifdef SPLITELE
 424       evdw1=energia(16)
 425 #endif
 426       ecorr=energia(4)
 427       ecorr5=energia(5)
 428       ecorr6=energia(6)
 429       eel_loc=energia(7)
 430       eello_turn3=energia(8)
 431       eello_turn4=energia(9)
 432       eello_turn6=energia(10)
 433       ebe=energia(11)
 434       escloc=energia(12)
 435       etors=energia(13)
 436       etors_d=energia(14)
 437       ehpb=energia(15)
 438       esccor=energia(19)
 439       edihcnstr=energia(20)
 440       estr=energia(17)
 441       ethetacnstr=energia(24)
 442       eliptran=energia(22)
 443 #ifdef SPLITELE
 444       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,
 445      &  wvdwpp,
 446      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor,
 447      &  etors_d,wtor_d,ehpb,wstrain,
 448      &  ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6,
 449      &  eel_loc,wel_loc,eello_turn3,wturn3,
 450      &  eello_turn4,wturn4,eello_turn6,wturn6,
 451      &  esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss,
 452      & eliptran,wliptran,etot
 453    10 format (/'Virtual-chain energies:'//
 454      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 455      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 456      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 457      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 458      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 459      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 460      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 461      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 462      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 463      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 464      & ' (SS bridges & dist. cnstr.)'/
 465      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 466      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 467      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 468      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 469      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 470      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 471      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 472      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 473      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 474      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 475      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 476      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 477      & 'ETOT=  ',1pE16.6,' (total)')
 478 #else
 479       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,
 480      &  ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d,
 481      &  ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5,
 482      &  ecorr6,wcorr6,eel_loc,wel_loc,
 483      &  eello_turn3,wturn3,eello_turn4,wturn4,
 484      &  eello_turn6,wturn6,esccor,wsccor,
 485      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 486    10 format (/'Virtual-chain energies:'//
 487      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 488      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 489      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 490      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 491      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 492      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 493      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 494      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 495      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 496      & ' (SS bridges & dist. cnstr.)'/
 497      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 498      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 499      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 500      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 501      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 502      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 503      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 504      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 505      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 506      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 507      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 508      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 509      & 'ETOT=  ',1pE16.6,' (total)')
 510 #endif
 511       return
 512       end
 513 C-----------------------------------------------------------------------
 514       subroutine elj(evdw)
 515 C
 516 C This subroutine calculates the interaction energy of nonbonded side chains
 517 C assuming the LJ potential of interaction.
 518 C
 519       implicit real*8 (a-h,o-z)
 520       include 'DIMENSIONS'
 521       include 'DIMENSIONS.ZSCOPT'
 522       parameter (accur=1.0d-10)
 523       include 'COMMON.GEO'
 524       include 'COMMON.VAR'
 525       include 'COMMON.LOCAL'
 526       include 'COMMON.CHAIN'
 527       include 'COMMON.DERIV'
 528       include 'COMMON.INTERACT'
 529       include 'COMMON.TORSION'
 530       include 'COMMON.WEIGHTDER'
 531       include 'COMMON.SBRIDGE'
 532       include 'COMMON.NAMES'
 533       include 'COMMON.IOUNITS'
 534       include 'COMMON.CONTACTS'
 535       dimension gg(3)
 536       integer icant
 537       external icant
 538 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 539       do i=1,nntyp
 540         do j=1,2
 541           eneps_temp(j,i)=0.0d0
 542         enddo
 543       enddo
 544       evdw=0.0D0
 545       do i=iatsc_s,iatsc_e
 546         itypi=itype(i)
 547         itypi1=itype(i+1)
 548         xi=c(1,nres+i)
 549         yi=c(2,nres+i)
 550         zi=c(3,nres+i)
 551 C Change 12/1/95
 552         num_conti=0
 553 C
 554 C Calculate SC interaction energy.
 555 C
 556         do iint=1,nint_gr(i)
 557 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 558 cd   &                  'iend=',iend(i,iint)
 559           do j=istart(i,iint),iend(i,iint)
 560             itypj=itype(j)
 561             xj=c(1,nres+j)-xi
 562             yj=c(2,nres+j)-yi
 563             zj=c(3,nres+j)-zi
 564 C Change 12/1/95 to calculate four-body interactions
 565             rij=xj*xj+yj*yj+zj*zj
 566             rrij=1.0D0/rij
 567 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 568             eps0ij=eps(itypi,itypj)
 569             fac=rrij**expon2
 570             e1=fac*fac*aa(itypi,itypj)
 571             e2=fac*bb(itypi,itypj)
 572             evdwij=e1+e2
 573             ij=icant(itypi,itypj)
 574             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 575             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 576 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 577 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 578 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 579 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 580 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 581 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 582             evdw=evdw+evdwij
 583             if (calc_grad) then
 584 C
 585 C Calculate the components of the gradient in DC and X
 586 C
 587             fac=-rrij*(e1+evdwij)
 588             gg(1)=xj*fac
 589             gg(2)=yj*fac
 590             gg(3)=zj*fac
 591             do k=1,3
 592               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 593               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 594             enddo
 595             do k=i,j-1
 596               do l=1,3
 597                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 598               enddo
 599             enddo
 600             endif
 601 C
 602 C 12/1/95, revised on 5/20/97
 603 C
 604 C Calculate the contact function. The ith column of the array JCONT will
 605 C contain the numbers of atoms that make contacts with the atom I (of numbers
 606 C greater than I). The arrays FACONT and GACONT will contain the values of
 607 C the contact function and its derivative.
 608 C
 609 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 610 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 611 C Uncomment next line, if the correlation interactions are contact function only
 612             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 613               rij=dsqrt(rij)
 614               sigij=sigma(itypi,itypj)
 615               r0ij=rs0(itypi,itypj)
 616 C
 617 C Check whether the SC's are not too far to make a contact.
 618 C
 619               rcut=1.5d0*r0ij
 620               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 621 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 622 C
 623               if (fcont.gt.0.0D0) then
 624 C If the SC-SC distance if close to sigma, apply spline.
 625 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 626 cAdam &             fcont1,fprimcont1)
 627 cAdam           fcont1=1.0d0-fcont1
 628 cAdam           if (fcont1.gt.0.0d0) then
 629 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 630 cAdam             fcont=fcont*fcont1
 631 cAdam           endif
 632 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 633 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 634 cga             do k=1,3
 635 cga               gg(k)=gg(k)*eps0ij
 636 cga             enddo
 637 cga             eps0ij=-evdwij*eps0ij
 638 C Uncomment for AL's type of SC correlation interactions.
 639 cadam           eps0ij=-evdwij
 640                 num_conti=num_conti+1
 641                 jcont(num_conti,i)=j
 642                 facont(num_conti,i)=fcont*eps0ij
 643                 fprimcont=eps0ij*fprimcont/rij
 644                 fcont=expon*fcont
 645 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 646 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 647 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 648 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 649                 gacont(1,num_conti,i)=-fprimcont*xj
 650                 gacont(2,num_conti,i)=-fprimcont*yj
 651                 gacont(3,num_conti,i)=-fprimcont*zj
 652 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 653 cd              write (iout,'(2i3,3f10.5)')
 654 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 655               endif
 656             endif
 657           enddo      ! j
 658         enddo        ! iint
 659 C Change 12/1/95
 660         num_cont(i)=num_conti
 661       enddo          ! i
 662       if (calc_grad) then
 663       do i=1,nct
 664         do j=1,3
 665           gvdwc(j,i)=expon*gvdwc(j,i)
 666           gvdwx(j,i)=expon*gvdwx(j,i)
 667         enddo
 668       enddo
 669       endif
 670 C******************************************************************************
 671 C
 672 C                              N O T E !!!
 673 C
 674 C To save time, the factor of EXPON has been extracted from ALL components
 675 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 676 C use!
 677 C
 678 C******************************************************************************
 679       return
 680       end
 681 C-----------------------------------------------------------------------------
 682       subroutine eljk(evdw)
 683 C
 684 C This subroutine calculates the interaction energy of nonbonded side chains
 685 C assuming the LJK potential of interaction.
 686 C
 687       implicit real*8 (a-h,o-z)
 688       include 'DIMENSIONS'
 689       include 'DIMENSIONS.ZSCOPT'
 690       include 'COMMON.GEO'
 691       include 'COMMON.VAR'
 692       include 'COMMON.LOCAL'
 693       include 'COMMON.CHAIN'
 694       include 'COMMON.DERIV'
 695       include 'COMMON.INTERACT'
 696       include 'COMMON.WEIGHTDER'
 697       include 'COMMON.IOUNITS'
 698       include 'COMMON.NAMES'
 699       dimension gg(3)
 700       logical scheck
 701       integer icant
 702       external icant
 703 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 704       do i=1,nntyp
 705         do j=1,2
 706           eneps_temp(j,i)=0.0d0
 707         enddo
 708       enddo
 709       evdw=0.0D0
 710       do i=iatsc_s,iatsc_e
 711         itypi=itype(i)
 712         itypi1=itype(i+1)
 713         xi=c(1,nres+i)
 714         yi=c(2,nres+i)
 715         zi=c(3,nres+i)
 716 C
 717 C Calculate SC interaction energy.
 718 C
 719         do iint=1,nint_gr(i)
 720           do j=istart(i,iint),iend(i,iint)
 721             itypj=itype(j)
 722             xj=c(1,nres+j)-xi
 723             yj=c(2,nres+j)-yi
 724             zj=c(3,nres+j)-zi
 725             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 726             fac_augm=rrij**expon
 727             e_augm=augm(itypi,itypj)*fac_augm
 728             r_inv_ij=dsqrt(rrij)
 729             rij=1.0D0/r_inv_ij
 730             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 731             fac=r_shift_inv**expon
 732             e1=fac*fac*aa(itypi,itypj)
 733             e2=fac*bb(itypi,itypj)
 734             evdwij=e_augm+e1+e2
 735             ij=icant(itypi,itypj)
 736             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 737      &        /dabs(eps(itypi,itypj))
 738             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 739 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 740 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 741 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 742 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 743 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 744 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 745 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 746             evdw=evdw+evdwij
 747             if (calc_grad) then
 748 C
 749 C Calculate the components of the gradient in DC and X
 750 C
 751             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 752             gg(1)=xj*fac
 753             gg(2)=yj*fac
 754             gg(3)=zj*fac
 755             do k=1,3
 756               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 757               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 758             enddo
 759             do k=i,j-1
 760               do l=1,3
 761                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 762               enddo
 763             enddo
 764             endif
 765           enddo      ! j
 766         enddo        ! iint
 767       enddo          ! i
 768       if (calc_grad) then
 769       do i=1,nct
 770         do j=1,3
 771           gvdwc(j,i)=expon*gvdwc(j,i)
 772           gvdwx(j,i)=expon*gvdwx(j,i)
 773         enddo
 774       enddo
 775       endif
 776       return
 777       end
 778 C-----------------------------------------------------------------------------
 779       subroutine ebp(evdw)
 780 C
 781 C This subroutine calculates the interaction energy of nonbonded side chains
 782 C assuming the Berne-Pechukas potential of interaction.
 783 C
 784       implicit real*8 (a-h,o-z)
 785       include 'DIMENSIONS'
 786       include 'DIMENSIONS.ZSCOPT'
 787       include 'COMMON.GEO'
 788       include 'COMMON.VAR'
 789       include 'COMMON.LOCAL'
 790       include 'COMMON.CHAIN'
 791       include 'COMMON.DERIV'
 792       include 'COMMON.NAMES'
 793       include 'COMMON.INTERACT'
 794       include 'COMMON.WEIGHTDER'
 795       include 'COMMON.IOUNITS'
 796       include 'COMMON.CALC'
 797       common /srutu/ icall
 798 c     double precision rrsave(maxdim)
 799       logical lprn
 800       integer icant
 801       external icant
 802       do i=1,nntyp
 803         do j=1,2
 804           eneps_temp(j,i)=0.0d0
 805         enddo
 806       enddo
 807       evdw=0.0D0
 808 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 809       evdw=0.0D0
 810 c     if (icall.eq.0) then
 811 c       lprn=.true.
 812 c     else
 813         lprn=.false.
 814 c     endif
 815       ind=0
 816       do i=iatsc_s,iatsc_e
 817         itypi=itype(i)
 818         itypi1=itype(i+1)
 819         xi=c(1,nres+i)
 820         yi=c(2,nres+i)
 821         zi=c(3,nres+i)
 822         dxi=dc_norm(1,nres+i)
 823         dyi=dc_norm(2,nres+i)
 824         dzi=dc_norm(3,nres+i)
 825         dsci_inv=vbld_inv(i+nres)
 826 C
 827 C Calculate SC interaction energy.
 828 C
 829         do iint=1,nint_gr(i)
 830           do j=istart(i,iint),iend(i,iint)
 831             ind=ind+1
 832             itypj=itype(j)
 833             dscj_inv=vbld_inv(j+nres)
 834             chi1=chi(itypi,itypj)
 835             chi2=chi(itypj,itypi)
 836             chi12=chi1*chi2
 837             chip1=chip(itypi)
 838             chip2=chip(itypj)
 839             chip12=chip1*chip2
 840             alf1=alp(itypi)
 841             alf2=alp(itypj)
 842             alf12=0.5D0*(alf1+alf2)
 843 C For diagnostics only!!!
 844 c           chi1=0.0D0
 845 c           chi2=0.0D0
 846 c           chi12=0.0D0
 847 c           chip1=0.0D0
 848 c           chip2=0.0D0
 849 c           chip12=0.0D0
 850 c           alf1=0.0D0
 851 c           alf2=0.0D0
 852 c           alf12=0.0D0
 853             xj=c(1,nres+j)-xi
 854             yj=c(2,nres+j)-yi
 855             zj=c(3,nres+j)-zi
 856             dxj=dc_norm(1,nres+j)
 857             dyj=dc_norm(2,nres+j)
 858             dzj=dc_norm(3,nres+j)
 859             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 860 cd          if (icall.eq.0) then
 861 cd            rrsave(ind)=rrij
 862 cd          else
 863 cd            rrij=rrsave(ind)
 864 cd          endif
 865             rij=dsqrt(rrij)
 866 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 867             call sc_angular
 868 C Calculate whole angle-dependent part of epsilon and contributions
 869 C to its derivatives
 870             fac=(rrij*sigsq)**expon2
 871             e1=fac*fac*aa(itypi,itypj)
 872             e2=fac*bb(itypi,itypj)
 873             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 874             eps2der=evdwij*eps3rt
 875             eps3der=evdwij*eps2rt
 876             evdwij=evdwij*eps2rt*eps3rt
 877             ij=icant(itypi,itypj)
 878             aux=eps1*eps2rt**2*eps3rt**2
 879             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 880      &        /dabs(eps(itypi,itypj))
 881             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 882             evdw=evdw+evdwij
 883             if (calc_grad) then
 884             if (lprn) then
 885             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 886             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 887 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 888 cd     &        restyp(itypi),i,restyp(itypj),j,
 889 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 890 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 891 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 892 cd     &        evdwij
 893             endif
 894 C Calculate gradient components.
 895             e1=e1*eps1*eps2rt**2*eps3rt**2
 896             fac=-expon*(e1+evdwij)
 897             sigder=fac/sigsq
 898             fac=rrij*fac
 899 C Calculate radial part of the gradient
 900             gg(1)=xj*fac
 901             gg(2)=yj*fac
 902             gg(3)=zj*fac
 903 C Calculate the angular part of the gradient and sum add the contributions
 904 C to the appropriate components of the Cartesian gradient.
 905             call sc_grad
 906             endif
 907           enddo      ! j
 908         enddo        ! iint
 909       enddo          ! i
 910 c     stop
 911       return
 912       end
 913 C-----------------------------------------------------------------------------
 914       subroutine egb(evdw)
 915 C
 916 C This subroutine calculates the interaction energy of nonbonded side chains
 917 C assuming the Gay-Berne potential of interaction.
 918 C
 919       implicit real*8 (a-h,o-z)
 920       include 'DIMENSIONS'
 921       include 'DIMENSIONS.ZSCOPT'
 922       include 'COMMON.CONTROL'
 923       include 'COMMON.GEO'
 924       include 'COMMON.VAR'
 925       include 'COMMON.LOCAL'
 926       include 'COMMON.CHAIN'
 927       include 'COMMON.DERIV'
 928       include 'COMMON.NAMES'
 929       include 'COMMON.INTERACT'
 930       include 'COMMON.WEIGHTDER'
 931       include 'COMMON.IOUNITS'
 932       include 'COMMON.CALC'
 933       include 'COMMON.SBRIDGE'
 934       logical lprn
 935       common /srutu/icall
 936       integer icant
 937       external icant
 938       do i=1,nntyp
 939         do j=1,2
 940           eneps_temp(j,i)=0.0d0
 941         enddo
 942       enddo
 943       evdw=0.0D0
 944 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 945       evdw=0.0D0
 946       lprn=.false.
 947 c      if (icall.gt.0) lprn=.true.
 948       ind=0
 949       do i=iatsc_s,iatsc_e
 950         itypi=iabs(itype(i))
 951         if (itypi.eq.ntyp1) cycle
 952         itypi1=iabs(itype(i+1))
 953         xi=c(1,nres+i)
 954         yi=c(2,nres+i)
 955         zi=c(3,nres+i)
 956 C Adjusting to box limits
 957         xi=mod(xi,boxxsize)
 958         if (xi.lt.0) xi=xi+boxxsize
 959         yi=mod(yi,boxysize)
 960         if (yi.lt.0) yi=yi+boxysize
 961         zi=mod(zi,boxzsize)
 962         if (zi.lt.0) zi=zi+boxzsize
 963 C end adjusting
 964 #ifdef LIPID
 965 C Lipid
 966        if ((zi.gt.bordlipbot)
 967      &.and.(zi.lt.bordliptop)) then
 968 C the energy transfer exist
 969         if (zi.lt.buflipbot) then
 970 C what fraction I am in
 971          fracinbuf=1.0d0-
 972      &        ((zi-bordlipbot)/lipbufthick)
 973 C lipbufthick is thickenes of lipid buffore
 974          sslipi=sscalelip(fracinbuf)
 975          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 976         elseif (zi.gt.bufliptop) then
 977          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 978          sslipi=sscalelip(fracinbuf)
 979          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 980         else
 981          sslipi=1.0d0
 982          ssgradlipi=0.0
 983         endif
 984        else
 985          sslipi=0.0d0
 986          ssgradlipi=0.0
 987        endif
 988 C end lipid
 989 #endif
 990         dxi=dc_norm(1,nres+i)
 991         dyi=dc_norm(2,nres+i)
 992         dzi=dc_norm(3,nres+i)
 993         dsci_inv=vbld_inv(i+nres)
 994 C
 995 C Calculate SC interaction energy.
 996 C
 997         do iint=1,nint_gr(i)
 998           do j=istart(i,iint),iend(i,iint)
 999 #ifdef SSBOND
1000 c SSbond
1001             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1002
1003 c              write(iout,*) "PRZED ZWYKLE", evdwij
1004               call dyn_ssbond_ene(i,j,evdwij)
1005 c              write(iout,*) "PO ZWYKLE", evdwij
1006
1007               evdw=evdw+evdwij
1008               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1009      &                        'evdw',i,j,evdwij,' ss'
1010 C triple bond artifac removal
1011              do k=j+1,iend(i,iint)
1012 C search over all next residues
1013               if (dyn_ss_mask(k)) then
1014 C check if they are cysteins
1015 C              write(iout,*) 'k=',k
1016
1017 c              write(iout,*) "PRZED TRI", evdwij
1018                evdwij_przed_tri=evdwij
1019               call triple_ssbond_ene(i,j,k,evdwij)
1020 c               if(evdwij_przed_tri.ne.evdwij) then
1021 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1022 c               endif
1023
1024 c              write(iout,*) "PO TRI", evdwij
1025 C call the energy function that removes the artifical triple disulfide
1026 C bond the soubroutine is located in ssMD.F
1027               evdw=evdw+evdwij
1028               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1029      &                        'evdw',i,j,evdwij,'tss'
1030               endif!dyn_ss_mask(k)
1031              enddo! k
1032 c end ssbond
1033             ELSE
1034 #endif
1035             ind=ind+1
1036             itypj=iabs(itype(j))
1037             if (itypj.eq.ntyp1) cycle
1038             dscj_inv=vbld_inv(j+nres)
1039             sig0ij=sigma(itypi,itypj)
1040             chi1=chi(itypi,itypj)
1041             chi2=chi(itypj,itypi)
1042             chi12=chi1*chi2
1043             chip1=chip(itypi)
1044             chip2=chip(itypj)
1045             chip12=chip1*chip2
1046             alf1=alp(itypi)
1047             alf2=alp(itypj)
1048             alf12=0.5D0*(alf1+alf2)
1049 C For diagnostics only!!!
1050 c           chi1=0.0D0
1051 c           chi2=0.0D0
1052 c           chi12=0.0D0
1053 c           chip1=0.0D0
1054 c           chip2=0.0D0
1055 c           chip12=0.0D0
1056 c           alf1=0.0D0
1057 c           alf2=0.0D0
1058 c           alf12=0.0D0
1059             xj=c(1,nres+j)
1060             yj=c(2,nres+j)
1061             zj=c(3,nres+j)
1062             xj=mod(xj,boxxsize)
1063             if (xj.lt.0) xj=xj+boxxsize
1064             yj=mod(yj,boxysize)
1065             if (yj.lt.0) yj=yj+boxysize
1066             zj=mod(zj,boxzsize)
1067             if (zj.lt.0) zj=zj+boxzsize
1068 #ifdef LIPID
1069             if ((zj.gt.bordlipbot)
1070      &       .and.(zj.lt.bordliptop)) then
1071 C the energy transfer exist
1072             if (zj.lt.buflipbot) then
1073 C what fraction I am in
1074                fracinbuf=1.0d0-
1075      &          ((zj-bordlipbot)/lipbufthick)
1076 C lipbufthick is thickenes of lipid buffore
1077                sslipj=sscalelip(fracinbuf)
1078                ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1079             elseif (zj.gt.bufliptop) then
1080               fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1081               sslipj=sscalelip(fracinbuf)
1082               ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1083             else
1084               sslipj=1.0d0
1085               ssgradlipj=0.0
1086             endif
1087             else
1088             sslipj=0.0d0
1089             ssgradlipj=0.0
1090             endif
1091             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1092      &      +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1093             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1094      &      +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1095 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1096 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1097 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1098 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1099 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1100 #endif
1101             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1102             xj_safe=xj
1103             yj_safe=yj
1104             zj_safe=zj
1105             subchap=0
1106             do xshift=-1,1
1107             do yshift=-1,1
1108             do zshift=-1,1
1109               xj=xj_safe+xshift*boxxsize
1110               yj=yj_safe+yshift*boxysize
1111               zj=zj_safe+zshift*boxzsize
1112               dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1113               if(dist_temp.lt.dist_init) then
1114                 dist_init=dist_temp
1115                 xj_temp=xj
1116                 yj_temp=yj
1117                 zj_temp=zj
1118                 subchap=1
1119               endif
1120             enddo
1121             enddo
1122             enddo
1123             if (subchap.eq.1) then
1124               xj=xj_temp-xi
1125               yj=yj_temp-yi
1126               zj=zj_temp-zi
1127             else
1128               xj=xj_safe-xi
1129               yj=yj_safe-yi
1130               zj=zj_safe-zi
1131             endif
1132             dxj=dc_norm(1,nres+j)
1133             dyj=dc_norm(2,nres+j)
1134             dzj=dc_norm(3,nres+j)
1135 c            write (iout,*) i,j,xj,yj,zj
1136             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1137             rij=dsqrt(rrij)
1138 C Calculate angle-dependent terms of energy and contributions to their
1139 C derivatives.
1140             call sc_angular
1141             sigsq=1.0D0/sigsq
1142             sig=sig0ij*dsqrt(sigsq)
1143             rij_shift=1.0D0/rij-sig+sig0ij
1144 C I hate to put IF's in the loops, but here don't have another choice!!!!
1145             if (rij_shift.le.0.0D0) then
1146               evdw=1.0D20
1147               return
1148             endif
1149             sigder=-sig*sigsq
1150 c---------------------------------------------------------------
1151             rij_shift=1.0D0/rij_shift
1152             fac=rij_shift**expon
1153             e1=fac*fac*aa(itypi,itypj)
1154             e2=fac*bb(itypi,itypj)
1155             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1156             eps2der=evdwij*eps3rt
1157             eps3der=evdwij*eps2rt
1158             evdwij=evdwij*eps2rt*eps3rt
1159             evdw=evdw+evdwij
1160             ij=icant(itypi,itypj)
1161             aux=eps1*eps2rt**2*eps3rt**2
1162 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1163 c     &        /dabs(eps(itypi,itypj))
1164 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1165 c-----------------------
1166             eps0ij=eps(itypi,itypj)
1167             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1168             rr0ij=r0(itypi,itypj)
1169             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1170 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1171 c-----------------------
1172 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1173 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1174 c     &         aux*e2/eps(itypi,itypj)
1175            if (lprn) then
1176            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1177             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1178             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1179      &        restyp(itypi),i,restyp(itypj),j,
1180      &        epsi,sigm,chi1,chi2,chip1,chip2,
1181      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1182      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1183      &        evdwij
1184             endif
1185             if (calc_grad) then
1186 C Calculate gradient components.
1187             e1=e1*eps1*eps2rt**2*eps3rt**2
1188             fac=-expon*(e1+evdwij)*rij_shift
1189             sigder=fac*sigder
1190             fac=rij*fac
1191 C Calculate the radial part of the gradient
1192             gg(1)=xj*fac
1193             gg(2)=yj*fac
1194             gg(3)=zj*fac
1195 C Calculate angular part of the gradient.
1196             call sc_grad
1197             endif
1198 #ifdef SSBOND
1199             ENDIF
1200 #endif
1201           enddo      ! j
1202         enddo        ! iint
1203       enddo          ! i
1204       return
1205       end
1206 C-----------------------------------------------------------------------------
1207       subroutine egbv(evdw)
1208 C
1209 C This subroutine calculates the interaction energy of nonbonded side chains
1210 C assuming the Gay-Berne-Vorobjev potential of interaction.
1211 C
1212       implicit real*8 (a-h,o-z)
1213       include 'DIMENSIONS'
1214       include 'DIMENSIONS.ZSCOPT'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.DERIV'
1220       include 'COMMON.NAMES'
1221       include 'COMMON.INTERACT'
1222       include 'COMMON.WEIGHTDER'
1223       include 'COMMON.IOUNITS'
1224       include 'COMMON.CALC'
1225       common /srutu/ icall
1226       logical lprn
1227       integer icant
1228       external icant
1229       do i=1,nntyp
1230         do j=1,2
1231           eneps_temp(j,i)=0.0d0
1232         enddo
1233       enddo
1234       evdw=0.0D0
1235 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1236       evdw=0.0D0
1237       lprn=.false.
1238 c      if (icall.gt.0) lprn=.true.
1239       ind=0
1240       do i=iatsc_s,iatsc_e
1241         itypi=itype(i)
1242         itypi1=itype(i+1)
1243         xi=c(1,nres+i)
1244         yi=c(2,nres+i)
1245         zi=c(3,nres+i)
1246         dxi=dc_norm(1,nres+i)
1247         dyi=dc_norm(2,nres+i)
1248         dzi=dc_norm(3,nres+i)
1249         dsci_inv=vbld_inv(i+nres)
1250 C
1251 C Calculate SC interaction energy.
1252 C
1253         do iint=1,nint_gr(i)
1254           do j=istart(i,iint),iend(i,iint)
1255             ind=ind+1
1256             itypj=itype(j)
1257             dscj_inv=vbld_inv(j+nres)
1258             sig0ij=sigma(itypi,itypj)
1259             r0ij=r0(itypi,itypj)
1260             chi1=chi(itypi,itypj)
1261             chi2=chi(itypj,itypi)
1262             chi12=chi1*chi2
1263             chip1=chip(itypi)
1264             chip2=chip(itypj)
1265             chip12=chip1*chip2
1266             alf1=alp(itypi)
1267             alf2=alp(itypj)
1268             alf12=0.5D0*(alf1+alf2)
1269 C For diagnostics only!!!
1270 c           chi1=0.0D0
1271 c           chi2=0.0D0
1272 c           chi12=0.0D0
1273 c           chip1=0.0D0
1274 c           chip2=0.0D0
1275 c           chip12=0.0D0
1276 c           alf1=0.0D0
1277 c           alf2=0.0D0
1278 c           alf12=0.0D0
1279             xj=c(1,nres+j)-xi
1280             yj=c(2,nres+j)-yi
1281             zj=c(3,nres+j)-zi
1282             dxj=dc_norm(1,nres+j)
1283             dyj=dc_norm(2,nres+j)
1284             dzj=dc_norm(3,nres+j)
1285             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1286             rij=dsqrt(rrij)
1287 C Calculate angle-dependent terms of energy and contributions to their
1288 C derivatives.
1289             call sc_angular
1290             sigsq=1.0D0/sigsq
1291             sig=sig0ij*dsqrt(sigsq)
1292             rij_shift=1.0D0/rij-sig+r0ij
1293 C I hate to put IF's in the loops, but here don't have another choice!!!!
1294             if (rij_shift.le.0.0D0) then
1295               evdw=1.0D20
1296               return
1297             endif
1298             sigder=-sig*sigsq
1299 c---------------------------------------------------------------
1300             rij_shift=1.0D0/rij_shift
1301             fac=rij_shift**expon
1302             e1=fac*fac*aa(itypi,itypj)
1303             e2=fac*bb(itypi,itypj)
1304             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1305             eps2der=evdwij*eps3rt
1306             eps3der=evdwij*eps2rt
1307             fac_augm=rrij**expon
1308             e_augm=augm(itypi,itypj)*fac_augm
1309             evdwij=evdwij*eps2rt*eps3rt
1310             evdw=evdw+evdwij+e_augm
1311             ij=icant(itypi,itypj)
1312             aux=eps1*eps2rt**2*eps3rt**2
1313             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1314      &        /dabs(eps(itypi,itypj))
1315             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1316 c            eneps_temp(ij)=eneps_temp(ij)
1317 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1318 c            if (lprn) then
1319 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1320 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1321 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1322 c     &        restyp(itypi),i,restyp(itypj),j,
1323 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1324 c     &        chi1,chi2,chip1,chip2,
1325 c     &        eps1,eps2rt**2,eps3rt**2,
1326 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1327 c     &        evdwij+e_augm
1328 c            endif
1329             if (calc_grad) then
1330 C Calculate gradient components.
1331             e1=e1*eps1*eps2rt**2*eps3rt**2
1332             fac=-expon*(e1+evdwij)*rij_shift
1333             sigder=fac*sigder
1334             fac=rij*fac-2*expon*rrij*e_augm
1335 C Calculate the radial part of the gradient
1336             gg(1)=xj*fac
1337             gg(2)=yj*fac
1338             gg(3)=zj*fac
1339 C Calculate angular part of the gradient.
1340             call sc_grad
1341             endif
1342           enddo      ! j
1343         enddo        ! iint
1344       enddo          ! i
1345       return
1346       end
1347 C-----------------------------------------------------------------------------
1348       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1349 C
1350 C This subroutine calculates the interaction energy of nonbonded side chains
1351 C assuming the Gay-Berne potential of interaction.
1352 C
1353        IMPLICIT NONE
1354        INCLUDE 'DIMENSIONS'
1355        INCLUDE 'DIMENSIONS.ZSCOPT'
1356        INCLUDE 'COMMON.CALC'
1357        INCLUDE 'COMMON.CONTROL'
1358        INCLUDE 'COMMON.CHAIN'
1359        INCLUDE 'COMMON.DERIV'
1360        INCLUDE 'COMMON.EMP'
1361        INCLUDE 'COMMON.GEO'
1362        INCLUDE 'COMMON.INTERACT'
1363        INCLUDE 'COMMON.IOUNITS'
1364        INCLUDE 'COMMON.LOCAL'
1365        INCLUDE 'COMMON.NAMES'
1366        INCLUDE 'COMMON.VAR'
1367        INCLUDE 'COMMON.WEIGHTDER'
1368        logical lprn
1369        double precision scalar
1370        double precision ener(4)
1371        integer troll
1372        integer iint,ij
1373        integer icant
1374
1375        energy_dec=.false.
1376        IF (energy_dec) write (iout,'(a)')
1377      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1378      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1379        evdw   = 0.0D0
1380        evdw_p = 0.0D0
1381        evdw_m = 0.0D0
1382 c DIAGNOSTICS
1383 ccccc      energy_dec=.false.
1384 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1385 c      lprn   = .false.
1386 c     if (icall.eq.0) lprn=.false.
1387 c END DIAGNOSTICS
1388 c      ind = 0
1389        DO i = iatsc_s, iatsc_e
1390         itypi  = itype(i)
1391 c        itypi1 = itype(i+1)
1392         dxi    = dc_norm(1,nres+i)
1393         dyi    = dc_norm(2,nres+i)
1394         dzi    = dc_norm(3,nres+i)
1395 c        dsci_inv=dsc_inv(itypi)
1396         dsci_inv = vbld_inv(i+nres)
1397 c        DO k = 1, 3
1398 c         ctail(k,1) = c(k, i+nres)
1399 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1400 c        END DO
1401         xi=c(1,nres+i)
1402         yi=c(2,nres+i)
1403         zi=c(3,nres+i)
1404 c!-------------------------------------------------------------------
1405 C Calculate SC interaction energy.
1406         DO iint = 1, nint_gr(i)
1407          DO j = istart(i,iint), iend(i,iint)
1408 c! initialize variables for electrostatic gradients
1409           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1410 c            ind=ind+1
1411 c            dscj_inv = dsc_inv(itypj)
1412           dscj_inv = vbld_inv(j+nres)
1413 c! rij holds 1/(distance of Calpha atoms)
1414           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1415           rij  = dsqrt(rrij)
1416 c!-------------------------------------------------------------------
1417 C Calculate angle-dependent terms of energy and contributions to their
1418 C derivatives.
1419
1420 #ifdef CHECK_MOMO
1421 c!      DO troll = 10, 5000
1422 c!      om1    = 0.0d0
1423 c!      om2    = 0.0d0
1424 c!      om12   = 1.0d0
1425 c!      sqom1  = om1 * om1
1426 c!      sqom2  = om2 * om2
1427 c!      sqom12 = om12 * om12
1428 c!      rij    = 5.0d0 / troll
1429 c!      rrij   = rij * rij
1430 c!      Rtail  = troll / 5.0d0
1431 c!      Rhead  = troll / 5.0d0
1432 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1433 c!      Rtail = dsqrt((Rtail**2)
1434 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1435 c!      rij = 1.0d0/Rtail
1436 c!      rrij = rij * rij
1437 #endif
1438           CALL sc_angular
1439 c! this should be in elgrad_init but om's are calculated by sc_angular
1440 c! which in turn is used by older potentials
1441 c! which proves how tangled UNRES code is >.<
1442 c! om = omega, sqom = om^2
1443           sqom1  = om1 * om1
1444           sqom2  = om2 * om2
1445           sqom12 = om12 * om12
1446
1447 c! now we calculate EGB - Gey-Berne
1448 c! It will be summed up in evdwij and saved in evdw
1449           sigsq     = 1.0D0  / sigsq
1450           sig       = sig0ij * dsqrt(sigsq)
1451 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1452           rij_shift = Rtail - sig + sig0ij
1453           IF (rij_shift.le.0.0D0) THEN
1454            evdw = 1.0D20
1455            RETURN
1456           END IF
1457           sigder = -sig * sigsq
1458           rij_shift = 1.0D0 / rij_shift
1459           fac       = rij_shift**expon
1460           c1        = fac  * fac * aa(itypi,itypj)
1461 c!          c1        = 0.0d0
1462           c2        = fac  * bb(itypi,itypj)
1463 c!          c2        = 0.0d0
1464           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1465           eps2der   = eps3rt * evdwij
1466           eps3der   = eps2rt * evdwij
1467 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1468           evdwij    = eps2rt * eps3rt * evdwij
1469 c!      evdwij = 0.0d0
1470 c!      write (*,*) "Gey Berne = ", evdwij
1471 #ifdef TSCSC
1472           IF (bb(itypi,itypj).gt.0) THEN
1473            evdw_p = evdw_p + evdwij
1474           ELSE
1475            evdw_m = evdw_m + evdwij
1476           END IF
1477 #else
1478           evdw = evdw
1479      &         + evdwij
1480 #endif
1481 c!-------------------------------------------------------------------
1482 c! Calculate some components of GGB
1483           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1484           fac    = -expon * (c1 + evdwij) * rij_shift
1485           sigder = fac * sigder
1486 c!          fac    = rij * fac
1487 c! Calculate distance derivative
1488 c!          gg(1) = xj * fac
1489 c!          gg(2) = yj * fac
1490 c!          gg(3) = zj * fac
1491           gg(1) = fac
1492           gg(2) = fac
1493           gg(3) = fac
1494 c!      write (*,*) "gg(1) = ", gg(1)
1495 c!      write (*,*) "gg(2) = ", gg(2)
1496 c!      write (*,*) "gg(3) = ", gg(3)
1497 c! The angular derivatives of GGB are brought together in sc_grad
1498 c!-------------------------------------------------------------------
1499 c! Fcav
1500 c!
1501 c! Catch gly-gly interactions to skip calculation of something that
1502 c! does not exist
1503
1504       IF (itypi.eq.10.and.itypj.eq.10) THEN
1505        Fcav = 0.0d0
1506        dFdR = 0.0d0
1507        dCAVdOM1  = 0.0d0
1508        dCAVdOM2  = 0.0d0
1509        dCAVdOM12 = 0.0d0
1510       ELSE
1511
1512 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1513        fac = chis1 * sqom1 + chis2 * sqom2
1514      &     - 2.0d0 * chis12 * om1 * om2 * om12
1515 c! we will use pom later in Gcav, so dont mess with it!
1516        pom = 1.0d0 - chis1 * chis2 * sqom12
1517
1518        Lambf = (1.0d0 - (fac / pom))
1519        Lambf = dsqrt(Lambf)
1520
1521
1522        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1523 c!       write (*,*) "sparrow = ", sparrow
1524        Chif = Rtail * sparrow
1525        ChiLambf = Chif * Lambf
1526        eagle = dsqrt(ChiLambf)
1527        bat = ChiLambf ** 11.0d0
1528
1529        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1530        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1531        botsq = bot * bot
1532
1533 c!      write (*,*) "sig1 = ",sig1
1534 c!      write (*,*) "sig2 = ",sig2
1535 c!      write (*,*) "Rtail = ",Rtail
1536 c!      write (*,*) "sparrow = ",sparrow
1537 c!      write (*,*) "Chis1 = ", chis1
1538 c!      write (*,*) "Chis2 = ", chis2
1539 c!      write (*,*) "Chis12 = ", chis12
1540 c!      write (*,*) "om1 = ", om1
1541 c!      write (*,*) "om2 = ", om2
1542 c!      write (*,*) "om12 = ", om12
1543 c!      write (*,*) "sqom1 = ", sqom1
1544 c!      write (*,*) "sqom2 = ", sqom2
1545 c!      write (*,*) "sqom12 = ", sqom12
1546 c!      write (*,*) "Lambf = ",Lambf
1547 c!      write (*,*) "b1 = ",b1
1548 c!      write (*,*) "b2 = ",b2
1549 c!      write (*,*) "b3 = ",b3
1550 c!      write (*,*) "b4 = ",b4
1551 c!      write (*,*) "top = ",top
1552 c!      write (*,*) "bot = ",bot
1553        Fcav = top / bot
1554 c!       Fcav = 0.0d0
1555 c!      write (*,*) "Fcav = ", Fcav
1556 c!-------------------------------------------------------------------
1557 c! derivative of Fcav is Gcav...
1558 c!---------------------------------------------------
1559
1560        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1561        dbot = 12.0d0 * b4 * bat * Lambf
1562        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1563 c!       dFdR = 0.0d0
1564 c!      write (*,*) "dFcav/dR = ", dFdR
1565
1566        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1567        dbot = 12.0d0 * b4 * bat * Chif
1568        eagle = Lambf * pom
1569        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1570        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1571        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1572      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1573
1574        dFdL = ((dtop * bot - top * dbot) / botsq)
1575 c!       dFdL = 0.0d0
1576        dCAVdOM1  = dFdL * ( dFdOM1 )
1577        dCAVdOM2  = dFdL * ( dFdOM2 )
1578        dCAVdOM12 = dFdL * ( dFdOM12 )
1579 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1580 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1581 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1582 c!      write (*,*) ""
1583 c!-------------------------------------------------------------------
1584 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1585 c! Pom is used here to project the gradient vector into
1586 c! cartesian coordinates and at the same time contains
1587 c! dXhb/dXsc derivative (for charged amino acids
1588 c! location of hydrophobic centre of interaction is not
1589 c! the same as geometric centre of side chain, this
1590 c! derivative takes that into account)
1591 c! derivatives of omega angles will be added in sc_grad
1592
1593        DO k= 1, 3
1594         ertail(k) = Rtail_distance(k)/Rtail
1595        END DO
1596        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1597        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1598        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1599        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1600        DO k = 1, 3
1601 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1602 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1603         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1604         gvdwx(k,i) = gvdwx(k,i)
1605      &             - (( dFdR + gg(k) ) * pom)
1606 c!     &             - ( dFdR * pom )
1607         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1608         gvdwx(k,j) = gvdwx(k,j)
1609      &             + (( dFdR + gg(k) ) * pom)
1610 c!     &             + ( dFdR * pom )
1611
1612         gvdwc(k,i) = gvdwc(k,i)
1613      &             - (( dFdR + gg(k) ) * ertail(k))
1614 c!     &             - ( dFdR * ertail(k))
1615
1616         gvdwc(k,j) = gvdwc(k,j)
1617      &             + (( dFdR + gg(k) ) * ertail(k))
1618 c!     &             + ( dFdR * ertail(k))
1619
1620         gg(k) = 0.0d0
1621 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1622 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1623       END DO
1624
1625 c!-------------------------------------------------------------------
1626 c! Compute head-head and head-tail energies for each state
1627
1628           isel = iabs(Qi) + iabs(Qj)
1629           IF (isel.eq.0) THEN
1630 c! No charges - do nothing
1631            eheadtail = 0.0d0
1632
1633           ELSE IF (isel.eq.4) THEN
1634 c! Calculate dipole-dipole interactions
1635            CALL edd(ecl)
1636            eheadtail = ECL
1637
1638           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1639 c! Charge-nonpolar interactions
1640            CALL eqn(epol)
1641            eheadtail = epol
1642
1643           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1644 c! Nonpolar-charge interactions
1645            CALL enq(epol)
1646            eheadtail = epol
1647
1648           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1649 c! Charge-dipole interactions
1650            CALL eqd(ecl, elj, epol)
1651            eheadtail = ECL + elj + epol
1652
1653           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1654 c! Dipole-charge interactions
1655            CALL edq(ecl, elj, epol)
1656            eheadtail = ECL + elj + epol
1657
1658           ELSE IF ((isel.eq.2.and.
1659      &          iabs(Qi).eq.1).and.
1660      &          nstate(itypi,itypj).eq.1) THEN
1661 c! Same charge-charge interaction ( +/+ or -/- )
1662            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1663            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1664
1665           ELSE IF ((isel.eq.2.and.
1666      &          iabs(Qi).eq.1).and.
1667      &          nstate(itypi,itypj).ne.1) THEN
1668 c! Different charge-charge interaction ( +/- or -/+ )
1669            CALL energy_quad
1670      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1671           END IF
1672        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1673 c!      write (*,*) "evdw = ", evdw
1674 c!      write (*,*) "Fcav = ", Fcav
1675 c!      write (*,*) "eheadtail = ", eheadtail
1676        evdw = evdw
1677      &      + Fcav
1678      &      + eheadtail
1679        ij=icant(itypi,itypj)
1680        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1681        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1682        eneps_temp(3,ij)=eheadtail
1683        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1684      &  restyp(itype(i)),i,restyp(itype(j)),j,
1685      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1686      &  Equad,evdw
1687        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1688      &  restyp(itype(i)),i,restyp(itype(j)),j,
1689      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1690      &  Equad,evdw
1691 #ifdef CHECK_MOMO
1692        evdw = 0.0d0
1693        END DO ! troll
1694 #endif
1695
1696 c!-------------------------------------------------------------------
1697 c! As all angular derivatives are done, now we sum them up,
1698 c! then transform and project into cartesian vectors and add to gvdwc
1699 c! We call sc_grad always, with the exception of +/- interaction.
1700 c! This is because energy_quad subroutine needs to handle
1701 c! this job in his own way.
1702 c! This IS probably not very efficient and SHOULD be optimised
1703 c! but it will require major restructurization of emomo
1704 c! so it will be left as it is for now
1705 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1706        IF (nstate(itypi,itypj).eq.1) THEN
1707 #ifdef TSCSC
1708         IF (bb(itypi,itypj).gt.0) THEN
1709          CALL sc_grad
1710         ELSE
1711          CALL sc_grad_T
1712         END IF
1713 #else
1714         CALL sc_grad
1715 #endif
1716        END IF
1717 c!-------------------------------------------------------------------
1718 c! NAPISY KONCOWE
1719          END DO   ! j
1720         END DO    ! iint
1721        END DO     ! i
1722 c      write (iout,*) "Number of loop steps in EGB:",ind
1723 c      energy_dec=.false.
1724        RETURN
1725       END SUBROUTINE emomo
1726 c! END OF MOMO
1727 C-----------------------------------------------------------------------------
1728       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1729        IMPLICIT NONE
1730        INCLUDE 'DIMENSIONS'
1731        INCLUDE 'DIMENSIONS.ZSCOPT'
1732        INCLUDE 'COMMON.CALC'
1733        INCLUDE 'COMMON.CHAIN'
1734        INCLUDE 'COMMON.CONTROL'
1735        INCLUDE 'COMMON.DERIV'
1736        INCLUDE 'COMMON.EMP'
1737        INCLUDE 'COMMON.GEO'
1738        INCLUDE 'COMMON.INTERACT'
1739        INCLUDE 'COMMON.IOUNITS'
1740        INCLUDE 'COMMON.LOCAL'
1741        INCLUDE 'COMMON.NAMES'
1742        INCLUDE 'COMMON.VAR'
1743        double precision scalar, facd3, facd4, federmaus, adler
1744 c! Epol and Gpol analytical parameters
1745        alphapol1 = alphapol(itypi,itypj)
1746        alphapol2 = alphapol(itypj,itypi)
1747 c! Fisocav and Gisocav analytical parameters
1748        al1  = alphiso(1,itypi,itypj)
1749        al2  = alphiso(2,itypi,itypj)
1750        al3  = alphiso(3,itypi,itypj)
1751        al4  = alphiso(4,itypi,itypj)
1752        csig = (1.0d0
1753      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1754      &      + sigiso2(itypi,itypj)**2.0d0))
1755 c!
1756        pis  = sig0head(itypi,itypj)
1757        eps_head = epshead(itypi,itypj)
1758        Rhead_sq = Rhead * Rhead
1759 c! R1 - distance between head of ith side chain and tail of jth sidechain
1760 c! R2 - distance between head of jth side chain and tail of ith sidechain
1761        R1 = 0.0d0
1762        R2 = 0.0d0
1763        DO k = 1, 3
1764 c! Calculate head-to-tail distances needed by Epol
1765         R1=R1+(ctail(k,2)-chead(k,1))**2
1766         R2=R2+(chead(k,2)-ctail(k,1))**2
1767        END DO
1768 c! Pitagoras
1769        R1 = dsqrt(R1)
1770        R2 = dsqrt(R2)
1771
1772 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1773 c!     &        +dhead(1,1,itypi,itypj))**2))
1774 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1775 c!     &        +dhead(2,1,itypi,itypj))**2))
1776 c!-------------------------------------------------------------------
1777 c! Coulomb electrostatic interaction
1778        Ecl = (332.0d0 * Qij) / Rhead
1779 c! derivative of Ecl is Gcl...
1780        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1781        dGCLdOM1 = 0.0d0
1782        dGCLdOM2 = 0.0d0
1783        dGCLdOM12 = 0.0d0
1784 c!-------------------------------------------------------------------
1785 c! Generalised Born Solvent Polarization
1786 c! Charged head polarizes the solvent
1787        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1788        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1789        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1790 c! Derivative of Egb is Ggb...
1791        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1792        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1793      &        / ( 2.0d0 * Fgb )
1794        dGGBdR = dGGBdFGB * dFGBdR
1795 c!-------------------------------------------------------------------
1796 c! Fisocav - isotropic cavity creation term
1797 c! or "how much energy it costs to put charged head in water"
1798        pom = Rhead * csig
1799        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1800        bot = (1.0d0 + al4 * pom**12.0d0)
1801        botsq = bot * bot
1802        FisoCav = top / bot
1803 c!      write (*,*) "Rhead = ",Rhead
1804 c!      write (*,*) "csig = ",csig
1805 c!      write (*,*) "pom = ",pom
1806 c!      write (*,*) "al1 = ",al1
1807 c!      write (*,*) "al2 = ",al2
1808 c!      write (*,*) "al3 = ",al3
1809 c!      write (*,*) "al4 = ",al4
1810 c!      write (*,*) "top = ",top
1811 c!      write (*,*) "bot = ",bot
1812 c! Derivative of Fisocav is GCV...
1813        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1814        dbot = 12.0d0 * al4 * pom ** 11.0d0
1815        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1816 c!-------------------------------------------------------------------
1817 c! Epol
1818 c! Polarization energy - charged heads polarize hydrophobic "neck"
1819        MomoFac1 = (1.0d0 - chi1 * sqom2)
1820        MomoFac2 = (1.0d0 - chi2 * sqom1)
1821        RR1  = ( R1 * R1 ) / MomoFac1
1822        RR2  = ( R2 * R2 ) / MomoFac2
1823        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1824        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1825        fgb1 = sqrt( RR1 + a12sq * ee1 )
1826        fgb2 = sqrt( RR2 + a12sq * ee2 )
1827        epol = 332.0d0 * eps_inout_fac * (
1828      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1829 c!       epol = 0.0d0
1830 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1831 c       write (*,*) "alphapol1 = ", alphapol1
1832 c       write (*,*) "alphapol2 = ", alphapol2
1833 c       write (*,*) "fgb1 = ", fgb1
1834 c       write (*,*) "fgb2 = ", fgb2
1835 c       write (*,*) "epol = ", epol
1836 c! derivative of Epol is Gpol...
1837        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1838      &          / (fgb1 ** 5.0d0)
1839        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1840      &          / (fgb2 ** 5.0d0)
1841        dFGBdR1 = ( (R1 / MomoFac1)
1842      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1843      &        / ( 2.0d0 * fgb1 )
1844        dFGBdR2 = ( (R2 / MomoFac2)
1845      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1846      &        / ( 2.0d0 * fgb2 )
1847        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1848      &          * ( 2.0d0 - 0.5d0 * ee1) )
1849      &          / ( 2.0d0 * fgb1 )
1850        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1851      &          * ( 2.0d0 - 0.5d0 * ee2) )
1852      &          / ( 2.0d0 * fgb2 )
1853        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1854 c!       dPOLdR1 = 0.0d0
1855        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1856 c!       dPOLdR2 = 0.0d0
1857        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1858 c!       dPOLdOM1 = 0.0d0
1859        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1860 c!       dPOLdOM2 = 0.0d0
1861 c!-------------------------------------------------------------------
1862 c! Elj
1863 c! Lennard-Jones 6-12 interaction between heads
1864        pom = (pis / Rhead)**6.0d0
1865        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1866 c! derivative of Elj is Glj
1867        dGLJdR = 4.0d0 * eps_head
1868      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1869      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1870 c!-------------------------------------------------------------------
1871 c! Return the results
1872 c! These things do the dRdX derivatives, that is
1873 c! allow us to change what we see from function that changes with
1874 c! distance to function that changes with LOCATION (of the interaction
1875 c! site)
1876        DO k = 1, 3
1877         erhead(k) = Rhead_distance(k)/Rhead
1878         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1879         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1880        END DO
1881
1882        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1883        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1884        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1885        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1886        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1887        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1888        facd1 = d1 * vbld_inv(i+nres)
1889        facd2 = d2 * vbld_inv(j+nres)
1890        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1891        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1892
1893 c! Now we add appropriate partial derivatives (one in each dimension)
1894        DO k = 1, 3
1895         hawk   = (erhead_tail(k,1) +
1896      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1897         condor = (erhead_tail(k,2) +
1898      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1899
1900         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1901         gvdwx(k,i) = gvdwx(k,i)
1902      &             - dGCLdR * pom
1903      &             - dGGBdR * pom
1904      &             - dGCVdR * pom
1905      &             - dPOLdR1 * hawk
1906      &             - dPOLdR2 * (erhead_tail(k,2)
1907      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1908      &             - dGLJdR * pom
1909
1910         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1911         gvdwx(k,j) = gvdwx(k,j)
1912      &             + dGCLdR * pom
1913      &             + dGGBdR * pom
1914      &             + dGCVdR * pom
1915      &             + dPOLdR1 * (erhead_tail(k,1)
1916      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1917      &             + dPOLdR2 * condor
1918      &             + dGLJdR * pom
1919
1920         gvdwc(k,i) = gvdwc(k,i)
1921      &             - dGCLdR * erhead(k)
1922      &             - dGGBdR * erhead(k)
1923      &             - dGCVdR * erhead(k)
1924      &             - dPOLdR1 * erhead_tail(k,1)
1925      &             - dPOLdR2 * erhead_tail(k,2)
1926      &             - dGLJdR * erhead(k)
1927
1928         gvdwc(k,j) = gvdwc(k,j)
1929      &             + dGCLdR * erhead(k)
1930      &             + dGGBdR * erhead(k)
1931      &             + dGCVdR * erhead(k)
1932      &             + dPOLdR1 * erhead_tail(k,1)
1933      &             + dPOLdR2 * erhead_tail(k,2)
1934      &             + dGLJdR * erhead(k)
1935
1936        END DO
1937        RETURN
1938       END SUBROUTINE eqq
1939 c!-------------------------------------------------------------------
1940       SUBROUTINE energy_quad
1941      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1942        IMPLICIT NONE
1943        INCLUDE 'DIMENSIONS'
1944        INCLUDE 'DIMENSIONS.ZSCOPT'
1945        INCLUDE 'COMMON.CALC'
1946        INCLUDE 'COMMON.CHAIN'
1947        INCLUDE 'COMMON.CONTROL'
1948        INCLUDE 'COMMON.DERIV'
1949        INCLUDE 'COMMON.EMP'
1950        INCLUDE 'COMMON.GEO'
1951        INCLUDE 'COMMON.INTERACT'
1952        INCLUDE 'COMMON.IOUNITS'
1953        INCLUDE 'COMMON.LOCAL'
1954        INCLUDE 'COMMON.NAMES'
1955        INCLUDE 'COMMON.VAR'
1956        double precision scalar
1957        double precision ener(4)
1958        double precision dcosom1(3),dcosom2(3)
1959 c! used in Epol derivatives
1960        double precision facd3, facd4
1961        double precision federmaus, adler
1962 c! Epol and Gpol analytical parameters
1963        alphapol1 = alphapol(itypi,itypj)
1964        alphapol2 = alphapol(itypj,itypi)
1965 c! Fisocav and Gisocav analytical parameters
1966        al1  = alphiso(1,itypi,itypj)
1967        al2  = alphiso(2,itypi,itypj)
1968        al3  = alphiso(3,itypi,itypj)
1969        al4  = alphiso(4,itypi,itypj)
1970        csig = (1.0d0
1971      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1972      &      + sigiso2(itypi,itypj)**2.0d0))
1973 c!
1974        w1   = wqdip(1,itypi,itypj)
1975        w2   = wqdip(2,itypi,itypj)
1976        pis  = sig0head(itypi,itypj)
1977        eps_head = epshead(itypi,itypj)
1978 c! First things first:
1979 c! We need to do sc_grad's job with GB and Fcav
1980        eom1  =
1981      &         eps2der * eps2rt_om1
1982      &       - 2.0D0 * alf1 * eps3der
1983      &       + sigder * sigsq_om1
1984      &       + dCAVdOM1
1985        eom2  =
1986      &         eps2der * eps2rt_om2
1987      &       + 2.0D0 * alf2 * eps3der
1988      &       + sigder * sigsq_om2
1989      &       + dCAVdOM2
1990        eom12 =
1991      &         evdwij  * eps1_om12
1992      &       + eps2der * eps2rt_om12
1993      &       - 2.0D0 * alf12 * eps3der
1994      &       + sigder *sigsq_om12
1995      &       + dCAVdOM12
1996 c! now some magical transformations to project gradient into
1997 c! three cartesian vectors
1998        DO k = 1, 3
1999         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2000         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2001         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
2002 c! this acts on hydrophobic center of interaction
2003         gvdwx(k,i)= gvdwx(k,i) - gg(k)
2004      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2005      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2006         gvdwx(k,j)= gvdwx(k,j) + gg(k)
2007      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2008      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2009 c! this acts on Calpha
2010         gvdwc(k,i)=gvdwc(k,i)-gg(k)
2011         gvdwc(k,j)=gvdwc(k,j)+gg(k)
2012        END DO
2013 c! sc_grad is done, now we will compute
2014        eheadtail = 0.0d0
2015        eom1 = 0.0d0
2016        eom2 = 0.0d0
2017        eom12 = 0.0d0
2018
2019 c! ENERGY DEBUG
2020 c!       ii = 1
2021 c!       jj = 1
2022 c!       d1 = dhead(1, 1, itypi, itypj)
2023 c!       d2 = dhead(2, 1, itypi, itypj)
2024 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2025 c!     &        +dhead(1,ii,itypi,itypj))**2))
2026 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2027 c!     &        +dhead(2,jj,itypi,itypj))**2))
2028 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
2029 c! END OF ENERGY DEBUG
2030 c*************************************************************
2031        DO istate = 1, nstate(itypi,itypj)
2032 c*************************************************************
2033         IF (istate.ne.1) THEN
2034          IF (istate.lt.3) THEN
2035           ii = 1
2036          ELSE
2037           ii = 2
2038          END IF
2039         jj = istate/ii
2040         d1 = dhead(1,ii,itypi,itypj)
2041         d2 = dhead(2,jj,itypi,itypj)
2042         DO k = 1,3
2043          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2044          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2045          Rhead_distance(k) = chead(k,2) - chead(k,1)
2046         END DO
2047 c! pitagoras (root of sum of squares)
2048         Rhead = dsqrt(
2049      &          (Rhead_distance(1)*Rhead_distance(1))
2050      &        + (Rhead_distance(2)*Rhead_distance(2))
2051      &        + (Rhead_distance(3)*Rhead_distance(3)))
2052         END IF
2053         Rhead_sq = Rhead * Rhead
2054
2055 c! R1 - distance between head of ith side chain and tail of jth sidechain
2056 c! R2 - distance between head of jth side chain and tail of ith sidechain
2057         R1 = 0.0d0
2058         R2 = 0.0d0
2059         DO k = 1, 3
2060 c! Calculate head-to-tail distances
2061          R1=R1+(ctail(k,2)-chead(k,1))**2
2062          R2=R2+(chead(k,2)-ctail(k,1))**2
2063         END DO
2064 c! Pitagoras
2065         R1 = dsqrt(R1)
2066         R2 = dsqrt(R2)
2067
2068 c! ENERGY DEBUG
2069 c!      write (*,*) "istate = ", istate
2070 c!      write (*,*) "ii = ", ii
2071 c!      write (*,*) "jj = ", jj
2072 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2073 c!     &        +dhead(1,ii,itypi,itypj))**2))
2074 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2075 c!     &        +dhead(2,jj,itypi,itypj))**2))
2076 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
2077 c!      Rhead_sq = Rhead * Rhead
2078 c!      write (*,*) "d1 = ",d1
2079 c!      write (*,*) "d2 = ",d2
2080 c!      write (*,*) "R1 = ",R1
2081 c!      write (*,*) "R2 = ",R2
2082 c!      write (*,*) "Rhead = ",Rhead
2083 c! END OF ENERGY DEBUG
2084
2085 c!-------------------------------------------------------------------
2086 c! Coulomb electrostatic interaction
2087         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
2088 c!        Ecl = 0.0d0
2089 c!        write (*,*) "Ecl = ", Ecl
2090 c! derivative of Ecl is Gcl...
2091         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
2092 c!        dGCLdR = 0.0d0
2093         dGCLdOM1 = 0.0d0
2094         dGCLdOM2 = 0.0d0
2095         dGCLdOM12 = 0.0d0
2096 c!-------------------------------------------------------------------
2097 c! Generalised Born Solvent Polarization
2098         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
2099         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
2100         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
2101 c!        Egb = 0.0d0
2102 c!      write (*,*) "a1*a2 = ", a12sq
2103 c!      write (*,*) "Rhead = ", Rhead
2104 c!      write (*,*) "Rhead_sq = ", Rhead_sq
2105 c!      write (*,*) "ee = ", ee
2106 c!      write (*,*) "Fgb = ", Fgb
2107 c!      write (*,*) "fac = ", eps_inout_fac
2108 c!      write (*,*) "Qij = ", Qij
2109 c!      write (*,*) "Egb = ", Egb
2110 c! Derivative of Egb is Ggb...
2111 c! dFGBdR is used by Quad's later...
2112         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
2113         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
2114      &         / ( 2.0d0 * Fgb )
2115         dGGBdR = dGGBdFGB * dFGBdR
2116 c!        dGGBdR = 0.0d0
2117 c!-------------------------------------------------------------------
2118 c! Fisocav - isotropic cavity creation term
2119         pom = Rhead * csig
2120         top = al1 * (dsqrt(pom) + al2 * pom - al3)
2121         bot = (1.0d0 + al4 * pom**12.0d0)
2122         botsq = bot * bot
2123         FisoCav = top / bot
2124 c!        FisoCav = 0.0d0
2125 c!      write (*,*) "pom = ",pom
2126 c!      write (*,*) "al1 = ",al1
2127 c!      write (*,*) "al2 = ",al2
2128 c!      write (*,*) "al3 = ",al3
2129 c!      write (*,*) "al4 = ",al4
2130 c!      write (*,*) "top = ",top
2131 c!      write (*,*) "bot = ",bot
2132 c!      write (*,*) "Fisocav = ", Fisocav
2133
2134 c! Derivative of Fisocav is GCV...
2135         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
2136         dbot = 12.0d0 * al4 * pom ** 11.0d0
2137         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
2138 c!        dGCVdR = 0.0d0
2139 c!-------------------------------------------------------------------
2140 c! Polarization energy
2141 c! Epol
2142         MomoFac1 = (1.0d0 - chi1 * sqom2)
2143         MomoFac2 = (1.0d0 - chi2 * sqom1)
2144         RR1  = ( R1 * R1 ) / MomoFac1
2145         RR2  = ( R2 * R2 ) / MomoFac2
2146         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2147         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2148         fgb1 = sqrt( RR1 + a12sq * ee1 )
2149         fgb2 = sqrt( RR2 + a12sq * ee2 )
2150         epol = 332.0d0 * eps_inout_fac * (
2151      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2152 c!        epol = 0.0d0
2153 c! derivative of Epol is Gpol...
2154         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2155      &            / (fgb1 ** 5.0d0)
2156         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2157      &            / (fgb2 ** 5.0d0)
2158         dFGBdR1 = ( (R1 / MomoFac1)
2159      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2160      &          / ( 2.0d0 * fgb1 )
2161         dFGBdR2 = ( (R2 / MomoFac2)
2162      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2163      &          / ( 2.0d0 * fgb2 )
2164         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2165      &           * ( 2.0d0 - 0.5d0 * ee1) )
2166      &           / ( 2.0d0 * fgb1 )
2167         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2168      &           * ( 2.0d0 - 0.5d0 * ee2) )
2169      &           / ( 2.0d0 * fgb2 )
2170         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2171 c!        dPOLdR1 = 0.0d0
2172         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2173 c!        dPOLdR2 = 0.0d0
2174         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2175 c!        dPOLdOM1 = 0.0d0
2176         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2177 c!        dPOLdOM2 = 0.0d0
2178 c!-------------------------------------------------------------------
2179 c! Elj
2180         pom = (pis / Rhead)**6.0d0
2181         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2182 c!        Elj = 0.0d0
2183 c! derivative of Elj is Glj
2184         dGLJdR = 4.0d0 * eps_head
2185      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2186      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2187 c!        dGLJdR = 0.0d0
2188 c!-------------------------------------------------------------------
2189 c! Equad
2190        IF (Wqd.ne.0.0d0) THEN
2191         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2192      &        - 37.5d0  * ( sqom1 + sqom2 )
2193      &        + 157.5d0 * ( sqom1 * sqom2 )
2194      &        - 45.0d0  * om1*om2*om12
2195         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2196         Equad = fac * Beta1
2197 c!        Equad = 0.0d0
2198 c! derivative of Equad...
2199         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2200 c!        dQUADdR = 0.0d0
2201         dQUADdOM1 = fac
2202      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2203 c!        dQUADdOM1 = 0.0d0
2204         dQUADdOM2 = fac
2205      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2206 c!        dQUADdOM2 = 0.0d0
2207         dQUADdOM12 = fac
2208      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2209 c!        dQUADdOM12 = 0.0d0
2210         ELSE
2211          Beta1 = 0.0d0
2212          Equad = 0.0d0
2213         END IF
2214 c!-------------------------------------------------------------------
2215 c! Return the results
2216 c! Angular stuff
2217         eom1 = dPOLdOM1 + dQUADdOM1
2218         eom2 = dPOLdOM2 + dQUADdOM2
2219         eom12 = dQUADdOM12
2220 c! now some magical transformations to project gradient into
2221 c! three cartesian vectors
2222         DO k = 1, 3
2223          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2224          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2225          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2226         END DO
2227 c! Radial stuff
2228         DO k = 1, 3
2229          erhead(k) = Rhead_distance(k)/Rhead
2230          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2231          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2232         END DO
2233         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2234         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2235         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2236         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2237         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2238         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2239         facd1 = d1 * vbld_inv(i+nres)
2240         facd2 = d2 * vbld_inv(j+nres)
2241         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2242         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2243 c! Throw the results into gheadtail which holds gradients
2244 c! for each micro-state
2245         DO k = 1, 3
2246          hawk   = erhead_tail(k,1) +
2247      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2248          condor = erhead_tail(k,2) +
2249      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2250
2251          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2252 c! this acts on hydrophobic center of interaction
2253          gheadtail(k,1,1) = gheadtail(k,1,1)
2254      &                    - dGCLdR * pom
2255      &                    - dGGBdR * pom
2256      &                    - dGCVdR * pom
2257      &                    - dPOLdR1 * hawk
2258      &                    - dPOLdR2 * (erhead_tail(k,2)
2259      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2260      &                    - dGLJdR * pom
2261      &                    - dQUADdR * pom
2262      &                    - tuna(k)
2263      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2264      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2265
2266          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2267 c! this acts on hydrophobic center of interaction
2268          gheadtail(k,2,1) = gheadtail(k,2,1)
2269      &                    + dGCLdR * pom
2270      &                    + dGGBdR * pom
2271      &                    + dGCVdR * pom
2272      &                    + dPOLdR1 * (erhead_tail(k,1)
2273      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2274      &                    + dPOLdR2 * condor
2275      &                    + dGLJdR * pom
2276      &                    + dQUADdR * pom
2277      &                    + tuna(k)
2278      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2279      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2280
2281 c! this acts on Calpha
2282          gheadtail(k,3,1) = gheadtail(k,3,1)
2283      &                    - dGCLdR * erhead(k)
2284      &                    - dGGBdR * erhead(k)
2285      &                    - dGCVdR * erhead(k)
2286      &                    - dPOLdR1 * erhead_tail(k,1)
2287      &                    - dPOLdR2 * erhead_tail(k,2)
2288      &                    - dGLJdR * erhead(k)
2289      &                    - dQUADdR * erhead(k)
2290      &                    - tuna(k)
2291
2292 c! this acts on Calpha
2293          gheadtail(k,4,1) = gheadtail(k,4,1)
2294      &                    + dGCLdR * erhead(k)
2295      &                    + dGGBdR * erhead(k)
2296      &                    + dGCVdR * erhead(k)
2297      &                    + dPOLdR1 * erhead_tail(k,1)
2298      &                    + dPOLdR2 * erhead_tail(k,2)
2299      &                    + dGLJdR * erhead(k)
2300      &                    + dQUADdR * erhead(k)
2301      &                    + tuna(k)
2302         END DO
2303 c!      write(*,*) "ECL = ", Ecl
2304 c!      write(*,*) "Egb = ", Egb
2305 c!      write(*,*) "Epol = ", Epol
2306 c!      write(*,*) "Fisocav = ", Fisocav
2307 c!      write(*,*) "Elj = ", Elj
2308 c!      write(*,*) "Equad = ", Equad
2309 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2310 c!      write(*,*) "eheadtail = ", eheadtail
2311 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2312 c!      write(*,*) "dGCLdR = ", dGCLdR
2313 c!      write(*,*) "dGGBdR = ", dGGBdR
2314 c!      write(*,*) "dGCVdR = ", dGCVdR
2315 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2316 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2317 c!      write(*,*) "dGLJdR = ", dGLJdR
2318 c!      write(*,*) "dQUADdR = ", dQUADdR
2319 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2320         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2321         eheadtail = eheadtail
2322      &            + wstate(istate, itypi, itypj)
2323      &            * dexp(-betaT * ener(istate))
2324 c! foreach cartesian dimension
2325         DO k = 1, 3
2326 c! foreach of two gvdwx and gvdwc
2327          DO l = 1, 4
2328           gheadtail(k,l,2) = gheadtail(k,l,2)
2329      &                     + wstate( istate, itypi, itypj )
2330      &                     * dexp(-betaT * ener(istate))
2331      &                     * gheadtail(k,l,1)
2332           gheadtail(k,l,1) = 0.0d0
2333          END DO
2334         END DO
2335        END DO
2336 c! Here ended the gigantic DO istate = 1, 4, which starts
2337 c! at the beggining of the subroutine
2338
2339        DO k = 1, 3
2340         DO l = 1, 4
2341          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2342         END DO
2343         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2344         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2345         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2346         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2347         DO l = 1, 4
2348          gheadtail(k,l,1) = 0.0d0
2349          gheadtail(k,l,2) = 0.0d0
2350         END DO
2351        END DO
2352        eheadtail = (-dlog(eheadtail)) / betaT
2353        dPOLdOM1 = 0.0d0
2354        dPOLdOM2 = 0.0d0
2355        dQUADdOM1 = 0.0d0
2356        dQUADdOM2 = 0.0d0
2357        dQUADdOM12 = 0.0d0
2358        RETURN
2359       END SUBROUTINE energy_quad
2360 c!-------------------------------------------------------------------
2361       SUBROUTINE eqn(Epol)
2362       IMPLICIT NONE
2363       INCLUDE 'DIMENSIONS'
2364       INCLUDE 'DIMENSIONS.ZSCOPT'
2365       INCLUDE 'COMMON.CALC'
2366       INCLUDE 'COMMON.CHAIN'
2367       INCLUDE 'COMMON.CONTROL'
2368       INCLUDE 'COMMON.DERIV'
2369       INCLUDE 'COMMON.EMP'
2370       INCLUDE 'COMMON.GEO'
2371       INCLUDE 'COMMON.INTERACT'
2372       INCLUDE 'COMMON.IOUNITS'
2373       INCLUDE 'COMMON.LOCAL'
2374       INCLUDE 'COMMON.NAMES'
2375       INCLUDE 'COMMON.VAR'
2376       double precision scalar, facd4, federmaus
2377       alphapol1 = alphapol(itypi,itypj)
2378 c! R1 - distance between head of ith side chain and tail of jth sidechain
2379        R1 = 0.0d0
2380        DO k = 1, 3
2381 c! Calculate head-to-tail distances
2382         R1=R1+(ctail(k,2)-chead(k,1))**2
2383        END DO
2384 c! Pitagoras
2385        R1 = dsqrt(R1)
2386
2387 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2388 c!     &        +dhead(1,1,itypi,itypj))**2))
2389 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2390 c!     &        +dhead(2,1,itypi,itypj))**2))
2391 c--------------------------------------------------------------------
2392 c Polarization energy
2393 c Epol
2394        MomoFac1 = (1.0d0 - chi1 * sqom2)
2395        RR1  = R1 * R1 / MomoFac1
2396        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2397        fgb1 = sqrt( RR1 + a12sq * ee1)
2398        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2399 c!       epol = 0.0d0
2400 c!------------------------------------------------------------------
2401 c! derivative of Epol is Gpol...
2402        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2403      &          / (fgb1 ** 5.0d0)
2404        dFGBdR1 = ( (R1 / MomoFac1)
2405      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2406      &        / ( 2.0d0 * fgb1 )
2407        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2408      &          * (2.0d0 - 0.5d0 * ee1) )
2409      &          / (2.0d0 * fgb1)
2410        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2411 c!       dPOLdR1 = 0.0d0
2412        dPOLdOM1 = 0.0d0
2413        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2414 c!       dPOLdOM2 = 0.0d0
2415 c!-------------------------------------------------------------------
2416 c! Return the results
2417 c! (see comments in Eqq)
2418        DO k = 1, 3
2419         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2420        END DO
2421        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2422        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2423        facd1 = d1 * vbld_inv(i+nres)
2424        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2425
2426        DO k = 1, 3
2427         hawk = (erhead_tail(k,1) +
2428      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2429
2430         gvdwx(k,i) = gvdwx(k,i)
2431      &             - dPOLdR1 * hawk
2432         gvdwx(k,j) = gvdwx(k,j)
2433      &             + dPOLdR1 * (erhead_tail(k,1)
2434      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2435
2436         gvdwc(k,i) = gvdwc(k,i)
2437      &             - dPOLdR1 * erhead_tail(k,1)
2438         gvdwc(k,j) = gvdwc(k,j)
2439      &             + dPOLdR1 * erhead_tail(k,1)
2440
2441        END DO
2442        RETURN
2443       END SUBROUTINE eqn
2444
2445
2446 c!-------------------------------------------------------------------
2447
2448
2449
2450       SUBROUTINE enq(Epol)
2451        IMPLICIT NONE
2452        INCLUDE 'DIMENSIONS'
2453        INCLUDE 'DIMENSIONS.ZSCOPT'
2454        INCLUDE 'COMMON.CALC'
2455        INCLUDE 'COMMON.CHAIN'
2456        INCLUDE 'COMMON.CONTROL'
2457        INCLUDE 'COMMON.DERIV'
2458        INCLUDE 'COMMON.EMP'
2459        INCLUDE 'COMMON.GEO'
2460        INCLUDE 'COMMON.INTERACT'
2461        INCLUDE 'COMMON.IOUNITS'
2462        INCLUDE 'COMMON.LOCAL'
2463        INCLUDE 'COMMON.NAMES'
2464        INCLUDE 'COMMON.VAR'
2465        double precision scalar, facd3, adler
2466        alphapol2 = alphapol(itypj,itypi)
2467 c! R2 - distance between head of jth side chain and tail of ith sidechain
2468        R2 = 0.0d0
2469        DO k = 1, 3
2470 c! Calculate head-to-tail distances
2471         R2=R2+(chead(k,2)-ctail(k,1))**2
2472        END DO
2473 c! Pitagoras
2474        R2 = dsqrt(R2)
2475
2476 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2477 c!     &        +dhead(1,1,itypi,itypj))**2))
2478 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2479 c!     &        +dhead(2,1,itypi,itypj))**2))
2480 c------------------------------------------------------------------------
2481 c Polarization energy
2482        MomoFac2 = (1.0d0 - chi2 * sqom1)
2483        RR2  = R2 * R2 / MomoFac2
2484        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2485        fgb2 = sqrt(RR2  + a12sq * ee2)
2486        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2487 c!       epol = 0.0d0
2488 c!-------------------------------------------------------------------
2489 c! derivative of Epol is Gpol...
2490        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2491      &          / (fgb2 ** 5.0d0)
2492        dFGBdR2 = ( (R2 / MomoFac2)
2493      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2494      &        / (2.0d0 * fgb2)
2495        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2496      &          * (2.0d0 - 0.5d0 * ee2) )
2497      &          / (2.0d0 * fgb2)
2498        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2499 c!       dPOLdR2 = 0.0d0
2500        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2501 c!       dPOLdOM1 = 0.0d0
2502        dPOLdOM2 = 0.0d0
2503 c!-------------------------------------------------------------------
2504 c! Return the results
2505 c! (See comments in Eqq)
2506        DO k = 1, 3
2507         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2508        END DO
2509        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2510        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2511        facd2 = d2 * vbld_inv(j+nres)
2512        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2513        DO k = 1, 3
2514         condor = (erhead_tail(k,2)
2515      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2516
2517         gvdwx(k,i) = gvdwx(k,i)
2518      &             - dPOLdR2 * (erhead_tail(k,2)
2519      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2520         gvdwx(k,j) = gvdwx(k,j)
2521      &             + dPOLdR2 * condor
2522
2523         gvdwc(k,i) = gvdwc(k,i)
2524      &             - dPOLdR2 * erhead_tail(k,2)
2525         gvdwc(k,j) = gvdwc(k,j)
2526      &             + dPOLdR2 * erhead_tail(k,2)
2527
2528        END DO
2529       RETURN
2530       END SUBROUTINE enq
2531
2532
2533 c!-------------------------------------------------------------------
2534
2535
2536       SUBROUTINE eqd(Ecl,Elj,Epol)
2537        IMPLICIT NONE
2538        INCLUDE 'DIMENSIONS'
2539        INCLUDE 'DIMENSIONS.ZSCOPT'
2540        INCLUDE 'COMMON.CALC'
2541        INCLUDE 'COMMON.CHAIN'
2542        INCLUDE 'COMMON.CONTROL'
2543        INCLUDE 'COMMON.DERIV'
2544        INCLUDE 'COMMON.EMP'
2545        INCLUDE 'COMMON.GEO'
2546        INCLUDE 'COMMON.INTERACT'
2547        INCLUDE 'COMMON.IOUNITS'
2548        INCLUDE 'COMMON.LOCAL'
2549        INCLUDE 'COMMON.NAMES'
2550        INCLUDE 'COMMON.VAR'
2551        double precision scalar, facd4, federmaus
2552        alphapol1 = alphapol(itypi,itypj)
2553        w1        = wqdip(1,itypi,itypj)
2554        w2        = wqdip(2,itypi,itypj)
2555        pis       = sig0head(itypi,itypj)
2556        eps_head   = epshead(itypi,itypj)
2557 c!-------------------------------------------------------------------
2558 c! R1 - distance between head of ith side chain and tail of jth sidechain
2559        R1 = 0.0d0
2560        DO k = 1, 3
2561 c! Calculate head-to-tail distances
2562         R1=R1+(ctail(k,2)-chead(k,1))**2
2563        END DO
2564 c! Pitagoras
2565        R1 = dsqrt(R1)
2566
2567 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2568 c!     &        +dhead(1,1,itypi,itypj))**2))
2569 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2570 c!     &        +dhead(2,1,itypi,itypj))**2))
2571
2572 c!-------------------------------------------------------------------
2573 c! ecl
2574        sparrow  = w1 * Qi * om1
2575        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2576        Ecl = sparrow / Rhead**2.0d0
2577      &     - hawk    / Rhead**4.0d0
2578 c!-------------------------------------------------------------------
2579 c! derivative of ecl is Gcl
2580 c! dF/dr part
2581        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2582      &           + 4.0d0 * hawk    / Rhead**5.0d0
2583 c! dF/dom1
2584        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2585 c! dF/dom2
2586        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2587 c--------------------------------------------------------------------
2588 c Polarization energy
2589 c Epol
2590        MomoFac1 = (1.0d0 - chi1 * sqom2)
2591        RR1  = R1 * R1 / MomoFac1
2592        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2593        fgb1 = sqrt( RR1 + a12sq * ee1)
2594        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2595 c!       epol = 0.0d0
2596 c!------------------------------------------------------------------
2597 c! derivative of Epol is Gpol...
2598        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2599      &          / (fgb1 ** 5.0d0)
2600        dFGBdR1 = ( (R1 / MomoFac1)
2601      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2602      &        / ( 2.0d0 * fgb1 )
2603        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2604      &          * (2.0d0 - 0.5d0 * ee1) )
2605      &          / (2.0d0 * fgb1)
2606        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2607 c!       dPOLdR1 = 0.0d0
2608        dPOLdOM1 = 0.0d0
2609        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2610 c!       dPOLdOM2 = 0.0d0
2611 c!-------------------------------------------------------------------
2612 c! Elj
2613        pom = (pis / Rhead)**6.0d0
2614        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2615 c! derivative of Elj is Glj
2616        dGLJdR = 4.0d0 * eps_head
2617      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2618      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2619 c!-------------------------------------------------------------------
2620 c! Return the results
2621        DO k = 1, 3
2622         erhead(k) = Rhead_distance(k)/Rhead
2623         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2624        END DO
2625
2626        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2627        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2628        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2629        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2630        facd1 = d1 * vbld_inv(i+nres)
2631        facd2 = d2 * vbld_inv(j+nres)
2632        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2633
2634        DO k = 1, 3
2635         hawk = (erhead_tail(k,1) +
2636      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2637
2638         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2639         gvdwx(k,i) = gvdwx(k,i)
2640      &             - dGCLdR * pom
2641      &             - dPOLdR1 * hawk
2642      &             - dGLJdR * pom
2643
2644         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2645         gvdwx(k,j) = gvdwx(k,j)
2646      &             + dGCLdR * pom
2647      &             + dPOLdR1 * (erhead_tail(k,1)
2648      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2649      &             + dGLJdR * pom
2650
2651
2652         gvdwc(k,i) = gvdwc(k,i)
2653      &             - dGCLdR * erhead(k)
2654      &             - dPOLdR1 * erhead_tail(k,1)
2655      &             - dGLJdR * erhead(k)
2656
2657         gvdwc(k,j) = gvdwc(k,j)
2658      &             + dGCLdR * erhead(k)
2659      &             + dPOLdR1 * erhead_tail(k,1)
2660      &             + dGLJdR * erhead(k)
2661
2662        END DO
2663        RETURN
2664       END SUBROUTINE eqd
2665
2666
2667 c!-------------------------------------------------------------------
2668
2669
2670       SUBROUTINE edq(Ecl,Elj,Epol)
2671        IMPLICIT NONE
2672        INCLUDE 'DIMENSIONS'
2673        INCLUDE 'DIMENSIONS.ZSCOPT'
2674        INCLUDE 'COMMON.CALC'
2675        INCLUDE 'COMMON.CHAIN'
2676        INCLUDE 'COMMON.CONTROL'
2677        INCLUDE 'COMMON.DERIV'
2678        INCLUDE 'COMMON.EMP'
2679        INCLUDE 'COMMON.GEO'
2680        INCLUDE 'COMMON.INTERACT'
2681        INCLUDE 'COMMON.IOUNITS'
2682        INCLUDE 'COMMON.LOCAL'
2683        INCLUDE 'COMMON.NAMES'
2684        INCLUDE 'COMMON.VAR'
2685        double precision scalar, facd3, adler
2686        alphapol2 = alphapol(itypj,itypi)
2687        w1        = wqdip(1,itypi,itypj)
2688        w2        = wqdip(2,itypi,itypj)
2689        pis       = sig0head(itypi,itypj)
2690        eps_head  = epshead(itypi,itypj)
2691 c!-------------------------------------------------------------------
2692 c! R2 - distance between head of jth side chain and tail of ith sidechain
2693        R2 = 0.0d0
2694        DO k = 1, 3
2695 c! Calculate head-to-tail distances
2696         R2=R2+(chead(k,2)-ctail(k,1))**2
2697        END DO
2698 c! Pitagoras
2699        R2 = dsqrt(R2)
2700
2701 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2702 c!     &        +dhead(1,1,itypi,itypj))**2))
2703 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2704 c!     &        +dhead(2,1,itypi,itypj))**2))
2705
2706
2707 c!-------------------------------------------------------------------
2708 c! ecl
2709        sparrow  = w1 * Qi * om1
2710        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2711        ECL = sparrow / Rhead**2.0d0
2712      &     - hawk    / Rhead**4.0d0
2713 c!-------------------------------------------------------------------
2714 c! derivative of ecl is Gcl
2715 c! dF/dr part
2716        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2717      &           + 4.0d0 * hawk    / Rhead**5.0d0
2718 c! dF/dom1
2719        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2720 c! dF/dom2
2721        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2722 c--------------------------------------------------------------------
2723 c Polarization energy
2724 c Epol
2725        MomoFac2 = (1.0d0 - chi2 * sqom1)
2726        RR2  = R2 * R2 / MomoFac2
2727        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2728        fgb2 = sqrt(RR2  + a12sq * ee2)
2729        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2730 c!       epol = 0.0d0
2731 c! derivative of Epol is Gpol...
2732        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2733      &          / (fgb2 ** 5.0d0)
2734        dFGBdR2 = ( (R2 / MomoFac2)
2735      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2736      &        / (2.0d0 * fgb2)
2737        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2738      &          * (2.0d0 - 0.5d0 * ee2) )
2739      &          / (2.0d0 * fgb2)
2740        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2741 c!       dPOLdR2 = 0.0d0
2742        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2743 c!       dPOLdOM1 = 0.0d0
2744        dPOLdOM2 = 0.0d0
2745 c!-------------------------------------------------------------------
2746 c! Elj
2747        pom = (pis / Rhead)**6.0d0
2748        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2749 c! derivative of Elj is Glj
2750        dGLJdR = 4.0d0 * eps_head
2751      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2752      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2753 c!-------------------------------------------------------------------
2754 c! Return the results
2755 c! (see comments in Eqq)
2756        DO k = 1, 3
2757         erhead(k) = Rhead_distance(k)/Rhead
2758         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2759        END DO
2760        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2761        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2762        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2763        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2764        facd1 = d1 * vbld_inv(i+nres)
2765        facd2 = d2 * vbld_inv(j+nres)
2766        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2767
2768        DO k = 1, 3
2769         condor = (erhead_tail(k,2)
2770      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2771
2772         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2773         gvdwx(k,i) = gvdwx(k,i)
2774      &             - dGCLdR * pom
2775      &             - dPOLdR2 * (erhead_tail(k,2)
2776      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2777      &             - dGLJdR * pom
2778
2779         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2780         gvdwx(k,j) = gvdwx(k,j)
2781      &             + dGCLdR * pom
2782      &             + dPOLdR2 * condor
2783      &             + dGLJdR * pom
2784
2785
2786         gvdwc(k,i) = gvdwc(k,i)
2787      &             - dGCLdR * erhead(k)
2788      &             - dPOLdR2 * erhead_tail(k,2)
2789      &             - dGLJdR * erhead(k)
2790
2791         gvdwc(k,j) = gvdwc(k,j)
2792      &             + dGCLdR * erhead(k)
2793      &             + dPOLdR2 * erhead_tail(k,2)
2794      &             + dGLJdR * erhead(k)
2795
2796        END DO
2797        RETURN
2798       END SUBROUTINE edq
2799
2800
2801 C--------------------------------------------------------------------
2802
2803
2804       SUBROUTINE edd(ECL)
2805        IMPLICIT NONE
2806        INCLUDE 'DIMENSIONS'
2807        INCLUDE 'DIMENSIONS.ZSCOPT'
2808        INCLUDE 'COMMON.CALC'
2809        INCLUDE 'COMMON.CHAIN'
2810        INCLUDE 'COMMON.CONTROL'
2811        INCLUDE 'COMMON.DERIV'
2812        INCLUDE 'COMMON.EMP'
2813        INCLUDE 'COMMON.GEO'
2814        INCLUDE 'COMMON.INTERACT'
2815        INCLUDE 'COMMON.IOUNITS'
2816        INCLUDE 'COMMON.LOCAL'
2817        INCLUDE 'COMMON.NAMES'
2818        INCLUDE 'COMMON.VAR'
2819        double precision scalar
2820 c!       csig = sigiso(itypi,itypj)
2821        w1 = wqdip(1,itypi,itypj)
2822        w2 = wqdip(2,itypi,itypj)
2823 c!-------------------------------------------------------------------
2824 c! ECL
2825        fac = (om12 - 3.0d0 * om1 * om2)
2826        c1 = (w1 / (Rhead**3.0d0)) * fac
2827        c2 = (w2 / Rhead ** 6.0d0)
2828      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2829        ECL = c1 - c2
2830 c!       write (*,*) "w1 = ", w1
2831 c!       write (*,*) "w2 = ", w2
2832 c!       write (*,*) "om1 = ", om1
2833 c!       write (*,*) "om2 = ", om2
2834 c!       write (*,*) "om12 = ", om12
2835 c!       write (*,*) "fac = ", fac
2836 c!       write (*,*) "c1 = ", c1
2837 c!       write (*,*) "c2 = ", c2
2838 c!       write (*,*) "Ecl = ", Ecl
2839 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2840 c!       write (*,*) "c2_2 = ",
2841 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2842 c!-------------------------------------------------------------------
2843 c! dervative of ECL is GCL...
2844 c! dECL/dr
2845        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2846        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2847      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2848        dGCLdR = c1 - c2
2849 c! dECL/dom1
2850        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2851        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2852      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2853        dGCLdOM1 = c1 - c2
2854 c! dECL/dom2
2855        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2856        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2857      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2858        dGCLdOM2 = c1 - c2
2859 c! dECL/dom12
2860        c1 = w1 / (Rhead ** 3.0d0)
2861        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2862        dGCLdOM12 = c1 - c2
2863 c!-------------------------------------------------------------------
2864 c! Return the results
2865 c! (see comments in Eqq)
2866        DO k= 1, 3
2867         erhead(k) = Rhead_distance(k)/Rhead
2868        END DO
2869        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2870        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2871        facd1 = d1 * vbld_inv(i+nres)
2872        facd2 = d2 * vbld_inv(j+nres)
2873        DO k = 1, 3
2874
2875         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2876         gvdwx(k,i) = gvdwx(k,i)
2877      &             - dGCLdR * pom
2878         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2879         gvdwx(k,j) = gvdwx(k,j)
2880      &             + dGCLdR * pom
2881
2882         gvdwc(k,i) = gvdwc(k,i)
2883      &             - dGCLdR * erhead(k)
2884         gvdwc(k,j) = gvdwc(k,j)
2885      &             + dGCLdR * erhead(k)
2886        END DO
2887        RETURN
2888       END SUBROUTINE edd
2889
2890
2891 c!-------------------------------------------------------------------
2892
2893
2894       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2895        IMPLICIT NONE
2896 c! maxres
2897        INCLUDE 'DIMENSIONS'
2898        INCLUDE 'DIMENSIONS.ZSCOPT'
2899 c! itypi, itypj, i, j, k, l, chead,
2900        INCLUDE 'COMMON.CALC'
2901 c! c, nres, dc_norm
2902        INCLUDE 'COMMON.CHAIN'
2903 c! gradc, gradx
2904        INCLUDE 'COMMON.DERIV'
2905 c! electrostatic gradients-specific variables
2906        INCLUDE 'COMMON.EMP'
2907 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2908        INCLUDE 'COMMON.INTERACT'
2909 c! t_bath, Rb
2910 c       INCLUDE 'COMMON.MD'
2911 c! io for debug, disable it in final builds
2912        INCLUDE 'COMMON.IOUNITS'
2913        double precision Rb /1.987D-3/
2914 c!-------------------------------------------------------------------
2915 c! Variable Init
2916
2917 c! what amino acid is the aminoacid j'th?
2918        itypj = itype(j)
2919 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2920 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2921 c!       t_bath = 300
2922 c!       BetaT = 1.0d0 / (t_bath * Rb)
2923        BetaT = 1.0d0 / (298.0d0 * Rb)
2924 c! Gay-berne var's
2925        sig0ij = sigma( itypi,itypj )
2926        chi1   = chi( itypi, itypj )
2927        chi2   = chi( itypj, itypi )
2928        chi12  = chi1 * chi2
2929        chip1  = chipp( itypi, itypj )
2930        chip2  = chipp( itypj, itypi )
2931        chip12 = chip1 * chip2
2932 c! not used by momo potential, but needed by sc_angular which is shared
2933 c! by all energy_potential subroutines
2934        alf1   = 0.0d0
2935        alf2   = 0.0d0
2936        alf12  = 0.0d0
2937 c! location, location, location
2938        xj  = c( 1, nres+j ) - xi
2939        yj  = c( 2, nres+j ) - yi
2940        zj  = c( 3, nres+j ) - zi
2941        dxj = dc_norm( 1, nres+j )
2942        dyj = dc_norm( 2, nres+j )
2943        dzj = dc_norm( 3, nres+j )
2944 c! distance from center of chain(?) to polar/charged head
2945 c!       write (*,*) "istate = ", 1
2946 c!       write (*,*) "ii = ", 1
2947 c!       write (*,*) "jj = ", 1
2948        d1 = dhead(1, 1, itypi, itypj)
2949        d2 = dhead(2, 1, itypi, itypj)
2950 c! ai*aj from Fgb
2951        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2952 c!       a12sq = a12sq * a12sq
2953 c! charge of amino acid itypi is...
2954        Qi  = icharge(itypi)
2955        Qj  = icharge(itypj)
2956        Qij = Qi * Qj
2957 c! chis1,2,12
2958        chis1 = chis(itypi,itypj)
2959        chis2 = chis(itypj,itypi)
2960        chis12 = chis1 * chis2
2961        sig1 = sigmap1(itypi,itypj)
2962        sig2 = sigmap2(itypi,itypj)
2963 c!       write (*,*) "sig1 = ", sig1
2964 c!       write (*,*) "sig2 = ", sig2
2965 c! alpha factors from Fcav/Gcav
2966        b1 = alphasur(1,itypi,itypj)
2967        b2 = alphasur(2,itypi,itypj)
2968        b3 = alphasur(3,itypi,itypj)
2969        b4 = alphasur(4,itypi,itypj)
2970 c! used to determine whether we want to do quadrupole calculations
2971        wqd = wquad(itypi, itypj)
2972 c! used by Fgb
2973        eps_in = epsintab(itypi,itypj)
2974        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2975 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2976 c!-------------------------------------------------------------------
2977 c! tail location and distance calculations
2978        Rtail = 0.0d0
2979        DO k = 1, 3
2980         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2981         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2982        END DO
2983 c! tail distances will be themselves usefull elswhere
2984 c1 (in Gcav, for example)
2985        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2986        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2987        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2988        Rtail = dsqrt(
2989      &     (Rtail_distance(1)*Rtail_distance(1))
2990      &   + (Rtail_distance(2)*Rtail_distance(2))
2991      &   + (Rtail_distance(3)*Rtail_distance(3)))
2992 c!-------------------------------------------------------------------
2993 c! Calculate location and distance between polar heads
2994 c! distance between heads
2995 c! for each one of our three dimensional space...
2996        DO k = 1,3
2997 c! location of polar head is computed by taking hydrophobic centre
2998 c! and moving by a d1 * dc_norm vector
2999 c! see unres publications for very informative images
3000         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
3001         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
3002 c! distance
3003 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
3004 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
3005         Rhead_distance(k) = chead(k,2) - chead(k,1)
3006        END DO
3007 c! pitagoras (root of sum of squares)
3008        Rhead = dsqrt(
3009      &     (Rhead_distance(1)*Rhead_distance(1))
3010      &   + (Rhead_distance(2)*Rhead_distance(2))
3011      &   + (Rhead_distance(3)*Rhead_distance(3)))
3012 c!-------------------------------------------------------------------
3013 c! zero everything that should be zero'ed
3014        Egb = 0.0d0
3015        ECL = 0.0d0
3016        Elj = 0.0d0
3017        Equad = 0.0d0
3018        Epol = 0.0d0
3019        eheadtail = 0.0d0
3020        dGCLdOM1 = 0.0d0
3021        dGCLdOM2 = 0.0d0
3022        dGCLdOM12 = 0.0d0
3023        dPOLdOM1 = 0.0d0
3024        dPOLdOM2 = 0.0d0
3025        RETURN
3026       END SUBROUTINE elgrad_init
3027
3028
3029 C-----------------------------------------------------------------------------
3030       subroutine sc_angular
3031 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
3032 C om12. Called by ebp, egb, and egbv.
3033       implicit none
3034       include 'COMMON.CALC'
3035       erij(1)=xj*rij
3036       erij(2)=yj*rij
3037       erij(3)=zj*rij
3038       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3039       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3040       om12=dxi*dxj+dyi*dyj+dzi*dzj
3041       chiom12=chi12*om12
3042 C Calculate eps1(om12) and its derivative in om12
3043       faceps1=1.0D0-om12*chiom12
3044       faceps1_inv=1.0D0/faceps1
3045       eps1=dsqrt(faceps1_inv)
3046 C Following variable is eps1*deps1/dom12
3047       eps1_om12=faceps1_inv*chiom12
3048 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
3049 C and om12.
3050       om1om2=om1*om2
3051       chiom1=chi1*om1
3052       chiom2=chi2*om2
3053       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
3054       sigsq=1.0D0-facsig*faceps1_inv
3055       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
3056       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
3057       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
3058 C Calculate eps2 and its derivatives in om1, om2, and om12.
3059       chipom1=chip1*om1
3060       chipom2=chip2*om2
3061       chipom12=chip12*om12
3062       facp=1.0D0-om12*chipom12
3063       facp_inv=1.0D0/facp
3064       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
3065 C Following variable is the square root of eps2
3066       eps2rt=1.0D0-facp1*facp_inv
3067 C Following three variables are the derivatives of the square root of eps
3068 C in om1, om2, and om12.
3069       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
3070       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
3071       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
3072 C Evaluate the "asymmetric" factor in the VDW constant, eps3
3073       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
3074 C Calculate whole angle-dependent part of epsilon and contributions
3075 C to its derivatives
3076       return
3077       end
3078 C----------------------------------------------------------------------------
3079       subroutine sc_grad
3080       implicit real*8 (a-h,o-z)
3081       include 'DIMENSIONS'
3082       include 'DIMENSIONS.ZSCOPT'
3083       include 'COMMON.CHAIN'
3084       include 'COMMON.DERIV'
3085       include 'COMMON.CALC'
3086       double precision dcosom1(3),dcosom2(3)
3087       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
3088       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
3089       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
3090      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
3091       do k=1,3
3092         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3093         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3094       enddo
3095       do k=1,3
3096         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3097       enddo
3098       do k=1,3
3099         gvdwx(k,i)=gvdwx(k,i)-gg(k)
3100      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
3101      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
3102         gvdwx(k,j)=gvdwx(k,j)+gg(k)
3103      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
3104      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
3105       enddo
3106 C
3107 C Calculate the components of the gradient in DC and X
3108 C
3109       do k=i,j-1
3110         do l=1,3
3111           gvdwc(l,k)=gvdwc(l,k)+gg(l)
3112         enddo
3113       enddo
3114       return
3115       end
3116 c------------------------------------------------------------------------------
3117       subroutine vec_and_deriv
3118       implicit real*8 (a-h,o-z)
3119       include 'DIMENSIONS'
3120       include 'DIMENSIONS.ZSCOPT'
3121       include 'COMMON.IOUNITS'
3122       include 'COMMON.GEO'
3123       include 'COMMON.VAR'
3124       include 'COMMON.LOCAL'
3125       include 'COMMON.CHAIN'
3126       include 'COMMON.VECTORS'
3127       include 'COMMON.DERIV'
3128       include 'COMMON.INTERACT'
3129       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
3130 C Compute the local reference systems. For reference system (i), the
3131 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3132 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3133       do i=1,nres-1
3134 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
3135           if (i.eq.nres-1) then
3136 C Case of the last full residue
3137 C Compute the Z-axis
3138             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3139             costh=dcos(pi-theta(nres))
3140             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3141             do k=1,3
3142               uz(k,i)=fac*uz(k,i)
3143             enddo
3144             if (calc_grad) then
3145 C Compute the derivatives of uz
3146             uzder(1,1,1)= 0.0d0
3147             uzder(2,1,1)=-dc_norm(3,i-1)
3148             uzder(3,1,1)= dc_norm(2,i-1)
3149             uzder(1,2,1)= dc_norm(3,i-1)
3150             uzder(2,2,1)= 0.0d0
3151             uzder(3,2,1)=-dc_norm(1,i-1)
3152             uzder(1,3,1)=-dc_norm(2,i-1)
3153             uzder(2,3,1)= dc_norm(1,i-1)
3154             uzder(3,3,1)= 0.0d0
3155             uzder(1,1,2)= 0.0d0
3156             uzder(2,1,2)= dc_norm(3,i)
3157             uzder(3,1,2)=-dc_norm(2,i)
3158             uzder(1,2,2)=-dc_norm(3,i)
3159             uzder(2,2,2)= 0.0d0
3160             uzder(3,2,2)= dc_norm(1,i)
3161             uzder(1,3,2)= dc_norm(2,i)
3162             uzder(2,3,2)=-dc_norm(1,i)
3163             uzder(3,3,2)= 0.0d0
3164             endif
3165 C Compute the Y-axis
3166             facy=fac
3167             do k=1,3
3168               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3169             enddo
3170             if (calc_grad) then
3171 C Compute the derivatives of uy
3172             do j=1,3
3173               do k=1,3
3174                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3175      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3176                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3177               enddo
3178               uyder(j,j,1)=uyder(j,j,1)-costh
3179               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3180             enddo
3181             do j=1,2
3182               do k=1,3
3183                 do l=1,3
3184                   uygrad(l,k,j,i)=uyder(l,k,j)
3185                   uzgrad(l,k,j,i)=uzder(l,k,j)
3186                 enddo
3187               enddo
3188             enddo
3189             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3190             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3191             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3192             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3193             endif
3194           else
3195 C Other residues
3196 C Compute the Z-axis
3197             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3198             costh=dcos(pi-theta(i+2))
3199             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3200             do k=1,3
3201               uz(k,i)=fac*uz(k,i)
3202             enddo
3203             if (calc_grad) then
3204 C Compute the derivatives of uz
3205             uzder(1,1,1)= 0.0d0
3206             uzder(2,1,1)=-dc_norm(3,i+1)
3207             uzder(3,1,1)= dc_norm(2,i+1)
3208             uzder(1,2,1)= dc_norm(3,i+1)
3209             uzder(2,2,1)= 0.0d0
3210             uzder(3,2,1)=-dc_norm(1,i+1)
3211             uzder(1,3,1)=-dc_norm(2,i+1)
3212             uzder(2,3,1)= dc_norm(1,i+1)
3213             uzder(3,3,1)= 0.0d0
3214             uzder(1,1,2)= 0.0d0
3215             uzder(2,1,2)= dc_norm(3,i)
3216             uzder(3,1,2)=-dc_norm(2,i)
3217             uzder(1,2,2)=-dc_norm(3,i)
3218             uzder(2,2,2)= 0.0d0
3219             uzder(3,2,2)= dc_norm(1,i)
3220             uzder(1,3,2)= dc_norm(2,i)
3221             uzder(2,3,2)=-dc_norm(1,i)
3222             uzder(3,3,2)= 0.0d0
3223             endif
3224 C Compute the Y-axis
3225             facy=fac
3226             do k=1,3
3227               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3228             enddo
3229             if (calc_grad) then
3230 C Compute the derivatives of uy
3231             do j=1,3
3232               do k=1,3
3233                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3234      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3235                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3236               enddo
3237               uyder(j,j,1)=uyder(j,j,1)-costh
3238               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3239             enddo
3240             do j=1,2
3241               do k=1,3
3242                 do l=1,3
3243                   uygrad(l,k,j,i)=uyder(l,k,j)
3244                   uzgrad(l,k,j,i)=uzder(l,k,j)
3245                 enddo
3246               enddo
3247             enddo
3248             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3249             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3250             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3251             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3252           endif
3253           endif
3254       enddo
3255       if (calc_grad) then
3256       do i=1,nres-1
3257         vbld_inv_temp(1)=vbld_inv(i+1)
3258         if (i.lt.nres-1) then
3259           vbld_inv_temp(2)=vbld_inv(i+2)
3260         else
3261           vbld_inv_temp(2)=vbld_inv(i)
3262         endif
3263         do j=1,2
3264           do k=1,3
3265             do l=1,3
3266               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3267               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3268             enddo
3269           enddo
3270         enddo
3271       enddo
3272       endif
3273       return
3274       end
3275 c------------------------------------------------------------------------------
3276       subroutine set_matrices
3277       implicit real*8 (a-h,o-z)
3278       include 'DIMENSIONS'
3279 #ifdef MPI
3280       include "mpif.h"
3281       integer IERR
3282       integer status(MPI_STATUS_SIZE)
3283 #endif
3284       include 'DIMENSIONS.ZSCOPT'
3285       include 'COMMON.IOUNITS'
3286       include 'COMMON.GEO'
3287       include 'COMMON.VAR'
3288       include 'COMMON.LOCAL'
3289       include 'COMMON.CHAIN'
3290       include 'COMMON.DERIV'
3291       include 'COMMON.INTERACT'
3292       include 'COMMON.CONTACTS'
3293       include 'COMMON.TORSION'
3294       include 'COMMON.VECTORS'
3295       include 'COMMON.FFIELD'
3296       double precision auxvec(2),auxmat(2,2)
3297 C
3298 C Compute the virtual-bond-torsional-angle dependent quantities needed
3299 C to calculate the el-loc multibody terms of various order.
3300 C
3301 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3302       do i=3,nres+1
3303         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3304           iti = itype2loc(itype(i-2))
3305         else
3306           iti=nloctyp
3307         endif
3308 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3309         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3310           iti1 = itype2loc(itype(i-1))
3311         else
3312           iti1=nloctyp
3313         endif
3314 #ifdef NEWCORR
3315         cost1=dcos(theta(i-1))
3316         sint1=dsin(theta(i-1))
3317         sint1sq=sint1*sint1
3318         sint1cub=sint1sq*sint1
3319         sint1cost1=2*sint1*cost1
3320 #ifdef DEBUG
3321         write (iout,*) "bnew1",i,iti
3322         write (iout,*) (bnew1(k,1,iti),k=1,3)
3323         write (iout,*) (bnew1(k,2,iti),k=1,3)
3324         write (iout,*) "bnew2",i,iti
3325         write (iout,*) (bnew2(k,1,iti),k=1,3)
3326         write (iout,*) (bnew2(k,2,iti),k=1,3)
3327 #endif
3328         do k=1,2
3329           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3330           b1(k,i-2)=sint1*b1k
3331           gtb1(k,i-2)=cost1*b1k-sint1sq*
3332      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3333           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3334           b2(k,i-2)=sint1*b2k
3335           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3336      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3337         enddo
3338         do k=1,2
3339           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3340           cc(1,k,i-2)=sint1sq*aux
3341           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3342      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3343           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3344           dd(1,k,i-2)=sint1sq*aux
3345           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3346      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3347         enddo
3348         cc(2,1,i-2)=cc(1,2,i-2)
3349         cc(2,2,i-2)=-cc(1,1,i-2)
3350         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3351         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3352         dd(2,1,i-2)=dd(1,2,i-2)
3353         dd(2,2,i-2)=-dd(1,1,i-2)
3354         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3355         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3356         do k=1,2
3357           do l=1,2
3358             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3359             EE(l,k,i-2)=sint1sq*aux
3360             if (calc_grad)
3361      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3362           enddo
3363         enddo
3364         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3365         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3366         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3367         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3368         if (calc_grad) then
3369         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3370         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3371         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3372         endif
3373 c        b1tilde(1,i-2)=b1(1,i-2)
3374 c        b1tilde(2,i-2)=-b1(2,i-2)
3375 c        b2tilde(1,i-2)=b2(1,i-2)
3376 c        b2tilde(2,i-2)=-b2(2,i-2)
3377 #ifdef DEBUG
3378         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3379         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3380         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3381         write (iout,*) 'theta=', theta(i-1)
3382 #endif
3383 #else
3384         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3385           iti = itype2loc(itype(i-2))
3386         else
3387           iti=nloctyp
3388         endif
3389 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3390         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3391           iti1 = itype2loc(itype(i-1))
3392         else
3393           iti1=nloctyp
3394         endif
3395         b1(1,i-2)=b(3,iti)
3396         b1(2,i-2)=b(5,iti)
3397         b2(1,i-2)=b(2,iti)
3398         b2(2,i-2)=b(4,iti)
3399         do k=1,2
3400           do l=1,2
3401            CC(k,l,i-2)=ccold(k,l,iti)
3402            DD(k,l,i-2)=ddold(k,l,iti)
3403            EE(k,l,i-2)=eeold(k,l,iti)
3404           enddo
3405         enddo
3406 #endif
3407         b1tilde(1,i-2)= b1(1,i-2)
3408         b1tilde(2,i-2)=-b1(2,i-2)
3409         b2tilde(1,i-2)= b2(1,i-2)
3410         b2tilde(2,i-2)=-b2(2,i-2)
3411 c
3412         Ctilde(1,1,i-2)= CC(1,1,i-2)
3413         Ctilde(1,2,i-2)= CC(1,2,i-2)
3414         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3415         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3416 c
3417         Dtilde(1,1,i-2)= DD(1,1,i-2)
3418         Dtilde(1,2,i-2)= DD(1,2,i-2)
3419         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3420         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3421 c        write(iout,*) "i",i," iti",iti
3422 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3423 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3424       enddo
3425       do i=3,nres+1
3426         if (i .lt. nres+1) then
3427           sin1=dsin(phi(i))
3428           cos1=dcos(phi(i))
3429           sintab(i-2)=sin1
3430           costab(i-2)=cos1
3431           obrot(1,i-2)=cos1
3432           obrot(2,i-2)=sin1
3433           sin2=dsin(2*phi(i))
3434           cos2=dcos(2*phi(i))
3435           sintab2(i-2)=sin2
3436           costab2(i-2)=cos2
3437           obrot2(1,i-2)=cos2
3438           obrot2(2,i-2)=sin2
3439           Ug(1,1,i-2)=-cos1
3440           Ug(1,2,i-2)=-sin1
3441           Ug(2,1,i-2)=-sin1
3442           Ug(2,2,i-2)= cos1
3443           Ug2(1,1,i-2)=-cos2
3444           Ug2(1,2,i-2)=-sin2
3445           Ug2(2,1,i-2)=-sin2
3446           Ug2(2,2,i-2)= cos2
3447         else
3448           costab(i-2)=1.0d0
3449           sintab(i-2)=0.0d0
3450           obrot(1,i-2)=1.0d0
3451           obrot(2,i-2)=0.0d0
3452           obrot2(1,i-2)=0.0d0
3453           obrot2(2,i-2)=0.0d0
3454           Ug(1,1,i-2)=1.0d0
3455           Ug(1,2,i-2)=0.0d0
3456           Ug(2,1,i-2)=0.0d0
3457           Ug(2,2,i-2)=1.0d0
3458           Ug2(1,1,i-2)=0.0d0
3459           Ug2(1,2,i-2)=0.0d0
3460           Ug2(2,1,i-2)=0.0d0
3461           Ug2(2,2,i-2)=0.0d0
3462         endif
3463         if (i .gt. 3 .and. i .lt. nres+1) then
3464           obrot_der(1,i-2)=-sin1
3465           obrot_der(2,i-2)= cos1
3466           Ugder(1,1,i-2)= sin1
3467           Ugder(1,2,i-2)=-cos1
3468           Ugder(2,1,i-2)=-cos1
3469           Ugder(2,2,i-2)=-sin1
3470           dwacos2=cos2+cos2
3471           dwasin2=sin2+sin2
3472           obrot2_der(1,i-2)=-dwasin2
3473           obrot2_der(2,i-2)= dwacos2
3474           Ug2der(1,1,i-2)= dwasin2
3475           Ug2der(1,2,i-2)=-dwacos2
3476           Ug2der(2,1,i-2)=-dwacos2
3477           Ug2der(2,2,i-2)=-dwasin2
3478         else
3479           obrot_der(1,i-2)=0.0d0
3480           obrot_der(2,i-2)=0.0d0
3481           Ugder(1,1,i-2)=0.0d0
3482           Ugder(1,2,i-2)=0.0d0
3483           Ugder(2,1,i-2)=0.0d0
3484           Ugder(2,2,i-2)=0.0d0
3485           obrot2_der(1,i-2)=0.0d0
3486           obrot2_der(2,i-2)=0.0d0
3487           Ug2der(1,1,i-2)=0.0d0
3488           Ug2der(1,2,i-2)=0.0d0
3489           Ug2der(2,1,i-2)=0.0d0
3490           Ug2der(2,2,i-2)=0.0d0
3491         endif
3492 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3493         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3494           iti = itype2loc(itype(i-2))
3495         else
3496           iti=nloctyp
3497         endif
3498 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3499         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3500           iti1 = itype2loc(itype(i-1))
3501         else
3502           iti1=nloctyp
3503         endif
3504 cd        write (iout,*) '*******i',i,' iti1',iti
3505 cd        write (iout,*) 'b1',b1(:,iti)
3506 cd        write (iout,*) 'b2',b2(:,iti)
3507 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3508 c        if (i .gt. iatel_s+2) then
3509         if (i .gt. nnt+2) then
3510           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3511 #ifdef NEWCORR
3512           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3513 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3514 #endif
3515 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3516 c     &    EE(1,2,iti),EE(2,2,i)
3517           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3518           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3519 c          write(iout,*) "Macierz EUG",
3520 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3521 c     &    eug(2,2,i-2)
3522           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3523      &    then
3524           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3525           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3526           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3527           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3528           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3529           endif
3530         else
3531           do k=1,2
3532             Ub2(k,i-2)=0.0d0
3533             Ctobr(k,i-2)=0.0d0
3534             Dtobr2(k,i-2)=0.0d0
3535             do l=1,2
3536               EUg(l,k,i-2)=0.0d0
3537               CUg(l,k,i-2)=0.0d0
3538               DUg(l,k,i-2)=0.0d0
3539               DtUg2(l,k,i-2)=0.0d0
3540             enddo
3541           enddo
3542         endif
3543         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3544         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3545         do k=1,2
3546           muder(k,i-2)=Ub2der(k,i-2)
3547         enddo
3548 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3549         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3550           if (itype(i-1).le.ntyp) then
3551             iti1 = itype2loc(itype(i-1))
3552           else
3553             iti1=nloctyp
3554           endif
3555         else
3556           iti1=nloctyp
3557         endif
3558         do k=1,2
3559           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3560         enddo
3561 #ifdef MUOUT
3562         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3563      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3564      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3565      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3566      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3567      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3568 #endif
3569 cd        write (iout,*) 'mu1',mu1(:,i-2)
3570 cd        write (iout,*) 'mu2',mu2(:,i-2)
3571         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3572      &  then
3573         if (calc_grad) then
3574         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3575         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3576         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3577         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3578         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3579         endif
3580 C Vectors and matrices dependent on a single virtual-bond dihedral.
3581         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3582         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3583         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3584         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3585         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3586         if (calc_grad) then
3587         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3588         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3589         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3590         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3591         endif
3592         endif
3593       enddo
3594 C Matrices dependent on two consecutive virtual-bond dihedrals.
3595 C The order of matrices is from left to right.
3596       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3597      &then
3598       do i=2,nres-1
3599         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3600         if (calc_grad) then
3601         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3602         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3603         endif
3604         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3605         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3606         if (calc_grad) then
3607         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3608         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3609         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3610         endif
3611       enddo
3612       endif
3613       return
3614       end
3615 C--------------------------------------------------------------------------
3616       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3617 C
3618 C This subroutine calculates the average interaction energy and its gradient
3619 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3620 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3621 C The potential depends both on the distance of peptide-group centers and on
3622 C the orientation of the CA-CA virtual bonds.
3623 C
3624       implicit real*8 (a-h,o-z)
3625 #ifdef MPI
3626       include 'mpif.h'
3627 #endif
3628       include 'DIMENSIONS'
3629       include 'DIMENSIONS.ZSCOPT'
3630       include 'COMMON.CONTROL'
3631       include 'COMMON.IOUNITS'
3632       include 'COMMON.GEO'
3633       include 'COMMON.VAR'
3634       include 'COMMON.LOCAL'
3635       include 'COMMON.CHAIN'
3636       include 'COMMON.DERIV'
3637       include 'COMMON.INTERACT'
3638       include 'COMMON.CONTACTS'
3639       include 'COMMON.TORSION'
3640       include 'COMMON.VECTORS'
3641       include 'COMMON.FFIELD'
3642       include 'COMMON.TIME1'
3643       include 'COMMON.SPLITELE'
3644       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3645      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3646       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3647      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3648       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3649      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3650      &    num_conti,j1,j2
3651 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3652 #ifdef MOMENT
3653       double precision scal_el /1.0d0/
3654 #else
3655       double precision scal_el /0.5d0/
3656 #endif
3657 C 12/13/98
3658 C 13-go grudnia roku pamietnego...
3659       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3660      &                   0.0d0,1.0d0,0.0d0,
3661      &                   0.0d0,0.0d0,1.0d0/
3662 cd      write(iout,*) 'In EELEC'
3663 cd      do i=1,nloctyp
3664 cd        write(iout,*) 'Type',i
3665 cd        write(iout,*) 'B1',B1(:,i)
3666 cd        write(iout,*) 'B2',B2(:,i)
3667 cd        write(iout,*) 'CC',CC(:,:,i)
3668 cd        write(iout,*) 'DD',DD(:,:,i)
3669 cd        write(iout,*) 'EE',EE(:,:,i)
3670 cd      enddo
3671 cd      call check_vecgrad
3672 cd      stop
3673       if (icheckgrad.eq.1) then
3674         do i=1,nres-1
3675           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3676           do k=1,3
3677             dc_norm(k,i)=dc(k,i)*fac
3678           enddo
3679 c          write (iout,*) 'i',i,' fac',fac
3680         enddo
3681       endif
3682       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3683      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3684      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3685 c        call vec_and_deriv
3686 #ifdef TIMING
3687         time01=MPI_Wtime()
3688 #endif
3689         call set_matrices
3690 #ifdef TIMING
3691         time_mat=time_mat+MPI_Wtime()-time01
3692 #endif
3693       endif
3694 cd      do i=1,nres-1
3695 cd        write (iout,*) 'i=',i
3696 cd        do k=1,3
3697 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3698 cd        enddo
3699 cd        do k=1,3
3700 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3701 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3702 cd        enddo
3703 cd      enddo
3704       t_eelecij=0.0d0
3705       ees=0.0D0
3706       evdw1=0.0D0
3707       eel_loc=0.0d0
3708       eello_turn3=0.0d0
3709       eello_turn4=0.0d0
3710       ind=0
3711       do i=1,nres
3712         num_cont_hb(i)=0
3713       enddo
3714 cd      print '(a)','Enter EELEC'
3715 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3716       do i=1,nres
3717         gel_loc_loc(i)=0.0d0
3718         gcorr_loc(i)=0.0d0
3719       enddo
3720 c
3721 c
3722 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3723 C
3724 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3725 C
3726 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3727       do i=iturn3_start,iturn3_end
3728 c        if (i.le.1) cycle
3729 C        write(iout,*) "tu jest i",i
3730         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3731 C changes suggested by Ana to avoid out of bounds
3732 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3733 c     & .or.((i+4).gt.nres)
3734 c     & .or.((i-1).le.0)
3735 C end of changes by Ana
3736 C dobra zmiana wycofana
3737      &  .or. itype(i+2).eq.ntyp1
3738      &  .or. itype(i+3).eq.ntyp1) cycle
3739 C Adam: Instructions below will switch off existing interactions
3740 c        if(i.gt.1)then
3741 c          if(itype(i-1).eq.ntyp1)cycle
3742 c        end if
3743 c        if(i.LT.nres-3)then
3744 c          if (itype(i+4).eq.ntyp1) cycle
3745 c        end if
3746         dxi=dc(1,i)
3747         dyi=dc(2,i)
3748         dzi=dc(3,i)
3749         dx_normi=dc_norm(1,i)
3750         dy_normi=dc_norm(2,i)
3751         dz_normi=dc_norm(3,i)
3752         xmedi=c(1,i)+0.5d0*dxi
3753         ymedi=c(2,i)+0.5d0*dyi
3754         zmedi=c(3,i)+0.5d0*dzi
3755           xmedi=mod(xmedi,boxxsize)
3756           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3757           ymedi=mod(ymedi,boxysize)
3758           if (ymedi.lt.0) ymedi=ymedi+boxysize
3759           zmedi=mod(zmedi,boxzsize)
3760           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3761         num_conti=0
3762         call eelecij(i,i+2,ees,evdw1,eel_loc)
3763         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3764         num_cont_hb(i)=num_conti
3765       enddo
3766       do i=iturn4_start,iturn4_end
3767         if (i.lt.1) cycle
3768         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3769 C changes suggested by Ana to avoid out of bounds
3770 c     & .or.((i+5).gt.nres)
3771 c     & .or.((i-1).le.0)
3772 C end of changes suggested by Ana
3773      &    .or. itype(i+3).eq.ntyp1
3774      &    .or. itype(i+4).eq.ntyp1
3775 c     &    .or. itype(i+5).eq.ntyp1
3776 c     &    .or. itype(i).eq.ntyp1
3777 c     &    .or. itype(i-1).eq.ntyp1
3778      &                             ) cycle
3779         dxi=dc(1,i)
3780         dyi=dc(2,i)
3781         dzi=dc(3,i)
3782         dx_normi=dc_norm(1,i)
3783         dy_normi=dc_norm(2,i)
3784         dz_normi=dc_norm(3,i)
3785         xmedi=c(1,i)+0.5d0*dxi
3786         ymedi=c(2,i)+0.5d0*dyi
3787         zmedi=c(3,i)+0.5d0*dzi
3788 C Return atom into box, boxxsize is size of box in x dimension
3789 c  194   continue
3790 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3791 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3792 C Condition for being inside the proper box
3793 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3794 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3795 c        go to 194
3796 c        endif
3797 c  195   continue
3798 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3799 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3800 C Condition for being inside the proper box
3801 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3802 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3803 c        go to 195
3804 c        endif
3805 c  196   continue
3806 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3807 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3808 C Condition for being inside the proper box
3809 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3810 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3811 c        go to 196
3812 c        endif
3813           xmedi=mod(xmedi,boxxsize)
3814           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3815           ymedi=mod(ymedi,boxysize)
3816           if (ymedi.lt.0) ymedi=ymedi+boxysize
3817           zmedi=mod(zmedi,boxzsize)
3818           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3819
3820         num_conti=num_cont_hb(i)
3821 c        write(iout,*) "JESTEM W PETLI"
3822         call eelecij(i,i+3,ees,evdw1,eel_loc)
3823         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3824      &   call eturn4(i,eello_turn4)
3825         num_cont_hb(i)=num_conti
3826       enddo   ! i
3827 C Loop over all neighbouring boxes
3828 C      do xshift=-1,1
3829 C      do yshift=-1,1
3830 C      do zshift=-1,1
3831 c
3832 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3833 c
3834 CTU KURWA
3835       do i=iatel_s,iatel_e
3836 C        do i=75,75
3837 c        if (i.le.1) cycle
3838         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3839 C changes suggested by Ana to avoid out of bounds
3840 c     & .or.((i+2).gt.nres)
3841 c     & .or.((i-1).le.0)
3842 C end of changes by Ana
3843 c     &  .or. itype(i+2).eq.ntyp1
3844 c     &  .or. itype(i-1).eq.ntyp1
3845      &                ) cycle
3846         dxi=dc(1,i)
3847         dyi=dc(2,i)
3848         dzi=dc(3,i)
3849         dx_normi=dc_norm(1,i)
3850         dy_normi=dc_norm(2,i)
3851         dz_normi=dc_norm(3,i)
3852         xmedi=c(1,i)+0.5d0*dxi
3853         ymedi=c(2,i)+0.5d0*dyi
3854         zmedi=c(3,i)+0.5d0*dzi
3855           xmedi=mod(xmedi,boxxsize)
3856           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3857           ymedi=mod(ymedi,boxysize)
3858           if (ymedi.lt.0) ymedi=ymedi+boxysize
3859           zmedi=mod(zmedi,boxzsize)
3860           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3861 C          xmedi=xmedi+xshift*boxxsize
3862 C          ymedi=ymedi+yshift*boxysize
3863 C          zmedi=zmedi+zshift*boxzsize
3864
3865 C Return tom into box, boxxsize is size of box in x dimension
3866 c  164   continue
3867 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3868 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3869 C Condition for being inside the proper box
3870 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3871 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3872 c        go to 164
3873 c        endif
3874 c  165   continue
3875 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3876 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3877 C Condition for being inside the proper box
3878 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3879 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3880 c        go to 165
3881 c        endif
3882 c  166   continue
3883 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3884 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3885 cC Condition for being inside the proper box
3886 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3887 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3888 c        go to 166
3889 c        endif
3890
3891 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3892         num_conti=num_cont_hb(i)
3893 C I TU KURWA
3894         do j=ielstart(i),ielend(i)
3895 C          do j=16,17
3896 C          write (iout,*) i,j
3897 C         if (j.le.1) cycle
3898           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3899 C changes suggested by Ana to avoid out of bounds
3900 c     & .or.((j+2).gt.nres)
3901 c     & .or.((j-1).le.0)
3902 C end of changes by Ana
3903 c     & .or.itype(j+2).eq.ntyp1
3904 c     & .or.itype(j-1).eq.ntyp1
3905      &) cycle
3906           call eelecij(i,j,ees,evdw1,eel_loc)
3907         enddo ! j
3908         num_cont_hb(i)=num_conti
3909       enddo   ! i
3910 C     enddo   ! zshift
3911 C      enddo   ! yshift
3912 C      enddo   ! xshift
3913
3914 c      write (iout,*) "Number of loop steps in EELEC:",ind
3915 cd      do i=1,nres
3916 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3917 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3918 cd      enddo
3919 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3920 ccc      eel_loc=eel_loc+eello_turn3
3921 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3922       return
3923       end
3924 C-------------------------------------------------------------------------------
3925       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3926       implicit real*8 (a-h,o-z)
3927       include 'DIMENSIONS'
3928       include 'DIMENSIONS.ZSCOPT'
3929 #ifdef MPI
3930       include "mpif.h"
3931 #endif
3932       include 'COMMON.CONTROL'
3933       include 'COMMON.IOUNITS'
3934       include 'COMMON.GEO'
3935       include 'COMMON.VAR'
3936       include 'COMMON.LOCAL'
3937       include 'COMMON.CHAIN'
3938       include 'COMMON.DERIV'
3939       include 'COMMON.INTERACT'
3940       include 'COMMON.CONTACTS'
3941       include 'COMMON.TORSION'
3942       include 'COMMON.VECTORS'
3943       include 'COMMON.FFIELD'
3944       include 'COMMON.TIME1'
3945       include 'COMMON.SPLITELE'
3946       include 'COMMON.SHIELD'
3947       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3948      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3949       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3950      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3951      &    gmuij2(4),gmuji2(4)
3952       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3953      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3954      &    num_conti,j1,j2
3955 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3956 #ifdef MOMENT
3957       double precision scal_el /1.0d0/
3958 #else
3959       double precision scal_el /0.5d0/
3960 #endif
3961 C 12/13/98
3962 C 13-go grudnia roku pamietnego...
3963       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3964      &                   0.0d0,1.0d0,0.0d0,
3965      &                   0.0d0,0.0d0,1.0d0/
3966        integer xshift,yshift,zshift
3967 c          time00=MPI_Wtime()
3968 cd      write (iout,*) "eelecij",i,j
3969 c          ind=ind+1
3970           iteli=itel(i)
3971           itelj=itel(j)
3972           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3973           aaa=app(iteli,itelj)
3974           bbb=bpp(iteli,itelj)
3975           ael6i=ael6(iteli,itelj)
3976           ael3i=ael3(iteli,itelj)
3977           dxj=dc(1,j)
3978           dyj=dc(2,j)
3979           dzj=dc(3,j)
3980           dx_normj=dc_norm(1,j)
3981           dy_normj=dc_norm(2,j)
3982           dz_normj=dc_norm(3,j)
3983 C          xj=c(1,j)+0.5D0*dxj-xmedi
3984 C          yj=c(2,j)+0.5D0*dyj-ymedi
3985 C          zj=c(3,j)+0.5D0*dzj-zmedi
3986           xj=c(1,j)+0.5D0*dxj
3987           yj=c(2,j)+0.5D0*dyj
3988           zj=c(3,j)+0.5D0*dzj
3989           xj=mod(xj,boxxsize)
3990           if (xj.lt.0) xj=xj+boxxsize
3991           yj=mod(yj,boxysize)
3992           if (yj.lt.0) yj=yj+boxysize
3993           zj=mod(zj,boxzsize)
3994           if (zj.lt.0) zj=zj+boxzsize
3995           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3996       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3997       xj_safe=xj
3998       yj_safe=yj
3999       zj_safe=zj
4000       isubchap=0
4001       do xshift=-1,1
4002       do yshift=-1,1
4003       do zshift=-1,1
4004           xj=xj_safe+xshift*boxxsize
4005           yj=yj_safe+yshift*boxysize
4006           zj=zj_safe+zshift*boxzsize
4007           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4008           if(dist_temp.lt.dist_init) then
4009             dist_init=dist_temp
4010             xj_temp=xj
4011             yj_temp=yj
4012             zj_temp=zj
4013             isubchap=1
4014           endif
4015        enddo
4016        enddo
4017        enddo
4018        if (isubchap.eq.1) then
4019           xj=xj_temp-xmedi
4020           yj=yj_temp-ymedi
4021           zj=zj_temp-zmedi
4022        else
4023           xj=xj_safe-xmedi
4024           yj=yj_safe-ymedi
4025           zj=zj_safe-zmedi
4026        endif
4027 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4028 c  174   continue
4029 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4030 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4031 C Condition for being inside the proper box
4032 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4033 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4034 c        go to 174
4035 c        endif
4036 c  175   continue
4037 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4038 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4039 C Condition for being inside the proper box
4040 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4041 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4042 c        go to 175
4043 c        endif
4044 c  176   continue
4045 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4046 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4047 C Condition for being inside the proper box
4048 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4049 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4050 c        go to 176
4051 c        endif
4052 C        endif !endPBC condintion
4053 C        xj=xj-xmedi
4054 C        yj=yj-ymedi
4055 C        zj=zj-zmedi
4056           rij=xj*xj+yj*yj+zj*zj
4057
4058             sss=sscale(sqrt(rij))
4059             sssgrad=sscagrad(sqrt(rij))
4060 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
4061 c     &       " rlamb",rlamb," sss",sss
4062 c            if (sss.gt.0.0d0) then
4063           rrmij=1.0D0/rij
4064           rij=dsqrt(rij)
4065           rmij=1.0D0/rij
4066           r3ij=rrmij*rmij
4067           r6ij=r3ij*r3ij
4068           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4069           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4070           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4071           fac=cosa-3.0D0*cosb*cosg
4072           ev1=aaa*r6ij*r6ij
4073 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4074           if (j.eq.i+2) ev1=scal_el*ev1
4075           ev2=bbb*r6ij
4076           fac3=ael6i*r6ij
4077           fac4=ael3i*r3ij
4078           evdwij=(ev1+ev2)
4079           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4080           el2=fac4*fac
4081 C MARYSIA
4082 C          eesij=(el1+el2)
4083 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4084           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4085           if (shield_mode.gt.0) then
4086 C          fac_shield(i)=0.4
4087 C          fac_shield(j)=0.6
4088           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4089           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4090           eesij=(el1+el2)
4091           ees=ees+eesij
4092           else
4093           fac_shield(i)=1.0
4094           fac_shield(j)=1.0
4095           eesij=(el1+el2)
4096           ees=ees+eesij
4097           endif
4098           evdw1=evdw1+evdwij*sss
4099 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4100 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4101 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4102 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4103
4104           if (energy_dec) then
4105               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4106      &'evdw1',i,j,evdwij
4107      &,iteli,itelj,aaa,evdw1,sss
4108               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4109      &fac_shield(i),fac_shield(j)
4110           endif
4111
4112 C
4113 C Calculate contributions to the Cartesian gradient.
4114 C
4115 #ifdef SPLITELE
4116           facvdw=-6*rrmij*(ev1+evdwij)*sss
4117           facel=-3*rrmij*(el1+eesij)
4118           fac1=fac
4119           erij(1)=xj*rmij
4120           erij(2)=yj*rmij
4121           erij(3)=zj*rmij
4122
4123 *
4124 * Radial derivatives. First process both termini of the fragment (i,j)
4125 *
4126           if (calc_grad) then
4127           ggg(1)=facel*xj
4128           ggg(2)=facel*yj
4129           ggg(3)=facel*zj
4130           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4131      &  (shield_mode.gt.0)) then
4132 C          print *,i,j
4133           do ilist=1,ishield_list(i)
4134            iresshield=shield_list(ilist,i)
4135            do k=1,3
4136            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4137      &      *2.0
4138            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4139      &              rlocshield
4140      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4141             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4142 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4143 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4144 C             if (iresshield.gt.i) then
4145 C               do ishi=i+1,iresshield-1
4146 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4147 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4148 C
4149 C              enddo
4150 C             else
4151 C               do ishi=iresshield,i
4152 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4153 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4154 C
4155 C               enddo
4156 C              endif
4157            enddo
4158           enddo
4159           do ilist=1,ishield_list(j)
4160            iresshield=shield_list(ilist,j)
4161            do k=1,3
4162            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4163      &     *2.0
4164            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4165      &              rlocshield
4166      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4167            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4168
4169 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4170 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4171 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4172 C             if (iresshield.gt.j) then
4173 C               do ishi=j+1,iresshield-1
4174 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4175 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4176 C
4177 C               enddo
4178 C            else
4179 C               do ishi=iresshield,j
4180 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4181 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4182 C               enddo
4183 C              endif
4184            enddo
4185           enddo
4186
4187           do k=1,3
4188             gshieldc(k,i)=gshieldc(k,i)+
4189      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4190             gshieldc(k,j)=gshieldc(k,j)+
4191      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4192             gshieldc(k,i-1)=gshieldc(k,i-1)+
4193      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4194             gshieldc(k,j-1)=gshieldc(k,j-1)+
4195      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4196
4197            enddo
4198            endif
4199 c          do k=1,3
4200 c            ghalf=0.5D0*ggg(k)
4201 c            gelc(k,i)=gelc(k,i)+ghalf
4202 c            gelc(k,j)=gelc(k,j)+ghalf
4203 c          enddo
4204 c 9/28/08 AL Gradient compotents will be summed only at the end
4205 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4206           do k=1,3
4207             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4208 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4209             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4210 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4211 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4212 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4213 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4214 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4215           enddo
4216 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4217
4218 *
4219 * Loop over residues i+1 thru j-1.
4220 *
4221 cgrad          do k=i+1,j-1
4222 cgrad            do l=1,3
4223 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226           if (sss.gt.0.0) then
4227           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4228           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4229           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4230           else
4231           ggg(1)=0.0
4232           ggg(2)=0.0
4233           ggg(3)=0.0
4234           endif
4235 c          do k=1,3
4236 c            ghalf=0.5D0*ggg(k)
4237 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4238 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4239 c          enddo
4240 c 9/28/08 AL Gradient compotents will be summed only at the end
4241           do k=1,3
4242             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4243             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4244           enddo
4245 *
4246 * Loop over residues i+1 thru j-1.
4247 *
4248 cgrad          do k=i+1,j-1
4249 cgrad            do l=1,3
4250 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4251 cgrad            enddo
4252 cgrad          enddo
4253           endif ! calc_grad
4254 #else
4255 C MARYSIA
4256           facvdw=(ev1+evdwij)*sss
4257           facel=(el1+eesij)
4258           fac1=fac
4259           fac=-3*rrmij*(facvdw+facvdw+facel)
4260           erij(1)=xj*rmij
4261           erij(2)=yj*rmij
4262           erij(3)=zj*rmij
4263 *
4264 * Radial derivatives. First process both termini of the fragment (i,j)
4265 *
4266           if (calc_grad) then
4267           ggg(1)=fac*xj
4268 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4269           ggg(2)=fac*yj
4270 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4271           ggg(3)=fac*zj
4272 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4273 c          do k=1,3
4274 c            ghalf=0.5D0*ggg(k)
4275 c            gelc(k,i)=gelc(k,i)+ghalf
4276 c            gelc(k,j)=gelc(k,j)+ghalf
4277 c          enddo
4278 c 9/28/08 AL Gradient compotents will be summed only at the end
4279           do k=1,3
4280             gelc_long(k,j)=gelc(k,j)+ggg(k)
4281             gelc_long(k,i)=gelc(k,i)-ggg(k)
4282           enddo
4283 *
4284 * Loop over residues i+1 thru j-1.
4285 *
4286 cgrad          do k=i+1,j-1
4287 cgrad            do l=1,3
4288 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4289 cgrad            enddo
4290 cgrad          enddo
4291 c 9/28/08 AL Gradient compotents will be summed only at the end
4292           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4293           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4294           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4295           do k=1,3
4296             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4297             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4298           enddo
4299           endif ! calc_grad
4300 #endif
4301 *
4302 * Angular part
4303 *
4304           if (calc_grad) then
4305           ecosa=2.0D0*fac3*fac1+fac4
4306           fac4=-3.0D0*fac4
4307           fac3=-6.0D0*fac3
4308           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4309           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4310           do k=1,3
4311             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4312             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4313           enddo
4314 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4315 cd   &          (dcosg(k),k=1,3)
4316           do k=1,3
4317             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4318      &      fac_shield(i)**2*fac_shield(j)**2
4319           enddo
4320 c          do k=1,3
4321 c            ghalf=0.5D0*ggg(k)
4322 c            gelc(k,i)=gelc(k,i)+ghalf
4323 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4324 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4325 c            gelc(k,j)=gelc(k,j)+ghalf
4326 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4327 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4328 c          enddo
4329 cgrad          do k=i+1,j-1
4330 cgrad            do l=1,3
4331 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4332 cgrad            enddo
4333 cgrad          enddo
4334 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4335           do k=1,3
4336             gelc(k,i)=gelc(k,i)
4337      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4338      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4339      &           *fac_shield(i)**2*fac_shield(j)**2
4340             gelc(k,j)=gelc(k,j)
4341      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4342      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4343      &           *fac_shield(i)**2*fac_shield(j)**2
4344             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4345             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4346           enddo
4347 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4348
4349 C MARYSIA
4350 c          endif !sscale
4351           endif ! calc_grad
4352           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4353      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4354      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4355 C
4356 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4357 C   energy of a peptide unit is assumed in the form of a second-order
4358 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4359 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4360 C   are computed for EVERY pair of non-contiguous peptide groups.
4361 C
4362
4363           if (j.lt.nres-1) then
4364             j1=j+1
4365             j2=j-1
4366           else
4367             j1=j-1
4368             j2=j-2
4369           endif
4370           kkk=0
4371           lll=0
4372           do k=1,2
4373             do l=1,2
4374               kkk=kkk+1
4375               muij(kkk)=mu(k,i)*mu(l,j)
4376 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4377 #ifdef NEWCORR
4378              if (calc_grad) then
4379              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4380 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4381              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4382              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4383 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4384              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4385              endif
4386 #endif
4387             enddo
4388           enddo
4389 #ifdef DEBUG
4390           write (iout,*) 'EELEC: i',i,' j',j
4391           write (iout,*) 'j',j,' j1',j1,' j2',j2
4392           write(iout,*) 'muij',muij
4393           write (iout,*) "uy",uy(:,i)
4394           write (iout,*) "uz",uz(:,j)
4395           write (iout,*) "erij",erij
4396 #endif
4397           ury=scalar(uy(1,i),erij)
4398           urz=scalar(uz(1,i),erij)
4399           vry=scalar(uy(1,j),erij)
4400           vrz=scalar(uz(1,j),erij)
4401           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4402           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4403           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4404           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4405           fac=dsqrt(-ael6i)*r3ij
4406           a22=a22*fac
4407           a23=a23*fac
4408           a32=a32*fac
4409           a33=a33*fac
4410 cd          write (iout,'(4i5,4f10.5)')
4411 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4412 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4413 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4414 cd     &      uy(:,j),uz(:,j)
4415 cd          write (iout,'(4f10.5)')
4416 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4417 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4418 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4419 cd           write (iout,'(9f10.5/)')
4420 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4421 C Derivatives of the elements of A in virtual-bond vectors
4422           if (calc_grad) then
4423           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4424           do k=1,3
4425             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4426             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4427             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4428             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4429             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4430             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4431             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4432             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4433             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4434             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4435             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4436             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4437           enddo
4438 C Compute radial contributions to the gradient
4439           facr=-3.0d0*rrmij
4440           a22der=a22*facr
4441           a23der=a23*facr
4442           a32der=a32*facr
4443           a33der=a33*facr
4444           agg(1,1)=a22der*xj
4445           agg(2,1)=a22der*yj
4446           agg(3,1)=a22der*zj
4447           agg(1,2)=a23der*xj
4448           agg(2,2)=a23der*yj
4449           agg(3,2)=a23der*zj
4450           agg(1,3)=a32der*xj
4451           agg(2,3)=a32der*yj
4452           agg(3,3)=a32der*zj
4453           agg(1,4)=a33der*xj
4454           agg(2,4)=a33der*yj
4455           agg(3,4)=a33der*zj
4456 C Add the contributions coming from er
4457           fac3=-3.0d0*fac
4458           do k=1,3
4459             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4460             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4461             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4462             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4463           enddo
4464           do k=1,3
4465 C Derivatives in DC(i)
4466 cgrad            ghalf1=0.5d0*agg(k,1)
4467 cgrad            ghalf2=0.5d0*agg(k,2)
4468 cgrad            ghalf3=0.5d0*agg(k,3)
4469 cgrad            ghalf4=0.5d0*agg(k,4)
4470             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4471      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4472             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4473      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4474             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4475      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4476             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4477      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4478 C Derivatives in DC(i+1)
4479             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4480      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4481             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4482      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4483             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4484      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4485             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4486      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4487 C Derivatives in DC(j)
4488             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4489      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4490             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4491      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4492             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4493      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4494             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4495      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4496 C Derivatives in DC(j+1) or DC(nres-1)
4497             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4498      &      -3.0d0*vryg(k,3)*ury)
4499             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4500      &      -3.0d0*vrzg(k,3)*ury)
4501             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4502      &      -3.0d0*vryg(k,3)*urz)
4503             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4504      &      -3.0d0*vrzg(k,3)*urz)
4505 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4506 cgrad              do l=1,4
4507 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4508 cgrad              enddo
4509 cgrad            endif
4510           enddo
4511           endif ! calc_grad
4512           acipa(1,1)=a22
4513           acipa(1,2)=a23
4514           acipa(2,1)=a32
4515           acipa(2,2)=a33
4516           a22=-a22
4517           a23=-a23
4518           if (calc_grad) then
4519           do l=1,2
4520             do k=1,3
4521               agg(k,l)=-agg(k,l)
4522               aggi(k,l)=-aggi(k,l)
4523               aggi1(k,l)=-aggi1(k,l)
4524               aggj(k,l)=-aggj(k,l)
4525               aggj1(k,l)=-aggj1(k,l)
4526             enddo
4527           enddo
4528           endif ! calc_grad
4529           if (j.lt.nres-1) then
4530             a22=-a22
4531             a32=-a32
4532             do l=1,3,2
4533               do k=1,3
4534                 agg(k,l)=-agg(k,l)
4535                 aggi(k,l)=-aggi(k,l)
4536                 aggi1(k,l)=-aggi1(k,l)
4537                 aggj(k,l)=-aggj(k,l)
4538                 aggj1(k,l)=-aggj1(k,l)
4539               enddo
4540             enddo
4541           else
4542             a22=-a22
4543             a23=-a23
4544             a32=-a32
4545             a33=-a33
4546             do l=1,4
4547               do k=1,3
4548                 agg(k,l)=-agg(k,l)
4549                 aggi(k,l)=-aggi(k,l)
4550                 aggi1(k,l)=-aggi1(k,l)
4551                 aggj(k,l)=-aggj(k,l)
4552                 aggj1(k,l)=-aggj1(k,l)
4553               enddo
4554             enddo
4555           endif
4556           ENDIF ! WCORR
4557           IF (wel_loc.gt.0.0d0) THEN
4558 C Contribution to the local-electrostatic energy coming from the i-j pair
4559           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4560      &     +a33*muij(4)
4561 #ifdef DEBUG
4562           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4563      &     " a33",a33
4564           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4565      &     " wel_loc",wel_loc
4566 #endif
4567           if (shield_mode.eq.0) then
4568            fac_shield(i)=1.0
4569            fac_shield(j)=1.0
4570 C          else
4571 C           fac_shield(i)=0.4
4572 C           fac_shield(j)=0.6
4573           endif
4574           eel_loc_ij=eel_loc_ij
4575      &    *fac_shield(i)*fac_shield(j)
4576           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4577      &            'eelloc',i,j,eel_loc_ij
4578 c           if (eel_loc_ij.ne.0)
4579 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4580 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4581
4582           eel_loc=eel_loc+eel_loc_ij
4583 C Now derivative over eel_loc
4584           if (calc_grad) then
4585           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4586      &  (shield_mode.gt.0)) then
4587 C          print *,i,j
4588
4589           do ilist=1,ishield_list(i)
4590            iresshield=shield_list(ilist,i)
4591            do k=1,3
4592            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4593      &                                          /fac_shield(i)
4594 C     &      *2.0
4595            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4596      &              rlocshield
4597      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4598             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4599      &      +rlocshield
4600            enddo
4601           enddo
4602           do ilist=1,ishield_list(j)
4603            iresshield=shield_list(ilist,j)
4604            do k=1,3
4605            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4606      &                                       /fac_shield(j)
4607 C     &     *2.0
4608            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4609      &              rlocshield
4610      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4611            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4612      &             +rlocshield
4613
4614            enddo
4615           enddo
4616
4617           do k=1,3
4618             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4619      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4620             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4621      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4622             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4623      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4624             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4625      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4626            enddo
4627            endif
4628
4629
4630 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4631 c     &                     ' eel_loc_ij',eel_loc_ij
4632 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4633 C Calculate patrial derivative for theta angle
4634 #ifdef NEWCORR
4635          geel_loc_ij=(a22*gmuij1(1)
4636      &     +a23*gmuij1(2)
4637      &     +a32*gmuij1(3)
4638      &     +a33*gmuij1(4))
4639      &    *fac_shield(i)*fac_shield(j)
4640 c         write(iout,*) "derivative over thatai"
4641 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4642 c     &   a33*gmuij1(4)
4643          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4644      &      geel_loc_ij*wel_loc
4645 c         write(iout,*) "derivative over thatai-1"
4646 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4647 c     &   a33*gmuij2(4)
4648          geel_loc_ij=
4649      &     a22*gmuij2(1)
4650      &     +a23*gmuij2(2)
4651      &     +a32*gmuij2(3)
4652      &     +a33*gmuij2(4)
4653          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4654      &      geel_loc_ij*wel_loc
4655      &    *fac_shield(i)*fac_shield(j)
4656
4657 c  Derivative over j residue
4658          geel_loc_ji=a22*gmuji1(1)
4659      &     +a23*gmuji1(2)
4660      &     +a32*gmuji1(3)
4661      &     +a33*gmuji1(4)
4662 c         write(iout,*) "derivative over thataj"
4663 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4664 c     &   a33*gmuji1(4)
4665
4666         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4667      &      geel_loc_ji*wel_loc
4668      &    *fac_shield(i)*fac_shield(j)
4669
4670          geel_loc_ji=
4671      &     +a22*gmuji2(1)
4672      &     +a23*gmuji2(2)
4673      &     +a32*gmuji2(3)
4674      &     +a33*gmuji2(4)
4675 c         write(iout,*) "derivative over thataj-1"
4676 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4677 c     &   a33*gmuji2(4)
4678          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4679      &      geel_loc_ji*wel_loc
4680      &    *fac_shield(i)*fac_shield(j)
4681 #endif
4682 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4683
4684 C Partial derivatives in virtual-bond dihedral angles gamma
4685           if (i.gt.1)
4686      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4687      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4688      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4689      &    *fac_shield(i)*fac_shield(j)
4690
4691           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4692      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4693      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4694      &    *fac_shield(i)*fac_shield(j)
4695 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4696           do l=1,3
4697             ggg(l)=(agg(l,1)*muij(1)+
4698      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4699      &    *fac_shield(i)*fac_shield(j)
4700             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4701             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4702 cgrad            ghalf=0.5d0*ggg(l)
4703 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4704 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4705           enddo
4706 cgrad          do k=i+1,j2
4707 cgrad            do l=1,3
4708 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4709 cgrad            enddo
4710 cgrad          enddo
4711 C Remaining derivatives of eello
4712           do l=1,3
4713             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4714      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4715      &    *fac_shield(i)*fac_shield(j)
4716
4717             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4718      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4719      &    *fac_shield(i)*fac_shield(j)
4720
4721             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4722      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4723      &    *fac_shield(i)*fac_shield(j)
4724
4725             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4726      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4727      &    *fac_shield(i)*fac_shield(j)
4728
4729           enddo
4730           endif ! calc_grad
4731           ENDIF
4732
4733
4734 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4735 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4736           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4737      &       .and. num_conti.le.maxconts) then
4738 c            write (iout,*) i,j," entered corr"
4739 C
4740 C Calculate the contact function. The ith column of the array JCONT will
4741 C contain the numbers of atoms that make contacts with the atom I (of numbers
4742 C greater than I). The arrays FACONT and GACONT will contain the values of
4743 C the contact function and its derivative.
4744 c           r0ij=1.02D0*rpp(iteli,itelj)
4745 c           r0ij=1.11D0*rpp(iteli,itelj)
4746             r0ij=2.20D0*rpp(iteli,itelj)
4747 c           r0ij=1.55D0*rpp(iteli,itelj)
4748             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4749             if (fcont.gt.0.0D0) then
4750               num_conti=num_conti+1
4751               if (num_conti.gt.maxconts) then
4752                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4753      &                         ' will skip next contacts for this conf.'
4754               else
4755                 jcont_hb(num_conti,i)=j
4756 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4757 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4758                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4759      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4760 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4761 C  terms.
4762                 d_cont(num_conti,i)=rij
4763 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4764 C     --- Electrostatic-interaction matrix ---
4765                 a_chuj(1,1,num_conti,i)=a22
4766                 a_chuj(1,2,num_conti,i)=a23
4767                 a_chuj(2,1,num_conti,i)=a32
4768                 a_chuj(2,2,num_conti,i)=a33
4769 C     --- Gradient of rij
4770                 if (calc_grad) then
4771                 do kkk=1,3
4772                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4773                 enddo
4774                 kkll=0
4775                 do k=1,2
4776                   do l=1,2
4777                     kkll=kkll+1
4778                     do m=1,3
4779                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4780                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4781                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4782                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4783                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4784                     enddo
4785                   enddo
4786                 enddo
4787                 endif ! calc_grad
4788                 ENDIF
4789                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4790 C Calculate contact energies
4791                 cosa4=4.0D0*cosa
4792                 wij=cosa-3.0D0*cosb*cosg
4793                 cosbg1=cosb+cosg
4794                 cosbg2=cosb-cosg
4795 c               fac3=dsqrt(-ael6i)/r0ij**3
4796                 fac3=dsqrt(-ael6i)*r3ij
4797 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4798                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4799                 if (ees0tmp.gt.0) then
4800                   ees0pij=dsqrt(ees0tmp)
4801                 else
4802                   ees0pij=0
4803                 endif
4804 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4805                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4806                 if (ees0tmp.gt.0) then
4807                   ees0mij=dsqrt(ees0tmp)
4808                 else
4809                   ees0mij=0
4810                 endif
4811 c               ees0mij=0.0D0
4812                 if (shield_mode.eq.0) then
4813                 fac_shield(i)=1.0d0
4814                 fac_shield(j)=1.0d0
4815                 else
4816                 ees0plist(num_conti,i)=j
4817 C                fac_shield(i)=0.4d0
4818 C                fac_shield(j)=0.6d0
4819                 endif
4820                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4821      &          *fac_shield(i)*fac_shield(j)
4822                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4823      &          *fac_shield(i)*fac_shield(j)
4824 C Diagnostics. Comment out or remove after debugging!
4825 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4826 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4827 c               ees0m(num_conti,i)=0.0D0
4828 C End diagnostics.
4829 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4830 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4831 C Angular derivatives of the contact function
4832
4833                 ees0pij1=fac3/ees0pij
4834                 ees0mij1=fac3/ees0mij
4835                 fac3p=-3.0D0*fac3*rrmij
4836                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4837                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4838 c               ees0mij1=0.0D0
4839                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4840                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4841                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4842                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4843                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4844                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4845                 ecosap=ecosa1+ecosa2
4846                 ecosbp=ecosb1+ecosb2
4847                 ecosgp=ecosg1+ecosg2
4848                 ecosam=ecosa1-ecosa2
4849                 ecosbm=ecosb1-ecosb2
4850                 ecosgm=ecosg1-ecosg2
4851 C Diagnostics
4852 c               ecosap=ecosa1
4853 c               ecosbp=ecosb1
4854 c               ecosgp=ecosg1
4855 c               ecosam=0.0D0
4856 c               ecosbm=0.0D0
4857 c               ecosgm=0.0D0
4858 C End diagnostics
4859                 facont_hb(num_conti,i)=fcont
4860
4861                 if (calc_grad) then
4862                 fprimcont=fprimcont/rij
4863 cd              facont_hb(num_conti,i)=1.0D0
4864 C Following line is for diagnostics.
4865 cd              fprimcont=0.0D0
4866                 do k=1,3
4867                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4868                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4869                 enddo
4870                 do k=1,3
4871                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4872                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4873                 enddo
4874                 gggp(1)=gggp(1)+ees0pijp*xj
4875                 gggp(2)=gggp(2)+ees0pijp*yj
4876                 gggp(3)=gggp(3)+ees0pijp*zj
4877                 gggm(1)=gggm(1)+ees0mijp*xj
4878                 gggm(2)=gggm(2)+ees0mijp*yj
4879                 gggm(3)=gggm(3)+ees0mijp*zj
4880 C Derivatives due to the contact function
4881                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4882                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4883                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4884                 do k=1,3
4885 c
4886 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4887 c          following the change of gradient-summation algorithm.
4888 c
4889 cgrad                  ghalfp=0.5D0*gggp(k)
4890 cgrad                  ghalfm=0.5D0*gggm(k)
4891                   gacontp_hb1(k,num_conti,i)=!ghalfp
4892      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4893      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4894      &          *fac_shield(i)*fac_shield(j)
4895
4896                   gacontp_hb2(k,num_conti,i)=!ghalfp
4897      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4898      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4899      &          *fac_shield(i)*fac_shield(j)
4900
4901                   gacontp_hb3(k,num_conti,i)=gggp(k)
4902      &          *fac_shield(i)*fac_shield(j)
4903
4904                   gacontm_hb1(k,num_conti,i)=!ghalfm
4905      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4906      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4907      &          *fac_shield(i)*fac_shield(j)
4908
4909                   gacontm_hb2(k,num_conti,i)=!ghalfm
4910      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4911      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4912      &          *fac_shield(i)*fac_shield(j)
4913
4914                   gacontm_hb3(k,num_conti,i)=gggm(k)
4915      &          *fac_shield(i)*fac_shield(j)
4916
4917                 enddo
4918 C Diagnostics. Comment out or remove after debugging!
4919 cdiag           do k=1,3
4920 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4921 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4922 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4923 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4924 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4925 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4926 cdiag           enddo
4927
4928                  endif ! calc_grad
4929
4930               ENDIF ! wcorr
4931               endif  ! num_conti.le.maxconts
4932             endif  ! fcont.gt.0
4933           endif    ! j.gt.i+1
4934           if (calc_grad) then
4935           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4936             do k=1,4
4937               do l=1,3
4938                 ghalf=0.5d0*agg(l,k)
4939                 aggi(l,k)=aggi(l,k)+ghalf
4940                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4941                 aggj(l,k)=aggj(l,k)+ghalf
4942               enddo
4943             enddo
4944             if (j.eq.nres-1 .and. i.lt.j-2) then
4945               do k=1,4
4946                 do l=1,3
4947                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4948                 enddo
4949               enddo
4950             endif
4951           endif
4952           endif ! calc_grad
4953 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4954       return
4955       end
4956 C-----------------------------------------------------------------------------
4957       subroutine eturn3(i,eello_turn3)
4958 C Third- and fourth-order contributions from turns
4959       implicit real*8 (a-h,o-z)
4960       include 'DIMENSIONS'
4961       include 'DIMENSIONS.ZSCOPT'
4962       include 'COMMON.IOUNITS'
4963       include 'COMMON.GEO'
4964       include 'COMMON.VAR'
4965       include 'COMMON.LOCAL'
4966       include 'COMMON.CHAIN'
4967       include 'COMMON.DERIV'
4968       include 'COMMON.INTERACT'
4969       include 'COMMON.CONTACTS'
4970       include 'COMMON.TORSION'
4971       include 'COMMON.VECTORS'
4972       include 'COMMON.FFIELD'
4973       include 'COMMON.CONTROL'
4974       include 'COMMON.SHIELD'
4975       dimension ggg(3)
4976       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4977      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4978      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4979      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4980      &  auxgmat2(2,2),auxgmatt2(2,2)
4981       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4982      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4983       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4984      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4985      &    num_conti,j1,j2
4986       j=i+2
4987 c      write (iout,*) "eturn3",i,j,j1,j2
4988       a_temp(1,1)=a22
4989       a_temp(1,2)=a23
4990       a_temp(2,1)=a32
4991       a_temp(2,2)=a33
4992 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4993 C
4994 C               Third-order contributions
4995 C
4996 C                 (i+2)o----(i+3)
4997 C                      | |
4998 C                      | |
4999 C                 (i+1)o----i
5000 C
5001 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5002 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5003         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5004 c auxalary matices for theta gradient
5005 c auxalary matrix for i+1 and constant i+2
5006         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5007 c auxalary matrix for i+2 and constant i+1
5008         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5009         call transpose2(auxmat(1,1),auxmat1(1,1))
5010         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5011         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5012         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5013         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5014         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5015         if (shield_mode.eq.0) then
5016         fac_shield(i)=1.0
5017         fac_shield(j)=1.0
5018 C        else
5019 C        fac_shield(i)=0.4
5020 C        fac_shield(j)=0.6
5021         endif
5022         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5023      &  *fac_shield(i)*fac_shield(j)
5024         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5025      &  *fac_shield(i)*fac_shield(j)
5026         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5027      &    eello_t3
5028         if (calc_grad) then
5029 C#ifdef NEWCORR
5030 C Derivatives in theta
5031         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5032      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5033      &   *fac_shield(i)*fac_shield(j)
5034         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5035      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5036      &   *fac_shield(i)*fac_shield(j)
5037 C#endif
5038
5039 C Derivatives in shield mode
5040           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5041      &  (shield_mode.gt.0)) then
5042 C          print *,i,j
5043
5044           do ilist=1,ishield_list(i)
5045            iresshield=shield_list(ilist,i)
5046            do k=1,3
5047            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5048 C     &      *2.0
5049            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5050      &              rlocshield
5051      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5052             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5053      &      +rlocshield
5054            enddo
5055           enddo
5056           do ilist=1,ishield_list(j)
5057            iresshield=shield_list(ilist,j)
5058            do k=1,3
5059            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5060 C     &     *2.0
5061            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5062      &              rlocshield
5063      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5064            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5065      &             +rlocshield
5066
5067            enddo
5068           enddo
5069
5070           do k=1,3
5071             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5072      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5073             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5074      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5075             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5076      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5077             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5078      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5079            enddo
5080            endif
5081
5082 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5083 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5084 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5085 cd     &    ' eello_turn3_num',4*eello_turn3_num
5086 C Derivatives in gamma(i)
5087         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5088         call transpose2(auxmat2(1,1),auxmat3(1,1))
5089         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5090         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5091      &   *fac_shield(i)*fac_shield(j)
5092 C Derivatives in gamma(i+1)
5093         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5094         call transpose2(auxmat2(1,1),auxmat3(1,1))
5095         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5096         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5097      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5098      &   *fac_shield(i)*fac_shield(j)
5099 C Cartesian derivatives
5100         do l=1,3
5101 c            ghalf1=0.5d0*agg(l,1)
5102 c            ghalf2=0.5d0*agg(l,2)
5103 c            ghalf3=0.5d0*agg(l,3)
5104 c            ghalf4=0.5d0*agg(l,4)
5105           a_temp(1,1)=aggi(l,1)!+ghalf1
5106           a_temp(1,2)=aggi(l,2)!+ghalf2
5107           a_temp(2,1)=aggi(l,3)!+ghalf3
5108           a_temp(2,2)=aggi(l,4)!+ghalf4
5109           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5110           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5111      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5112      &   *fac_shield(i)*fac_shield(j)
5113
5114           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5115           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5116           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5117           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5118           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5119           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5120      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5121      &   *fac_shield(i)*fac_shield(j)
5122           a_temp(1,1)=aggj(l,1)!+ghalf1
5123           a_temp(1,2)=aggj(l,2)!+ghalf2
5124           a_temp(2,1)=aggj(l,3)!+ghalf3
5125           a_temp(2,2)=aggj(l,4)!+ghalf4
5126           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5127           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5128      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5129      &   *fac_shield(i)*fac_shield(j)
5130           a_temp(1,1)=aggj1(l,1)
5131           a_temp(1,2)=aggj1(l,2)
5132           a_temp(2,1)=aggj1(l,3)
5133           a_temp(2,2)=aggj1(l,4)
5134           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5135           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5136      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5137      &   *fac_shield(i)*fac_shield(j)
5138         enddo
5139
5140         endif ! calc_grad
5141
5142       return
5143       end
5144 C-------------------------------------------------------------------------------
5145       subroutine eturn4(i,eello_turn4)
5146 C Third- and fourth-order contributions from turns
5147       implicit real*8 (a-h,o-z)
5148       include 'DIMENSIONS'
5149       include 'DIMENSIONS.ZSCOPT'
5150       include 'COMMON.IOUNITS'
5151       include 'COMMON.GEO'
5152       include 'COMMON.VAR'
5153       include 'COMMON.LOCAL'
5154       include 'COMMON.CHAIN'
5155       include 'COMMON.DERIV'
5156       include 'COMMON.INTERACT'
5157       include 'COMMON.CONTACTS'
5158       include 'COMMON.TORSION'
5159       include 'COMMON.VECTORS'
5160       include 'COMMON.FFIELD'
5161       include 'COMMON.CONTROL'
5162       include 'COMMON.SHIELD'
5163       dimension ggg(3)
5164       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5165      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5166      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5167      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5168      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5169      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5170      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5171       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5172      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5173       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5174      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5175      &    num_conti,j1,j2
5176       j=i+3
5177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5178 C
5179 C               Fourth-order contributions
5180 C
5181 C                 (i+3)o----(i+4)
5182 C                     /  |
5183 C               (i+2)o   |
5184 C                     \  |
5185 C                 (i+1)o----i
5186 C
5187 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5188 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5189 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5190 c        write(iout,*)"WCHODZE W PROGRAM"
5191         a_temp(1,1)=a22
5192         a_temp(1,2)=a23
5193         a_temp(2,1)=a32
5194         a_temp(2,2)=a33
5195         iti1=itype2loc(itype(i+1))
5196         iti2=itype2loc(itype(i+2))
5197         iti3=itype2loc(itype(i+3))
5198 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5199         call transpose2(EUg(1,1,i+1),e1t(1,1))
5200         call transpose2(Eug(1,1,i+2),e2t(1,1))
5201         call transpose2(Eug(1,1,i+3),e3t(1,1))
5202 C Ematrix derivative in theta
5203         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5204         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5205         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5206         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5207 c       eta1 in derivative theta
5208         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5209         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5210 c       auxgvec is derivative of Ub2 so i+3 theta
5211         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5212 c       auxalary matrix of E i+1
5213         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5214 c        s1=0.0
5215 c        gs1=0.0
5216         s1=scalar2(b1(1,i+2),auxvec(1))
5217 c derivative of theta i+2 with constant i+3
5218         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5219 c derivative of theta i+2 with constant i+2
5220         gs32=scalar2(b1(1,i+2),auxgvec(1))
5221 c derivative of E matix in theta of i+1
5222         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5223
5224         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5225 c       ea31 in derivative theta
5226         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5227         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5228 c auxilary matrix auxgvec of Ub2 with constant E matirx
5229         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5230 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5231         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5232
5233 c        s2=0.0
5234 c        gs2=0.0
5235         s2=scalar2(b1(1,i+1),auxvec(1))
5236 c derivative of theta i+1 with constant i+3
5237         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5238 c derivative of theta i+2 with constant i+1
5239         gs21=scalar2(b1(1,i+1),auxgvec(1))
5240 c derivative of theta i+3 with constant i+1
5241         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5242 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5243 c     &  gtb1(1,i+1)
5244         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5245 c two derivatives over diffetent matrices
5246 c gtae3e2 is derivative over i+3
5247         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5248 c ae3gte2 is derivative over i+2
5249         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5250         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5251 c three possible derivative over theta E matices
5252 c i+1
5253         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5254 c i+2
5255         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5256 c i+3
5257         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5258         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5259
5260         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5261         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5262         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5263         if (shield_mode.eq.0) then
5264         fac_shield(i)=1.0
5265         fac_shield(j)=1.0
5266 C        else
5267 C        fac_shield(i)=0.6
5268 C        fac_shield(j)=0.4
5269         endif
5270         eello_turn4=eello_turn4-(s1+s2+s3)
5271      &  *fac_shield(i)*fac_shield(j)
5272         eello_t4=-(s1+s2+s3)
5273      &  *fac_shield(i)*fac_shield(j)
5274 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5275         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5276      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5277 C Now derivative over shield:
5278           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5279      &  (shield_mode.gt.0)) then
5280 C          print *,i,j
5281
5282           do ilist=1,ishield_list(i)
5283            iresshield=shield_list(ilist,i)
5284            do k=1,3
5285            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5286 C     &      *2.0
5287            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5288      &              rlocshield
5289      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5290             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5291      &      +rlocshield
5292            enddo
5293           enddo
5294           do ilist=1,ishield_list(j)
5295            iresshield=shield_list(ilist,j)
5296            do k=1,3
5297            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5298 C     &     *2.0
5299            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5300      &              rlocshield
5301      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5302            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5303      &             +rlocshield
5304
5305            enddo
5306           enddo
5307
5308           do k=1,3
5309             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5310      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5311             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5312      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5313             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5314      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5315             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5316      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5317            enddo
5318            endif
5319 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5320 cd     &    ' eello_turn4_num',8*eello_turn4_num
5321 #ifdef NEWCORR
5322         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5323      &                  -(gs13+gsE13+gsEE1)*wturn4
5324      &  *fac_shield(i)*fac_shield(j)
5325         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5326      &                    -(gs23+gs21+gsEE2)*wturn4
5327      &  *fac_shield(i)*fac_shield(j)
5328
5329         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5330      &                    -(gs32+gsE31+gsEE3)*wturn4
5331      &  *fac_shield(i)*fac_shield(j)
5332
5333 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5334 c     &   gs2
5335 #endif
5336         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5337      &      'eturn4',i,j,-(s1+s2+s3)
5338 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5339 c     &    ' eello_turn4_num',8*eello_turn4_num
5340 C Derivatives in gamma(i)
5341         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5342         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5343         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5344         s1=scalar2(b1(1,i+2),auxvec(1))
5345         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5346         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5347         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5348      &  *fac_shield(i)*fac_shield(j)
5349 C Derivatives in gamma(i+1)
5350         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5351         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5352         s2=scalar2(b1(1,i+1),auxvec(1))
5353         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5354         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5355         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5356         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5357      &  *fac_shield(i)*fac_shield(j)
5358 C Derivatives in gamma(i+2)
5359         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5360         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5361         s1=scalar2(b1(1,i+2),auxvec(1))
5362         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5363         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5364         s2=scalar2(b1(1,i+1),auxvec(1))
5365         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5366         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5367         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5368         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5369      &  *fac_shield(i)*fac_shield(j)
5370         if (calc_grad) then
5371 C Cartesian derivatives
5372 C Derivatives of this turn contributions in DC(i+2)
5373         if (j.lt.nres-1) then
5374           do l=1,3
5375             a_temp(1,1)=agg(l,1)
5376             a_temp(1,2)=agg(l,2)
5377             a_temp(2,1)=agg(l,3)
5378             a_temp(2,2)=agg(l,4)
5379             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5380             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5381             s1=scalar2(b1(1,i+2),auxvec(1))
5382             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5383             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5384             s2=scalar2(b1(1,i+1),auxvec(1))
5385             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5386             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5387             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5388             ggg(l)=-(s1+s2+s3)
5389             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5390      &  *fac_shield(i)*fac_shield(j)
5391           enddo
5392         endif
5393 C Remaining derivatives of this turn contribution
5394         do l=1,3
5395           a_temp(1,1)=aggi(l,1)
5396           a_temp(1,2)=aggi(l,2)
5397           a_temp(2,1)=aggi(l,3)
5398           a_temp(2,2)=aggi(l,4)
5399           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5400           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5401           s1=scalar2(b1(1,i+2),auxvec(1))
5402           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5403           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5404           s2=scalar2(b1(1,i+1),auxvec(1))
5405           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5406           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5407           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5408           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5409      &  *fac_shield(i)*fac_shield(j)
5410           a_temp(1,1)=aggi1(l,1)
5411           a_temp(1,2)=aggi1(l,2)
5412           a_temp(2,1)=aggi1(l,3)
5413           a_temp(2,2)=aggi1(l,4)
5414           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5415           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5416           s1=scalar2(b1(1,i+2),auxvec(1))
5417           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5418           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5419           s2=scalar2(b1(1,i+1),auxvec(1))
5420           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5421           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5422           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5423           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5424      &  *fac_shield(i)*fac_shield(j)
5425           a_temp(1,1)=aggj(l,1)
5426           a_temp(1,2)=aggj(l,2)
5427           a_temp(2,1)=aggj(l,3)
5428           a_temp(2,2)=aggj(l,4)
5429           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5430           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5431           s1=scalar2(b1(1,i+2),auxvec(1))
5432           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5433           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5434           s2=scalar2(b1(1,i+1),auxvec(1))
5435           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5436           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5437           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5438           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5439      &  *fac_shield(i)*fac_shield(j)
5440           a_temp(1,1)=aggj1(l,1)
5441           a_temp(1,2)=aggj1(l,2)
5442           a_temp(2,1)=aggj1(l,3)
5443           a_temp(2,2)=aggj1(l,4)
5444           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5445           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5446           s1=scalar2(b1(1,i+2),auxvec(1))
5447           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5448           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5449           s2=scalar2(b1(1,i+1),auxvec(1))
5450           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5451           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5452           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5453 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5454           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5455      &  *fac_shield(i)*fac_shield(j)
5456         enddo
5457
5458         endif ! calc_grad
5459
5460       return
5461       end
5462 C-----------------------------------------------------------------------------
5463       subroutine vecpr(u,v,w)
5464       implicit real*8(a-h,o-z)
5465       dimension u(3),v(3),w(3)
5466       w(1)=u(2)*v(3)-u(3)*v(2)
5467       w(2)=-u(1)*v(3)+u(3)*v(1)
5468       w(3)=u(1)*v(2)-u(2)*v(1)
5469       return
5470       end
5471 C-----------------------------------------------------------------------------
5472       subroutine unormderiv(u,ugrad,unorm,ungrad)
5473 C This subroutine computes the derivatives of a normalized vector u, given
5474 C the derivatives computed without normalization conditions, ugrad. Returns
5475 C ungrad.
5476       implicit none
5477       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5478       double precision vec(3)
5479       double precision scalar
5480       integer i,j
5481 c      write (2,*) 'ugrad',ugrad
5482 c      write (2,*) 'u',u
5483       do i=1,3
5484         vec(i)=scalar(ugrad(1,i),u(1))
5485       enddo
5486 c      write (2,*) 'vec',vec
5487       do i=1,3
5488         do j=1,3
5489           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5490         enddo
5491       enddo
5492 c      write (2,*) 'ungrad',ungrad
5493       return
5494       end
5495 C-----------------------------------------------------------------------------
5496       subroutine escp(evdw2,evdw2_14)
5497 C
5498 C This subroutine calculates the excluded-volume interaction energy between
5499 C peptide-group centers and side chains and its gradient in virtual-bond and
5500 C side-chain vectors.
5501 C
5502       implicit real*8 (a-h,o-z)
5503       include 'DIMENSIONS'
5504       include 'DIMENSIONS.ZSCOPT'
5505       include 'COMMON.GEO'
5506       include 'COMMON.VAR'
5507       include 'COMMON.LOCAL'
5508       include 'COMMON.CHAIN'
5509       include 'COMMON.DERIV'
5510       include 'COMMON.INTERACT'
5511       include 'COMMON.FFIELD'
5512       include 'COMMON.IOUNITS'
5513       dimension ggg(3)
5514       evdw2=0.0D0
5515       evdw2_14=0.0d0
5516 cd    print '(a)','Enter ESCP'
5517 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5518 c     &  ' scal14',scal14
5519       do i=iatscp_s,iatscp_e
5520         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5521         iteli=itel(i)
5522 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5523 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5524         if (iteli.eq.0) goto 1225
5525         xi=0.5D0*(c(1,i)+c(1,i+1))
5526         yi=0.5D0*(c(2,i)+c(2,i+1))
5527         zi=0.5D0*(c(3,i)+c(3,i+1))
5528 C Returning the ith atom to box
5529           xi=mod(xi,boxxsize)
5530           if (xi.lt.0) xi=xi+boxxsize
5531           yi=mod(yi,boxysize)
5532           if (yi.lt.0) yi=yi+boxysize
5533           zi=mod(zi,boxzsize)
5534           if (zi.lt.0) zi=zi+boxzsize
5535         do iint=1,nscp_gr(i)
5536
5537         do j=iscpstart(i,iint),iscpend(i,iint)
5538           itypj=iabs(itype(j))
5539           if (itypj.eq.ntyp1) cycle
5540 C Uncomment following three lines for SC-p interactions
5541 c         xj=c(1,nres+j)-xi
5542 c         yj=c(2,nres+j)-yi
5543 c         zj=c(3,nres+j)-zi
5544 C Uncomment following three lines for Ca-p interactions
5545           xj=c(1,j)
5546           yj=c(2,j)
5547           zj=c(3,j)
5548 C returning the jth atom to box
5549           xj=mod(xj,boxxsize)
5550           if (xj.lt.0) xj=xj+boxxsize
5551           yj=mod(yj,boxysize)
5552           if (yj.lt.0) yj=yj+boxysize
5553           zj=mod(zj,boxzsize)
5554           if (zj.lt.0) zj=zj+boxzsize
5555       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5556       xj_safe=xj
5557       yj_safe=yj
5558       zj_safe=zj
5559       subchap=0
5560 C Finding the closest jth atom
5561       do xshift=-1,1
5562       do yshift=-1,1
5563       do zshift=-1,1
5564           xj=xj_safe+xshift*boxxsize
5565           yj=yj_safe+yshift*boxysize
5566           zj=zj_safe+zshift*boxzsize
5567           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5568           if(dist_temp.lt.dist_init) then
5569             dist_init=dist_temp
5570             xj_temp=xj
5571             yj_temp=yj
5572             zj_temp=zj
5573             subchap=1
5574           endif
5575        enddo
5576        enddo
5577        enddo
5578        if (subchap.eq.1) then
5579           xj=xj_temp-xi
5580           yj=yj_temp-yi
5581           zj=zj_temp-zi
5582        else
5583           xj=xj_safe-xi
5584           yj=yj_safe-yi
5585           zj=zj_safe-zi
5586        endif
5587           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5588 C sss is scaling function for smoothing the cutoff gradient otherwise
5589 C the gradient would not be continuouse
5590           sss=sscale(1.0d0/(dsqrt(rrij)))
5591           if (sss.le.0.0d0) cycle
5592           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5593           fac=rrij**expon2
5594           e1=fac*fac*aad(itypj,iteli)
5595           e2=fac*bad(itypj,iteli)
5596           if (iabs(j-i) .le. 2) then
5597             e1=scal14*e1
5598             e2=scal14*e2
5599             evdw2_14=evdw2_14+(e1+e2)*sss
5600           endif
5601           evdwij=e1+e2
5602 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5603 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5604 c     &       bad(itypj,iteli)
5605           evdw2=evdw2+evdwij*sss
5606           if (calc_grad) then
5607 C
5608 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5609 C
5610           fac=-(evdwij+e1)*rrij*sss
5611           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5612           ggg(1)=xj*fac
5613           ggg(2)=yj*fac
5614           ggg(3)=zj*fac
5615           if (j.lt.i) then
5616 cd          write (iout,*) 'j<i'
5617 C Uncomment following three lines for SC-p interactions
5618 c           do k=1,3
5619 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5620 c           enddo
5621           else
5622 cd          write (iout,*) 'j>i'
5623             do k=1,3
5624               ggg(k)=-ggg(k)
5625 C Uncomment following line for SC-p interactions
5626 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5627             enddo
5628           endif
5629           do k=1,3
5630             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5631           enddo
5632           kstart=min0(i+1,j)
5633           kend=max0(i-1,j-1)
5634 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5635 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5636           do k=kstart,kend
5637             do l=1,3
5638               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5639             enddo
5640           enddo
5641           endif ! calc_grad
5642         enddo
5643         enddo ! iint
5644  1225   continue
5645       enddo ! i
5646       do i=1,nct
5647         do j=1,3
5648           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5649           gradx_scp(j,i)=expon*gradx_scp(j,i)
5650         enddo
5651       enddo
5652 C******************************************************************************
5653 C
5654 C                              N O T E !!!
5655 C
5656 C To save time the factor EXPON has been extracted from ALL components
5657 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5658 C use!
5659 C
5660 C******************************************************************************
5661       return
5662       end
5663 C--------------------------------------------------------------------------
5664       subroutine edis(ehpb)
5665 C
5666 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5667 C
5668       implicit real*8 (a-h,o-z)
5669       include 'DIMENSIONS'
5670       include 'DIMENSIONS.ZSCOPT'
5671       include 'COMMON.SBRIDGE'
5672       include 'COMMON.CHAIN'
5673       include 'COMMON.DERIV'
5674       include 'COMMON.VAR'
5675       include 'COMMON.INTERACT'
5676       include 'COMMON.CONTROL'
5677       include 'COMMON.IOUNITS'
5678       dimension ggg(3)
5679       ehpb=0.0D0
5680 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5681 cd    print *,'link_start=',link_start,' link_end=',link_end
5682 C      write(iout,*) link_end, "link_end"
5683       if (link_end.eq.0) return
5684       do i=link_start,link_end
5685 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5686 C CA-CA distance used in regularization of structure.
5687         ii=ihpb(i)
5688         jj=jhpb(i)
5689 C iii and jjj point to the residues for which the distance is assigned.
5690         if (ii.gt.nres) then
5691           iii=ii-nres
5692           jjj=jj-nres
5693         else
5694           iii=ii
5695           jjj=jj
5696         endif
5697 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5698 C    distance and angle dependent SS bond potential.
5699 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5700 C     & iabs(itype(jjj)).eq.1) then
5701 C       write(iout,*) constr_dist,"const"
5702        if (.not.dyn_ss .and. i.le.nss) then
5703          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5704      & iabs(itype(jjj)).eq.1) then
5705           call ssbond_ene(iii,jjj,eij)
5706           ehpb=ehpb+2*eij
5707            endif !ii.gt.neres
5708         else if (ii.gt.nres .and. jj.gt.nres) then
5709 c Restraints from contact prediction
5710           dd=dist(ii,jj)
5711           if (constr_dist.eq.11) then
5712 C            ehpb=ehpb+fordepth(i)**4.0d0
5713 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5714             ehpb=ehpb+fordepth(i)**4.0d0
5715      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5716             fac=fordepth(i)**4.0d0
5717      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5718 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5719 C     &    ehpb,fordepth(i),dd
5720 C            write(iout,*) ehpb,"atu?"
5721 C            ehpb,"tu?"
5722 C            fac=fordepth(i)**4.0d0
5723 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5724            else
5725           if (dhpb1(i).gt.0.0d0) then
5726             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5727             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5728 c            write (iout,*) "beta nmr",
5729 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5730           else
5731             dd=dist(ii,jj)
5732             rdis=dd-dhpb(i)
5733 C Get the force constant corresponding to this distance.
5734             waga=forcon(i)
5735 C Calculate the contribution to energy.
5736             ehpb=ehpb+waga*rdis*rdis
5737 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5738 C
5739 C Evaluate gradient.
5740 C
5741             fac=waga*rdis/dd
5742           endif !end dhpb1(i).gt.0
5743           endif !end const_dist=11
5744           do j=1,3
5745             ggg(j)=fac*(c(j,jj)-c(j,ii))
5746           enddo
5747           do j=1,3
5748             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5749             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5750           enddo
5751           do k=1,3
5752             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5753             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5754           enddo
5755         else !ii.gt.nres
5756 C          write(iout,*) "before"
5757           dd=dist(ii,jj)
5758 C          write(iout,*) "after",dd
5759           if (constr_dist.eq.11) then
5760             ehpb=ehpb+fordepth(i)**4.0d0
5761      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5762             fac=fordepth(i)**4.0d0
5763      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5764 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5765 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5766 C            print *,ehpb,"tu?"
5767 C            write(iout,*) ehpb,"btu?",
5768 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5769 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5770 C     &    ehpb,fordepth(i),dd
5771            else
5772           if (dhpb1(i).gt.0.0d0) then
5773             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5774             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5775 c            write (iout,*) "alph nmr",
5776 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5777           else
5778             rdis=dd-dhpb(i)
5779 C Get the force constant corresponding to this distance.
5780             waga=forcon(i)
5781 C Calculate the contribution to energy.
5782             ehpb=ehpb+waga*rdis*rdis
5783 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5784 C
5785 C Evaluate gradient.
5786 C
5787             fac=waga*rdis/dd
5788           endif
5789           endif
5790
5791         do j=1,3
5792           ggg(j)=fac*(c(j,jj)-c(j,ii))
5793         enddo
5794 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5795 C If this is a SC-SC distance, we need to calculate the contributions to the
5796 C Cartesian gradient in the SC vectors (ghpbx).
5797         if (iii.lt.ii) then
5798           do j=1,3
5799             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5800             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5801           enddo
5802         endif
5803         do j=iii,jjj-1
5804           do k=1,3
5805             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5806           enddo
5807         enddo
5808         endif
5809       enddo
5810       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5811       return
5812       end
5813 C--------------------------------------------------------------------------
5814       subroutine ssbond_ene(i,j,eij)
5815 C
5816 C Calculate the distance and angle dependent SS-bond potential energy
5817 C using a free-energy function derived based on RHF/6-31G** ab initio
5818 C calculations of diethyl disulfide.
5819 C
5820 C A. Liwo and U. Kozlowska, 11/24/03
5821 C
5822       implicit real*8 (a-h,o-z)
5823       include 'DIMENSIONS'
5824       include 'DIMENSIONS.ZSCOPT'
5825       include 'COMMON.SBRIDGE'
5826       include 'COMMON.CHAIN'
5827       include 'COMMON.DERIV'
5828       include 'COMMON.LOCAL'
5829       include 'COMMON.INTERACT'
5830       include 'COMMON.VAR'
5831       include 'COMMON.IOUNITS'
5832       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5833       itypi=iabs(itype(i))
5834       xi=c(1,nres+i)
5835       yi=c(2,nres+i)
5836       zi=c(3,nres+i)
5837       dxi=dc_norm(1,nres+i)
5838       dyi=dc_norm(2,nres+i)
5839       dzi=dc_norm(3,nres+i)
5840       dsci_inv=dsc_inv(itypi)
5841       itypj=iabs(itype(j))
5842       dscj_inv=dsc_inv(itypj)
5843       xj=c(1,nres+j)-xi
5844       yj=c(2,nres+j)-yi
5845       zj=c(3,nres+j)-zi
5846       dxj=dc_norm(1,nres+j)
5847       dyj=dc_norm(2,nres+j)
5848       dzj=dc_norm(3,nres+j)
5849       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5850       rij=dsqrt(rrij)
5851       erij(1)=xj*rij
5852       erij(2)=yj*rij
5853       erij(3)=zj*rij
5854       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5855       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5856       om12=dxi*dxj+dyi*dyj+dzi*dzj
5857       do k=1,3
5858         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5859         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5860       enddo
5861       rij=1.0d0/rij
5862       deltad=rij-d0cm
5863       deltat1=1.0d0-om1
5864       deltat2=1.0d0+om2
5865       deltat12=om2-om1+2.0d0
5866       cosphi=om12-om1*om2
5867       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5868      &  +akct*deltad*deltat12
5869      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5870 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5871 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5872 c     &  " deltat12",deltat12," eij",eij
5873       ed=2*akcm*deltad+akct*deltat12
5874       pom1=akct*deltad
5875       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5876       eom1=-2*akth*deltat1-pom1-om2*pom2
5877       eom2= 2*akth*deltat2+pom1-om1*pom2
5878       eom12=pom2
5879       do k=1,3
5880         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5881       enddo
5882       do k=1,3
5883         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5884      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5885         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5886      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5887       enddo
5888 C
5889 C Calculate the components of the gradient in DC and X
5890 C
5891       do k=i,j-1
5892         do l=1,3
5893           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5894         enddo
5895       enddo
5896       return
5897       end
5898 C--------------------------------------------------------------------------
5899       subroutine ebond(estr)
5900 c
5901 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5902 c
5903       implicit real*8 (a-h,o-z)
5904       include 'DIMENSIONS'
5905       include 'DIMENSIONS.ZSCOPT'
5906       include 'COMMON.LOCAL'
5907       include 'COMMON.GEO'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.DERIV'
5910       include 'COMMON.VAR'
5911       include 'COMMON.CHAIN'
5912       include 'COMMON.IOUNITS'
5913       include 'COMMON.NAMES'
5914       include 'COMMON.FFIELD'
5915       include 'COMMON.CONTROL'
5916       double precision u(3),ud(3)
5917       estr=0.0d0
5918       estr1=0.0d0
5919 c      write (iout,*) "distchainmax",distchainmax
5920       do i=nnt+1,nct
5921         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5922 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5923 C          do j=1,3
5924 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5925 C     &      *dc(j,i-1)/vbld(i)
5926 C          enddo
5927 C          if (energy_dec) write(iout,*)
5928 C     &       "estr1",i,vbld(i),distchainmax,
5929 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5930 C        else
5931          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5932         diff = vbld(i)-vbldpDUM
5933 #ifdef DEBUG
5934          write(iout,*) "dumm_bond",i,diff
5935 #endif
5936          else
5937           diff = vbld(i)-vbldp0
5938 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5939          endif
5940 #ifdef DEBUG
5941         write (iout,'(a7,i5,4f7.3)')
5942      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5943 #endif
5944           estr=estr+diff*diff
5945           do j=1,3
5946             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5947           enddo
5948 C        endif
5949       enddo
5950       estr=0.5d0*AKP*estr+estr1
5951 c
5952 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5953 c
5954       do i=nnt,nct
5955         iti=iabs(itype(i))
5956         if (iti.ne.10 .and. iti.ne.ntyp1) then
5957           nbi=nbondterm(iti)
5958           if (nbi.eq.1) then
5959             diff=vbld(i+nres)-vbldsc0(1,iti)
5960 #ifdef DEBUG
5961             write (iout,*)
5962      &        "estr_sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5963      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5964 #endif
5965             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5966             do j=1,3
5967               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5968             enddo
5969           else
5970             do j=1,nbi
5971               diff=vbld(i+nres)-vbldsc0(j,iti)
5972               ud(j)=aksc(j,iti)*diff
5973               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5974             enddo
5975             uprod=u(1)
5976             do j=2,nbi
5977               uprod=uprod*u(j)
5978             enddo
5979             usum=0.0d0
5980             usumsqder=0.0d0
5981             do j=1,nbi
5982               uprod1=1.0d0
5983               uprod2=1.0d0
5984               do k=1,nbi
5985                 if (k.ne.j) then
5986                   uprod1=uprod1*u(k)
5987                   uprod2=uprod2*u(k)*u(k)
5988                 endif
5989               enddo
5990               usum=usum+uprod1
5991               usumsqder=usumsqder+ud(j)*uprod2
5992             enddo
5993 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5994 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5995             estr=estr+uprod/usum
5996             do j=1,3
5997              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5998             enddo
5999           endif
6000         endif
6001       enddo
6002       return
6003       end
6004 #ifdef CRYST_THETA
6005 C--------------------------------------------------------------------------
6006       subroutine ebend(etheta,ethetacnstr)
6007 C
6008 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6009 C angles gamma and its derivatives in consecutive thetas and gammas.
6010 C
6011       implicit real*8 (a-h,o-z)
6012       include 'DIMENSIONS'
6013       include 'DIMENSIONS.ZSCOPT'
6014       include 'COMMON.LOCAL'
6015       include 'COMMON.GEO'
6016       include 'COMMON.INTERACT'
6017       include 'COMMON.DERIV'
6018       include 'COMMON.VAR'
6019       include 'COMMON.CHAIN'
6020       include 'COMMON.IOUNITS'
6021       include 'COMMON.NAMES'
6022       include 'COMMON.FFIELD'
6023       include 'COMMON.TORCNSTR'
6024       common /calcthet/ term1,term2,termm,diffak,ratak,
6025      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6026      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6027       double precision y(2),z(2)
6028       delta=0.02d0*pi
6029 c      time11=dexp(-2*time)
6030 c      time12=1.0d0
6031       etheta=0.0D0
6032 c      write (iout,*) "nres",nres
6033 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6034 c      write (iout,*) ithet_start,ithet_end
6035       do i=ithet_start,ithet_end
6036 C        if (itype(i-1).eq.ntyp1) cycle
6037         if (i.le.2) cycle
6038         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6039      &  .or.itype(i).eq.ntyp1) cycle
6040 C Zero the energy function and its derivative at 0 or pi.
6041         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6042         it=itype(i-1)
6043         ichir1=isign(1,itype(i-2))
6044         ichir2=isign(1,itype(i))
6045          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6046          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6047          if (itype(i-1).eq.10) then
6048           itype1=isign(10,itype(i-2))
6049           ichir11=isign(1,itype(i-2))
6050           ichir12=isign(1,itype(i-2))
6051           itype2=isign(10,itype(i))
6052           ichir21=isign(1,itype(i))
6053           ichir22=isign(1,itype(i))
6054          endif
6055          if (i.eq.3) then
6056           y(1)=0.0D0
6057           y(2)=0.0D0
6058           else
6059
6060         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6061 #ifdef OSF
6062           phii=phi(i)
6063 c          icrc=0
6064 c          call proc_proc(phii,icrc)
6065           if (icrc.eq.1) phii=150.0
6066 #else
6067           phii=phi(i)
6068 #endif
6069           y(1)=dcos(phii)
6070           y(2)=dsin(phii)
6071         else
6072           y(1)=0.0D0
6073           y(2)=0.0D0
6074         endif
6075         endif
6076         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6077 #ifdef OSF
6078           phii1=phi(i+1)
6079 c          icrc=0
6080 c          call proc_proc(phii1,icrc)
6081           if (icrc.eq.1) phii1=150.0
6082           phii1=pinorm(phii1)
6083           z(1)=cos(phii1)
6084 #else
6085           phii1=phi(i+1)
6086           z(1)=dcos(phii1)
6087 #endif
6088           z(2)=dsin(phii1)
6089         else
6090           z(1)=0.0D0
6091           z(2)=0.0D0
6092         endif
6093 C Calculate the "mean" value of theta from the part of the distribution
6094 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6095 C In following comments this theta will be referred to as t_c.
6096         thet_pred_mean=0.0d0
6097         do k=1,2
6098             athetk=athet(k,it,ichir1,ichir2)
6099             bthetk=bthet(k,it,ichir1,ichir2)
6100           if (it.eq.10) then
6101              athetk=athet(k,itype1,ichir11,ichir12)
6102              bthetk=bthet(k,itype2,ichir21,ichir22)
6103           endif
6104           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6105         enddo
6106 c        write (iout,*) "thet_pred_mean",thet_pred_mean
6107         dthett=thet_pred_mean*ssd
6108         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6109 c        write (iout,*) "thet_pred_mean",thet_pred_mean
6110 C Derivatives of the "mean" values in gamma1 and gamma2.
6111         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6112      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6113          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6114      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6115          if (it.eq.10) then
6116       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6117      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6118         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6119      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6120          endif
6121         if (theta(i).gt.pi-delta) then
6122           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6123      &         E_tc0)
6124           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6125           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6126           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6127      &        E_theta)
6128           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6129      &        E_tc)
6130         else if (theta(i).lt.delta) then
6131           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6132           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6133           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6134      &        E_theta)
6135           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6136           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6137      &        E_tc)
6138         else
6139           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6140      &        E_theta,E_tc)
6141         endif
6142         etheta=etheta+ethetai
6143 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6144 c     &      'ebend',i,ethetai,theta(i),itype(i)
6145 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
6146 c     &    rad2deg*phii,rad2deg*phii1,ethetai
6147         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6148         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6149         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6150 c 1215   continue
6151       enddo
6152       ethetacnstr=0.0d0
6153 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6154       do i=1,ntheta_constr
6155         itheta=itheta_constr(i)
6156         thetiii=theta(itheta)
6157         difi=pinorm(thetiii-theta_constr0(i))
6158         if (difi.gt.theta_drange(i)) then
6159           difi=difi-theta_drange(i)
6160           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6161           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6162      &    +for_thet_constr(i)*difi**3
6163         else if (difi.lt.-drange(i)) then
6164           difi=difi+drange(i)
6165           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6166           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6167      &    +for_thet_constr(i)*difi**3
6168         else
6169           difi=0.0
6170         endif
6171 C       if (energy_dec) then
6172 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6173 C     &    i,itheta,rad2deg*thetiii,
6174 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6175 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6176 C     &    gloc(itheta+nphi-2,icg)
6177 C        endif
6178       enddo
6179 C Ufff.... We've done all this!!!
6180       return
6181       end
6182 C---------------------------------------------------------------------------
6183       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6184      &     E_tc)
6185       implicit real*8 (a-h,o-z)
6186       include 'DIMENSIONS'
6187       include 'COMMON.LOCAL'
6188       include 'COMMON.IOUNITS'
6189       common /calcthet/ term1,term2,termm,diffak,ratak,
6190      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6191      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6192 C Calculate the contributions to both Gaussian lobes.
6193 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6194 C The "polynomial part" of the "standard deviation" of this part of
6195 C the distribution.
6196         sig=polthet(3,it)
6197         do j=2,0,-1
6198           sig=sig*thet_pred_mean+polthet(j,it)
6199         enddo
6200 C Derivative of the "interior part" of the "standard deviation of the"
6201 C gamma-dependent Gaussian lobe in t_c.
6202         sigtc=3*polthet(3,it)
6203         do j=2,1,-1
6204           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6205         enddo
6206         sigtc=sig*sigtc
6207 C Set the parameters of both Gaussian lobes of the distribution.
6208 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6209         fac=sig*sig+sigc0(it)
6210         sigcsq=fac+fac
6211         sigc=1.0D0/sigcsq
6212 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6213         sigsqtc=-4.0D0*sigcsq*sigtc
6214 c       print *,i,sig,sigtc,sigsqtc
6215 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6216         sigtc=-sigtc/(fac*fac)
6217 C Following variable is sigma(t_c)**(-2)
6218         sigcsq=sigcsq*sigcsq
6219         sig0i=sig0(it)
6220         sig0inv=1.0D0/sig0i**2
6221         delthec=thetai-thet_pred_mean
6222         delthe0=thetai-theta0i
6223         term1=-0.5D0*sigcsq*delthec*delthec
6224         term2=-0.5D0*sig0inv*delthe0*delthe0
6225 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6226 C NaNs in taking the logarithm. We extract the largest exponent which is added
6227 C to the energy (this being the log of the distribution) at the end of energy
6228 C term evaluation for this virtual-bond angle.
6229         if (term1.gt.term2) then
6230           termm=term1
6231           term2=dexp(term2-termm)
6232           term1=1.0d0
6233         else
6234           termm=term2
6235           term1=dexp(term1-termm)
6236           term2=1.0d0
6237         endif
6238 C The ratio between the gamma-independent and gamma-dependent lobes of
6239 C the distribution is a Gaussian function of thet_pred_mean too.
6240         diffak=gthet(2,it)-thet_pred_mean
6241         ratak=diffak/gthet(3,it)**2
6242         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6243 C Let's differentiate it in thet_pred_mean NOW.
6244         aktc=ak*ratak
6245 C Now put together the distribution terms to make complete distribution.
6246         termexp=term1+ak*term2
6247         termpre=sigc+ak*sig0i
6248 C Contribution of the bending energy from this theta is just the -log of
6249 C the sum of the contributions from the two lobes and the pre-exponential
6250 C factor. Simple enough, isn't it?
6251         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6252 C NOW the derivatives!!!
6253 C 6/6/97 Take into account the deformation.
6254         E_theta=(delthec*sigcsq*term1
6255      &       +ak*delthe0*sig0inv*term2)/termexp
6256         E_tc=((sigtc+aktc*sig0i)/termpre
6257      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6258      &       aktc*term2)/termexp)
6259       return
6260       end
6261 c-----------------------------------------------------------------------------
6262       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6263       implicit real*8 (a-h,o-z)
6264       include 'DIMENSIONS'
6265       include 'COMMON.LOCAL'
6266       include 'COMMON.IOUNITS'
6267       common /calcthet/ term1,term2,termm,diffak,ratak,
6268      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6269      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6270       delthec=thetai-thet_pred_mean
6271       delthe0=thetai-theta0i
6272 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6273       t3 = thetai-thet_pred_mean
6274       t6 = t3**2
6275       t9 = term1
6276       t12 = t3*sigcsq
6277       t14 = t12+t6*sigsqtc
6278       t16 = 1.0d0
6279       t21 = thetai-theta0i
6280       t23 = t21**2
6281       t26 = term2
6282       t27 = t21*t26
6283       t32 = termexp
6284       t40 = t32**2
6285       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6286      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6287      & *(-t12*t9-ak*sig0inv*t27)
6288       return
6289       end
6290 #else
6291 C--------------------------------------------------------------------------
6292       subroutine ebend(etheta)
6293 C
6294 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6295 C angles gamma and its derivatives in consecutive thetas and gammas.
6296 C ab initio-derived potentials from
6297 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6298 C
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'DIMENSIONS.ZSCOPT'
6302       include 'COMMON.LOCAL'
6303       include 'COMMON.GEO'
6304       include 'COMMON.INTERACT'
6305       include 'COMMON.DERIV'
6306       include 'COMMON.VAR'
6307       include 'COMMON.CHAIN'
6308       include 'COMMON.IOUNITS'
6309       include 'COMMON.NAMES'
6310       include 'COMMON.FFIELD'
6311       include 'COMMON.CONTROL'
6312       include 'COMMON.TORCNSTR'
6313       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6314      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6315      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6316      & sinph1ph2(maxdouble,maxdouble)
6317       logical lprn /.false./, lprn1 /.false./
6318       etheta=0.0D0
6319 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6320       do i=ithet_start,ithet_end
6321 C         if (i.eq.2) cycle
6322 C        if (itype(i-1).eq.ntyp1) cycle
6323         if (i.le.2) cycle
6324         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6325      &  .or.itype(i).eq.ntyp1) cycle
6326         if (iabs(itype(i+1)).eq.20) iblock=2
6327         if (iabs(itype(i+1)).ne.20) iblock=1
6328         dethetai=0.0d0
6329         dephii=0.0d0
6330         dephii1=0.0d0
6331         theti2=0.5d0*theta(i)
6332         ityp2=ithetyp((itype(i-1)))
6333         do k=1,nntheterm
6334           coskt(k)=dcos(k*theti2)
6335           sinkt(k)=dsin(k*theti2)
6336         enddo
6337         if (i.eq.3) then
6338           phii=0.0d0
6339           ityp1=nthetyp+1
6340           do k=1,nsingle
6341             cosph1(k)=0.0d0
6342             sinph1(k)=0.0d0
6343           enddo
6344         else
6345         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6346 #ifdef OSF
6347           phii=phi(i)
6348           if (phii.ne.phii) phii=150.0
6349 #else
6350           phii=phi(i)
6351 #endif
6352           ityp1=ithetyp((itype(i-2)))
6353           do k=1,nsingle
6354             cosph1(k)=dcos(k*phii)
6355             sinph1(k)=dsin(k*phii)
6356           enddo
6357         else
6358           phii=0.0d0
6359 c          ityp1=nthetyp+1
6360           do k=1,nsingle
6361             ityp1=ithetyp((itype(i-2)))
6362             cosph1(k)=0.0d0
6363             sinph1(k)=0.0d0
6364           enddo
6365         endif
6366         endif
6367         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6368 #ifdef OSF
6369           phii1=phi(i+1)
6370           if (phii1.ne.phii1) phii1=150.0
6371           phii1=pinorm(phii1)
6372 #else
6373           phii1=phi(i+1)
6374 #endif
6375           ityp3=ithetyp((itype(i)))
6376           do k=1,nsingle
6377             cosph2(k)=dcos(k*phii1)
6378             sinph2(k)=dsin(k*phii1)
6379           enddo
6380         else
6381           phii1=0.0d0
6382 c          ityp3=nthetyp+1
6383           ityp3=ithetyp((itype(i)))
6384           do k=1,nsingle
6385             cosph2(k)=0.0d0
6386             sinph2(k)=0.0d0
6387           enddo
6388         endif
6389 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6390 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6391 c        call flush(iout)
6392         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6393         do k=1,ndouble
6394           do l=1,k-1
6395             ccl=cosph1(l)*cosph2(k-l)
6396             ssl=sinph1(l)*sinph2(k-l)
6397             scl=sinph1(l)*cosph2(k-l)
6398             csl=cosph1(l)*sinph2(k-l)
6399             cosph1ph2(l,k)=ccl-ssl
6400             cosph1ph2(k,l)=ccl+ssl
6401             sinph1ph2(l,k)=scl+csl
6402             sinph1ph2(k,l)=scl-csl
6403           enddo
6404         enddo
6405         if (lprn) then
6406         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6407      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6408         write (iout,*) "coskt and sinkt"
6409         do k=1,nntheterm
6410           write (iout,*) k,coskt(k),sinkt(k)
6411         enddo
6412         endif
6413         do k=1,ntheterm
6414           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6415           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6416      &      *coskt(k)
6417           if (lprn)
6418      &    write (iout,*) "k",k,"
6419      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6420      &     " ethetai",ethetai
6421         enddo
6422         if (lprn) then
6423         write (iout,*) "cosph and sinph"
6424         do k=1,nsingle
6425           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6426         enddo
6427         write (iout,*) "cosph1ph2 and sinph2ph2"
6428         do k=2,ndouble
6429           do l=1,k-1
6430             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6431      &         sinph1ph2(l,k),sinph1ph2(k,l)
6432           enddo
6433         enddo
6434         write(iout,*) "ethetai",ethetai
6435         endif
6436         do m=1,ntheterm2
6437           do k=1,nsingle
6438             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6439      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6440      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6441      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6442             ethetai=ethetai+sinkt(m)*aux
6443             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6444             dephii=dephii+k*sinkt(m)*(
6445      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6446      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6447             dephii1=dephii1+k*sinkt(m)*(
6448      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6449      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6450             if (lprn)
6451      &      write (iout,*) "m",m," k",k," bbthet",
6452      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6453      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6454      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6455      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6456           enddo
6457         enddo
6458         if (lprn)
6459      &  write(iout,*) "ethetai",ethetai
6460         do m=1,ntheterm3
6461           do k=2,ndouble
6462             do l=1,k-1
6463               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6464      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6465      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6466      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6467               ethetai=ethetai+sinkt(m)*aux
6468               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6469               dephii=dephii+l*sinkt(m)*(
6470      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6471      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6472      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6473      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6474               dephii1=dephii1+(k-l)*sinkt(m)*(
6475      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6476      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6477      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6478      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6479               if (lprn) then
6480               write (iout,*) "m",m," k",k," l",l," ffthet",
6481      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6482      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6483      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6484      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6485      &            " ethetai",ethetai
6486               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6487      &            cosph1ph2(k,l)*sinkt(m),
6488      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6489               endif
6490             enddo
6491           enddo
6492         enddo
6493 10      continue
6494         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6495      &   i,theta(i)*rad2deg,phii*rad2deg,
6496      &   phii1*rad2deg,ethetai
6497         etheta=etheta+ethetai
6498         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6499         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6500 c        gloc(nphi+i-2,icg)=wang*dethetai
6501         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6502       enddo
6503       return
6504       end
6505 #endif
6506 #ifdef CRYST_SC
6507 c-----------------------------------------------------------------------------
6508       subroutine esc(escloc)
6509 C Calculate the local energy of a side chain and its derivatives in the
6510 C corresponding virtual-bond valence angles THETA and the spherical angles
6511 C ALPHA and OMEGA.
6512       implicit real*8 (a-h,o-z)
6513       include 'DIMENSIONS'
6514       include 'DIMENSIONS.ZSCOPT'
6515       include 'COMMON.GEO'
6516       include 'COMMON.LOCAL'
6517       include 'COMMON.VAR'
6518       include 'COMMON.INTERACT'
6519       include 'COMMON.DERIV'
6520       include 'COMMON.CHAIN'
6521       include 'COMMON.IOUNITS'
6522       include 'COMMON.NAMES'
6523       include 'COMMON.FFIELD'
6524       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6525      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6526       common /sccalc/ time11,time12,time112,theti,it,nlobit
6527       delta=0.02d0*pi
6528       escloc=0.0D0
6529 C      write (iout,*) 'ESC'
6530       do i=loc_start,loc_end
6531         it=itype(i)
6532         if (it.eq.ntyp1) cycle
6533         if (it.eq.10) goto 1
6534         nlobit=nlob(iabs(it))
6535 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6536 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6537         theti=theta(i+1)-pipol
6538         x(1)=dtan(theti)
6539         x(2)=alph(i)
6540         x(3)=omeg(i)
6541 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6542
6543         if (x(2).gt.pi-delta) then
6544           xtemp(1)=x(1)
6545           xtemp(2)=pi-delta
6546           xtemp(3)=x(3)
6547           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6548           xtemp(2)=pi
6549           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6550           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6551      &        escloci,dersc(2))
6552           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6553      &        ddersc0(1),dersc(1))
6554           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6555      &        ddersc0(3),dersc(3))
6556           xtemp(2)=pi-delta
6557           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6558           xtemp(2)=pi
6559           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6560           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6561      &            dersc0(2),esclocbi,dersc02)
6562           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6563      &            dersc12,dersc01)
6564           call splinthet(x(2),0.5d0*delta,ss,ssd)
6565           dersc0(1)=dersc01
6566           dersc0(2)=dersc02
6567           dersc0(3)=0.0d0
6568           do k=1,3
6569             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6570           enddo
6571           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6572           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6573      &             esclocbi,ss,ssd
6574           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6575 c         escloci=esclocbi
6576 c         write (iout,*) escloci
6577         else if (x(2).lt.delta) then
6578           xtemp(1)=x(1)
6579           xtemp(2)=delta
6580           xtemp(3)=x(3)
6581           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6582           xtemp(2)=0.0d0
6583           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6584           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6585      &        escloci,dersc(2))
6586           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6587      &        ddersc0(1),dersc(1))
6588           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6589      &        ddersc0(3),dersc(3))
6590           xtemp(2)=delta
6591           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6592           xtemp(2)=0.0d0
6593           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6594           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6595      &            dersc0(2),esclocbi,dersc02)
6596           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6597      &            dersc12,dersc01)
6598           dersc0(1)=dersc01
6599           dersc0(2)=dersc02
6600           dersc0(3)=0.0d0
6601           call splinthet(x(2),0.5d0*delta,ss,ssd)
6602           do k=1,3
6603             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6604           enddo
6605           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6606 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6607 c     &             esclocbi,ss,ssd
6608           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6609 C         write (iout,*) 'i=',i, escloci
6610         else
6611           call enesc(x,escloci,dersc,ddummy,.false.)
6612         endif
6613
6614         escloc=escloc+escloci
6615 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6616             write (iout,'(a6,i5,0pf7.3)')
6617      &     'escloc',i,escloci
6618
6619         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6620      &   wscloc*dersc(1)
6621         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6622         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6623     1   continue
6624       enddo
6625       return
6626       end
6627 C---------------------------------------------------------------------------
6628       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6629       implicit real*8 (a-h,o-z)
6630       include 'DIMENSIONS'
6631       include 'COMMON.GEO'
6632       include 'COMMON.LOCAL'
6633       include 'COMMON.IOUNITS'
6634       common /sccalc/ time11,time12,time112,theti,it,nlobit
6635       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6636       double precision contr(maxlob,-1:1)
6637       logical mixed
6638 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6639         escloc_i=0.0D0
6640         do j=1,3
6641           dersc(j)=0.0D0
6642           if (mixed) ddersc(j)=0.0d0
6643         enddo
6644         x3=x(3)
6645
6646 C Because of periodicity of the dependence of the SC energy in omega we have
6647 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6648 C To avoid underflows, first compute & store the exponents.
6649
6650         do iii=-1,1
6651
6652           x(3)=x3+iii*dwapi
6653
6654           do j=1,nlobit
6655             do k=1,3
6656               z(k)=x(k)-censc(k,j,it)
6657             enddo
6658             do k=1,3
6659               Axk=0.0D0
6660               do l=1,3
6661                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6662               enddo
6663               Ax(k,j,iii)=Axk
6664             enddo
6665             expfac=0.0D0
6666             do k=1,3
6667               expfac=expfac+Ax(k,j,iii)*z(k)
6668             enddo
6669             contr(j,iii)=expfac
6670           enddo ! j
6671
6672         enddo ! iii
6673
6674         x(3)=x3
6675 C As in the case of ebend, we want to avoid underflows in exponentiation and
6676 C subsequent NaNs and INFs in energy calculation.
6677 C Find the largest exponent
6678         emin=contr(1,-1)
6679         do iii=-1,1
6680           do j=1,nlobit
6681             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6682           enddo
6683         enddo
6684         emin=0.5D0*emin
6685 cd      print *,'it=',it,' emin=',emin
6686
6687 C Compute the contribution to SC energy and derivatives
6688         do iii=-1,1
6689
6690           do j=1,nlobit
6691             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6692 cd          print *,'j=',j,' expfac=',expfac
6693             escloc_i=escloc_i+expfac
6694             do k=1,3
6695               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6696             enddo
6697             if (mixed) then
6698               do k=1,3,2
6699                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6700      &            +gaussc(k,2,j,it))*expfac
6701               enddo
6702             endif
6703           enddo
6704
6705         enddo ! iii
6706
6707         dersc(1)=dersc(1)/cos(theti)**2
6708         ddersc(1)=ddersc(1)/cos(theti)**2
6709         ddersc(3)=ddersc(3)
6710
6711         escloci=-(dlog(escloc_i)-emin)
6712         do j=1,3
6713           dersc(j)=dersc(j)/escloc_i
6714         enddo
6715         if (mixed) then
6716           do j=1,3,2
6717             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6718           enddo
6719         endif
6720       return
6721       end
6722 C------------------------------------------------------------------------------
6723       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6724       implicit real*8 (a-h,o-z)
6725       include 'DIMENSIONS'
6726       include 'COMMON.GEO'
6727       include 'COMMON.LOCAL'
6728       include 'COMMON.IOUNITS'
6729       common /sccalc/ time11,time12,time112,theti,it,nlobit
6730       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6731       double precision contr(maxlob)
6732       logical mixed
6733
6734       escloc_i=0.0D0
6735
6736       do j=1,3
6737         dersc(j)=0.0D0
6738       enddo
6739
6740       do j=1,nlobit
6741         do k=1,2
6742           z(k)=x(k)-censc(k,j,it)
6743         enddo
6744         z(3)=dwapi
6745         do k=1,3
6746           Axk=0.0D0
6747           do l=1,3
6748             Axk=Axk+gaussc(l,k,j,it)*z(l)
6749           enddo
6750           Ax(k,j)=Axk
6751         enddo
6752         expfac=0.0D0
6753         do k=1,3
6754           expfac=expfac+Ax(k,j)*z(k)
6755         enddo
6756         contr(j)=expfac
6757       enddo ! j
6758
6759 C As in the case of ebend, we want to avoid underflows in exponentiation and
6760 C subsequent NaNs and INFs in energy calculation.
6761 C Find the largest exponent
6762       emin=contr(1)
6763       do j=1,nlobit
6764         if (emin.gt.contr(j)) emin=contr(j)
6765       enddo
6766       emin=0.5D0*emin
6767
6768 C Compute the contribution to SC energy and derivatives
6769
6770       dersc12=0.0d0
6771       do j=1,nlobit
6772         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6773         escloc_i=escloc_i+expfac
6774         do k=1,2
6775           dersc(k)=dersc(k)+Ax(k,j)*expfac
6776         enddo
6777         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6778      &            +gaussc(1,2,j,it))*expfac
6779         dersc(3)=0.0d0
6780       enddo
6781
6782       dersc(1)=dersc(1)/cos(theti)**2
6783       dersc12=dersc12/cos(theti)**2
6784       escloci=-(dlog(escloc_i)-emin)
6785       do j=1,2
6786         dersc(j)=dersc(j)/escloc_i
6787       enddo
6788       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6789       return
6790       end
6791 #else
6792 c----------------------------------------------------------------------------------
6793       subroutine esc(escloc)
6794 C Calculate the local energy of a side chain and its derivatives in the
6795 C corresponding virtual-bond valence angles THETA and the spherical angles
6796 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6797 C added by Urszula Kozlowska. 07/11/2007
6798 C
6799       implicit real*8 (a-h,o-z)
6800       include 'DIMENSIONS'
6801       include 'DIMENSIONS.ZSCOPT'
6802       include 'COMMON.GEO'
6803       include 'COMMON.LOCAL'
6804       include 'COMMON.VAR'
6805       include 'COMMON.SCROT'
6806       include 'COMMON.INTERACT'
6807       include 'COMMON.DERIV'
6808       include 'COMMON.CHAIN'
6809       include 'COMMON.IOUNITS'
6810       include 'COMMON.NAMES'
6811       include 'COMMON.FFIELD'
6812       include 'COMMON.CONTROL'
6813       include 'COMMON.VECTORS'
6814       double precision x_prime(3),y_prime(3),z_prime(3)
6815      &    , sumene,dsc_i,dp2_i,x(65),
6816      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6817      &    de_dxx,de_dyy,de_dzz,de_dt
6818       double precision s1_t,s1_6_t,s2_t,s2_6_t
6819       double precision
6820      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6821      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6822      & dt_dCi(3),dt_dCi1(3)
6823       common /sccalc/ time11,time12,time112,theti,it,nlobit
6824       delta=0.02d0*pi
6825       escloc=0.0D0
6826       do i=loc_start,loc_end
6827         if (itype(i).eq.ntyp1) cycle
6828         costtab(i+1) =dcos(theta(i+1))
6829         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6830         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6831         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6832         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6833         cosfac=dsqrt(cosfac2)
6834         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6835         sinfac=dsqrt(sinfac2)
6836         it=iabs(itype(i))
6837         if (it.eq.10) goto 1
6838 c
6839 C  Compute the axes of tghe local cartesian coordinates system; store in
6840 c   x_prime, y_prime and z_prime
6841 c
6842         do j=1,3
6843           x_prime(j) = 0.00
6844           y_prime(j) = 0.00
6845           z_prime(j) = 0.00
6846         enddo
6847 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6848 C     &   dc_norm(3,i+nres)
6849         do j = 1,3
6850           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6851           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6852         enddo
6853         do j = 1,3
6854           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6855         enddo
6856 c       write (2,*) "i",i
6857 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6858 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6859 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6860 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6861 c      & " xy",scalar(x_prime(1),y_prime(1)),
6862 c      & " xz",scalar(x_prime(1),z_prime(1)),
6863 c      & " yy",scalar(y_prime(1),y_prime(1)),
6864 c      & " yz",scalar(y_prime(1),z_prime(1)),
6865 c      & " zz",scalar(z_prime(1),z_prime(1))
6866 c
6867 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6868 C to local coordinate system. Store in xx, yy, zz.
6869 c
6870         xx=0.0d0
6871         yy=0.0d0
6872         zz=0.0d0
6873         do j = 1,3
6874           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6875           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6876           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6877         enddo
6878
6879         xxtab(i)=xx
6880         yytab(i)=yy
6881         zztab(i)=zz
6882 C
6883 C Compute the energy of the ith side cbain
6884 C
6885 c        write (2,*) "xx",xx," yy",yy," zz",zz
6886         it=iabs(itype(i))
6887         do j = 1,65
6888           x(j) = sc_parmin(j,it)
6889         enddo
6890 #ifdef CHECK_COORD
6891 Cc diagnostics - remove later
6892         xx1 = dcos(alph(2))
6893         yy1 = dsin(alph(2))*dcos(omeg(2))
6894         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6895         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6896      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6897      &    xx1,yy1,zz1
6898 C,"  --- ", xx_w,yy_w,zz_w
6899 c end diagnostics
6900 #endif
6901         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6902      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6903      &   + x(10)*yy*zz
6904         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6905      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6906      & + x(20)*yy*zz
6907         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6908      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6909      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6910      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6911      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6912      &  +x(40)*xx*yy*zz
6913         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6914      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6915      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6916      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6917      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6918      &  +x(60)*xx*yy*zz
6919         dsc_i   = 0.743d0+x(61)
6920         dp2_i   = 1.9d0+x(62)
6921         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6922      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6923         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6924      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6925         s1=(1+x(63))/(0.1d0 + dscp1)
6926         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6927         s2=(1+x(65))/(0.1d0 + dscp2)
6928         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6929         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6930      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6931 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6932 c     &   sumene4,
6933 c     &   dscp1,dscp2,sumene
6934 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6935         escloc = escloc + sumene
6936 c        write (2,*) "escloc",escloc
6937 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6938 c     &  zz,xx,yy
6939         if (.not. calc_grad) goto 1
6940 #ifdef DEBUG
6941 C
6942 C This section to check the numerical derivatives of the energy of ith side
6943 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6944 C #define DEBUG in the code to turn it on.
6945 C
6946         write (2,*) "sumene               =",sumene
6947         aincr=1.0d-7
6948         xxsave=xx
6949         xx=xx+aincr
6950         write (2,*) xx,yy,zz
6951         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6952         de_dxx_num=(sumenep-sumene)/aincr
6953         xx=xxsave
6954         write (2,*) "xx+ sumene from enesc=",sumenep
6955         yysave=yy
6956         yy=yy+aincr
6957         write (2,*) xx,yy,zz
6958         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6959         de_dyy_num=(sumenep-sumene)/aincr
6960         yy=yysave
6961         write (2,*) "yy+ sumene from enesc=",sumenep
6962         zzsave=zz
6963         zz=zz+aincr
6964         write (2,*) xx,yy,zz
6965         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6966         de_dzz_num=(sumenep-sumene)/aincr
6967         zz=zzsave
6968         write (2,*) "zz+ sumene from enesc=",sumenep
6969         costsave=cost2tab(i+1)
6970         sintsave=sint2tab(i+1)
6971         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6972         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6973         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6974         de_dt_num=(sumenep-sumene)/aincr
6975         write (2,*) " t+ sumene from enesc=",sumenep
6976         cost2tab(i+1)=costsave
6977         sint2tab(i+1)=sintsave
6978 C End of diagnostics section.
6979 #endif
6980 C
6981 C Compute the gradient of esc
6982 C
6983         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6984         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6985         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6986         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6987         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6988         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6989         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6990         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6991         pom1=(sumene3*sint2tab(i+1)+sumene1)
6992      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6993         pom2=(sumene4*cost2tab(i+1)+sumene2)
6994      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6995         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6996         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6997      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6998      &  +x(40)*yy*zz
6999         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7000         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7001      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7002      &  +x(60)*yy*zz
7003         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7004      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7005      &        +(pom1+pom2)*pom_dx
7006 #ifdef DEBUG
7007         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
7008 #endif
7009 C
7010         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7011         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7012      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7013      &  +x(40)*xx*zz
7014         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7015         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7016      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7017      &  +x(59)*zz**2 +x(60)*xx*zz
7018         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7019      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7020      &        +(pom1-pom2)*pom_dy
7021 #ifdef DEBUG
7022         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
7023 #endif
7024 C
7025         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7026      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7027      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7028      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7029      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7030      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7031      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7032      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7033 #ifdef DEBUG
7034         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
7035 #endif
7036 C
7037         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7038      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7039      &  +pom1*pom_dt1+pom2*pom_dt2
7040 #ifdef DEBUG
7041         write(2,*), "de_dt = ", de_dt,de_dt_num
7042 #endif
7043 c
7044 C
7045        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7046        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7047        cosfac2xx=cosfac2*xx
7048        sinfac2yy=sinfac2*yy
7049        do k = 1,3
7050          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7051      &      vbld_inv(i+1)
7052          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7053      &      vbld_inv(i)
7054          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7055          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7056 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7057 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7058 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7059 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7060          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7061          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7062          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7063          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7064          dZZ_Ci1(k)=0.0d0
7065          dZZ_Ci(k)=0.0d0
7066          do j=1,3
7067            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7068      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7069            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7070      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7071          enddo
7072
7073          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7074          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7075          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
7076 c
7077          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7078          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7079        enddo
7080
7081        do k=1,3
7082          dXX_Ctab(k,i)=dXX_Ci(k)
7083          dXX_C1tab(k,i)=dXX_Ci1(k)
7084          dYY_Ctab(k,i)=dYY_Ci(k)
7085          dYY_C1tab(k,i)=dYY_Ci1(k)
7086          dZZ_Ctab(k,i)=dZZ_Ci(k)
7087          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7088          dXX_XYZtab(k,i)=dXX_XYZ(k)
7089          dYY_XYZtab(k,i)=dYY_XYZ(k)
7090          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7091        enddo
7092
7093        do k = 1,3
7094 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7095 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7096 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7097 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7098 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7099 c     &    dt_dci(k)
7100 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7101 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7102          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7103      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7104          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7105      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7106          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7107      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7108        enddo
7109 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7110 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7111
7112 C to check gradient call subroutine check_grad
7113
7114     1 continue
7115       enddo
7116       return
7117       end
7118 #endif
7119 c------------------------------------------------------------------------------
7120       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7121 C
7122 C This procedure calculates two-body contact function g(rij) and its derivative:
7123 C
7124 C           eps0ij                                     !       x < -1
7125 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7126 C            0                                         !       x > 1
7127 C
7128 C where x=(rij-r0ij)/delta
7129 C
7130 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7131 C
7132       implicit none
7133       double precision rij,r0ij,eps0ij,fcont,fprimcont
7134       double precision x,x2,x4,delta
7135 c     delta=0.02D0*r0ij
7136 c      delta=0.2D0*r0ij
7137       x=(rij-r0ij)/delta
7138       if (x.lt.-1.0D0) then
7139         fcont=eps0ij
7140         fprimcont=0.0D0
7141       else if (x.le.1.0D0) then
7142         x2=x*x
7143         x4=x2*x2
7144         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7145         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7146       else
7147         fcont=0.0D0
7148         fprimcont=0.0D0
7149       endif
7150       return
7151       end
7152 c------------------------------------------------------------------------------
7153       subroutine splinthet(theti,delta,ss,ssder)
7154       implicit real*8 (a-h,o-z)
7155       include 'DIMENSIONS'
7156       include 'DIMENSIONS.ZSCOPT'
7157       include 'COMMON.VAR'
7158       include 'COMMON.GEO'
7159       thetup=pi-delta
7160       thetlow=delta
7161       if (theti.gt.pipol) then
7162         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7163       else
7164         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7165         ssder=-ssder
7166       endif
7167       return
7168       end
7169 c------------------------------------------------------------------------------
7170       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7171       implicit none
7172       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7173       double precision ksi,ksi2,ksi3,a1,a2,a3
7174       a1=fprim0*delta/(f1-f0)
7175       a2=3.0d0-2.0d0*a1
7176       a3=a1-2.0d0
7177       ksi=(x-x0)/delta
7178       ksi2=ksi*ksi
7179       ksi3=ksi2*ksi
7180       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7181       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7182       return
7183       end
7184 c------------------------------------------------------------------------------
7185       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7186       implicit none
7187       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7188       double precision ksi,ksi2,ksi3,a1,a2,a3
7189       ksi=(x-x0)/delta
7190       ksi2=ksi*ksi
7191       ksi3=ksi2*ksi
7192       a1=fprim0x*delta
7193       a2=3*(f1x-f0x)-2*fprim0x*delta
7194       a3=fprim0x*delta-2*(f1x-f0x)
7195       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7196       return
7197       end
7198 C-----------------------------------------------------------------------------
7199 #ifdef CRYST_TOR
7200 C-----------------------------------------------------------------------------
7201       subroutine etor(etors)
7202       implicit real*8 (a-h,o-z)
7203       include 'DIMENSIONS'
7204       include 'DIMENSIONS.ZSCOPT'
7205       include 'COMMON.VAR'
7206       include 'COMMON.GEO'
7207       include 'COMMON.LOCAL'
7208       include 'COMMON.TORSION'
7209       include 'COMMON.INTERACT'
7210       include 'COMMON.DERIV'
7211       include 'COMMON.CHAIN'
7212       include 'COMMON.NAMES'
7213       include 'COMMON.IOUNITS'
7214       include 'COMMON.FFIELD'
7215       include 'COMMON.TORCNSTR'
7216       logical lprn
7217 C Set lprn=.true. for debugging
7218       lprn=.false.
7219 c      lprn=.true.
7220       etors=0.0D0
7221       do i=iphi_start,iphi_end
7222         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7223      &      .or. itype(i).eq.ntyp1) cycle
7224         itori=itortyp(itype(i-2))
7225         itori1=itortyp(itype(i-1))
7226         phii=phi(i)
7227         gloci=0.0D0
7228 C Proline-Proline pair is a special case...
7229         if (itori.eq.3 .and. itori1.eq.3) then
7230           if (phii.gt.-dwapi3) then
7231             cosphi=dcos(3*phii)
7232             fac=1.0D0/(1.0D0-cosphi)
7233             etorsi=v1(1,3,3)*fac
7234             etorsi=etorsi+etorsi
7235             etors=etors+etorsi-v1(1,3,3)
7236             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7237           endif
7238           do j=1,3
7239             v1ij=v1(j+1,itori,itori1)
7240             v2ij=v2(j+1,itori,itori1)
7241             cosphi=dcos(j*phii)
7242             sinphi=dsin(j*phii)
7243             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7244             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7245           enddo
7246         else
7247           do j=1,nterm_old
7248             v1ij=v1(j,itori,itori1)
7249             v2ij=v2(j,itori,itori1)
7250             cosphi=dcos(j*phii)
7251             sinphi=dsin(j*phii)
7252             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7253             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7254           enddo
7255         endif
7256         if (lprn)
7257      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7258      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7259      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7260         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7261 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7262       enddo
7263       return
7264       end
7265 c------------------------------------------------------------------------------
7266 #else
7267       subroutine etor(etors)
7268       implicit real*8 (a-h,o-z)
7269       include 'DIMENSIONS'
7270       include 'DIMENSIONS.ZSCOPT'
7271       include 'COMMON.VAR'
7272       include 'COMMON.GEO'
7273       include 'COMMON.LOCAL'
7274       include 'COMMON.TORSION'
7275       include 'COMMON.INTERACT'
7276       include 'COMMON.DERIV'
7277       include 'COMMON.CHAIN'
7278       include 'COMMON.NAMES'
7279       include 'COMMON.IOUNITS'
7280       include 'COMMON.FFIELD'
7281       include 'COMMON.TORCNSTR'
7282       include 'COMMON.WEIGHTS'
7283       include 'COMMON.WEIGHTDER'
7284       logical lprn
7285 C Set lprn=.true. for debugging
7286       lprn=.false.
7287 c      lprn=.true.
7288       etors=0.0D0
7289       do iblock=1,2
7290       do i=-ntyp+1,ntyp-1
7291         do j=-ntyp+1,ntyp-1
7292           do k=0,3
7293             do l=0,2*maxterm
7294               etor_temp(l,k,j,i,iblock)=0.0d0
7295             enddo
7296           enddo
7297         enddo
7298       enddo
7299       enddo
7300       do i=iphi_start,iphi_end
7301         if (i.le.2) cycle
7302         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7303      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7304         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7305         if (iabs(itype(i)).eq.20) then
7306           iblock=2
7307         else
7308           iblock=1
7309         endif
7310         itori=itortyp(itype(i-2))
7311         itori1=itortyp(itype(i-1))
7312         weitori=weitor(0,itori,itori1,iblock)
7313         phii=phi(i)
7314         gloci=0.0D0
7315         etori=0.0d0
7316 C Regular cosine and sine terms
7317         do j=1,nterm(itori,itori1,iblock)
7318           v1ij=v1(j,itori,itori1,iblock)
7319           v2ij=v2(j,itori,itori1,iblock)
7320           cosphi=dcos(j*phii)
7321           sinphi=dsin(j*phii)
7322           etori=etori+v1ij*cosphi+v2ij*sinphi
7323           etor_temp(j,0,itori,itori1,iblock)=
7324      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7325           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7326      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7327      &      sinphi*ww(13)
7328           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7329         enddo
7330 C Lorentz terms
7331 C                         v1
7332 C  E = SUM ----------------------------------- - v1
7333 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7334 C
7335         cosphi=dcos(0.5d0*phii)
7336         sinphi=dsin(0.5d0*phii)
7337         do j=1,nlor(itori,itori1,iblock)
7338           vl1ij=vlor1(j,itori,itori1)
7339           vl2ij=vlor2(j,itori,itori1)
7340           vl3ij=vlor3(j,itori,itori1)
7341           pom=vl2ij*cosphi+vl3ij*sinphi
7342           pom1=1.0d0/(pom*pom+1.0d0)
7343           etori=etori+vl1ij*pom1
7344           pom=-pom*pom1*pom1
7345           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7346         enddo
7347 C Subtract the constant term
7348         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7349         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7350      &    (etori-v0(itori,itori1,iblock))*ww(13)
7351
7352         if (lprn) then
7353         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7354      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7355      &  weitori,v0(itori,itori1,iblock)*weitori,
7356      &  (v1(j,itori,itori1,iblock)*weitori,
7357      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7358         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7359      &    iloctyp(itori1)," etor_temp",
7360      &    etor_temp(0,0,itori,itori1,1)
7361         call flush(iout)
7362         endif
7363         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7364 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7365  1215   continue
7366       enddo
7367       return
7368       end
7369 c----------------------------------------------------------------------------
7370       subroutine etor_d(etors_d)
7371 C 6/23/01 Compute double torsional energy
7372       implicit real*8 (a-h,o-z)
7373       include 'DIMENSIONS'
7374       include 'DIMENSIONS.ZSCOPT'
7375       include 'COMMON.VAR'
7376       include 'COMMON.GEO'
7377       include 'COMMON.LOCAL'
7378       include 'COMMON.TORSION'
7379       include 'COMMON.INTERACT'
7380       include 'COMMON.DERIV'
7381       include 'COMMON.CHAIN'
7382       include 'COMMON.NAMES'
7383       include 'COMMON.IOUNITS'
7384       include 'COMMON.FFIELD'
7385       include 'COMMON.TORCNSTR'
7386       logical lprn
7387 C Set lprn=.true. for debugging
7388       lprn=.false.
7389 c     lprn=.true.
7390       etors_d=0.0D0
7391       do i=iphi_start,iphi_end-1
7392         if (i.le.3) cycle
7393 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7394 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7395          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7396      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7397      &  (itype(i+1).eq.ntyp1)) cycle
7398         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7399      &     goto 1215
7400         itori=itortyp(itype(i-2))
7401         itori1=itortyp(itype(i-1))
7402         itori2=itortyp(itype(i))
7403         phii=phi(i)
7404         phii1=phi(i+1)
7405         gloci1=0.0D0
7406         gloci2=0.0D0
7407         iblock=1
7408         if (iabs(itype(i+1)).eq.20) iblock=2
7409 C Regular cosine and sine terms
7410         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7411           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7412           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7413           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7414           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7415           cosphi1=dcos(j*phii)
7416           sinphi1=dsin(j*phii)
7417           cosphi2=dcos(j*phii1)
7418           sinphi2=dsin(j*phii1)
7419           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7420      &     v2cij*cosphi2+v2sij*sinphi2
7421           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7422           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7423         enddo
7424         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7425           do l=1,k-1
7426             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7427             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7428             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7429             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7430             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7431             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7432             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7433             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7434             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7435      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7436             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7437      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7438             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7439      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7440           enddo
7441         enddo
7442         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7443         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7444  1215   continue
7445       enddo
7446       return
7447       end
7448 #endif
7449 c---------------------------------------------------------------------------
7450 C The rigorous attempt to derive energy function
7451       subroutine etor_kcc(etors)
7452       implicit real*8 (a-h,o-z)
7453       include 'DIMENSIONS'
7454       include 'DIMENSIONS.ZSCOPT'
7455       include 'COMMON.VAR'
7456       include 'COMMON.GEO'
7457       include 'COMMON.LOCAL'
7458       include 'COMMON.TORSION'
7459       include 'COMMON.INTERACT'
7460       include 'COMMON.DERIV'
7461       include 'COMMON.CHAIN'
7462       include 'COMMON.NAMES'
7463       include 'COMMON.IOUNITS'
7464       include 'COMMON.FFIELD'
7465       include 'COMMON.TORCNSTR'
7466       include 'COMMON.CONTROL'
7467       include 'COMMON.WEIGHTS'
7468       include 'COMMON.WEIGHTDER'
7469       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7470       logical lprn
7471 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7472 C Set lprn=.true. for debugging
7473       lprn=energy_dec
7474 c      lprn=.true.
7475       if (lprn) write (iout,*)"ETOR_KCC"
7476       do iblock=1,2
7477       do i=-ntyp+1,ntyp-1
7478         do j=-ntyp+1,ntyp-1
7479           do k=0,3
7480             do l=0,2*maxterm
7481               etor_temp(l,k,j,i,iblock)=0.0d0
7482             enddo
7483           enddo
7484         enddo
7485       enddo
7486       enddo
7487       do i=-ntyp+1,ntyp-1
7488         do j=-ntyp+1,ntyp-1
7489           do k=0,2*maxtor_kcc
7490             do l=1,maxval_kcc
7491               do ll=1,maxval_kcc
7492                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7493               enddo
7494             enddo
7495           enddo
7496         enddo
7497       enddo
7498       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7499       etors=0.0D0
7500       do i=iphi_start,iphi_end
7501 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7502 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7503 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7504 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7505         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7506      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7507         itori=itortyp(itype(i-2))
7508         itori1=itortyp(itype(i-1))
7509         weitori=weitor(0,itori,itori1,1)
7510         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7511         phii=phi(i)
7512         glocig=0.0D0
7513         glocit1=0.0d0
7514         glocit2=0.0d0
7515 C to avoid multiple devision by 2
7516 c        theti22=0.5d0*theta(i)
7517 C theta 12 is the theta_1 /2
7518 C theta 22 is theta_2 /2
7519 c        theti12=0.5d0*theta(i-1)
7520 C and appropriate sinus function
7521         sinthet1=dsin(theta(i-1))
7522         sinthet2=dsin(theta(i))
7523         costhet1=dcos(theta(i-1))
7524         costhet2=dcos(theta(i))
7525 C to speed up lets store its mutliplication
7526         sint1t2=sinthet2*sinthet1
7527         sint1t2n=1.0d0
7528 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7529 C +d_n*sin(n*gamma)) *
7530 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7531 C we have two sum 1) Non-Chebyshev which is with n and gamma
7532         nval=nterm_kcc_Tb(itori,itori1)
7533         c1(0)=0.0d0
7534         c2(0)=0.0d0
7535         c1(1)=1.0d0
7536         c2(1)=1.0d0
7537         do j=2,nval
7538           c1(j)=c1(j-1)*costhet1
7539           c2(j)=c2(j-1)*costhet2
7540         enddo
7541         etori=0.0d0
7542         do j=1,nterm_kcc(itori,itori1)
7543           cosphi=dcos(j*phii)
7544           sinphi=dsin(j*phii)
7545           sint1t2n1=sint1t2n
7546           sint1t2n=sint1t2n*sint1t2
7547           sumvalc=0.0d0
7548           gradvalct1=0.0d0
7549           gradvalct2=0.0d0
7550           do k=1,nval
7551             do l=1,nval
7552               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7553               etor_temp_kcc(l,k,j,itori,itori1)=
7554      &           etor_temp_kcc(l,k,j,itori,itori1)+
7555      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7556               gradvalct1=gradvalct1+
7557      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7558               gradvalct2=gradvalct2+
7559      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7560             enddo
7561           enddo
7562           gradvalct1=-gradvalct1*sinthet1
7563           gradvalct2=-gradvalct2*sinthet2
7564           sumvals=0.0d0
7565           gradvalst1=0.0d0
7566           gradvalst2=0.0d0
7567           do k=1,nval
7568             do l=1,nval
7569               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7570               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7571      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7572      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7573               gradvalst1=gradvalst1+
7574      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7575               gradvalst2=gradvalst2+
7576      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7577             enddo
7578           enddo
7579           gradvalst1=-gradvalst1*sinthet1
7580           gradvalst2=-gradvalst2*sinthet2
7581           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7582           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7583      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7584 C glocig is the gradient local i site in gamma
7585           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7586 C now gradient over theta_1
7587           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7588      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7589           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7590      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7591         enddo ! j
7592         etors=etors+etori*weitori
7593 C derivative over gamma
7594         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7595 C derivative over theta1
7596         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7597 C now derivative over theta2
7598         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7599         if (lprn)
7600      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7601      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7602       enddo
7603       return
7604       end
7605 c---------------------------------------------------------------------------------------------
7606       subroutine etor_constr(edihcnstr)
7607       implicit real*8 (a-h,o-z)
7608       include 'DIMENSIONS'
7609       include 'DIMENSIONS.ZSCOPT'
7610       include 'COMMON.VAR'
7611       include 'COMMON.GEO'
7612       include 'COMMON.LOCAL'
7613       include 'COMMON.TORSION'
7614       include 'COMMON.INTERACT'
7615       include 'COMMON.DERIV'
7616       include 'COMMON.CHAIN'
7617       include 'COMMON.NAMES'
7618       include 'COMMON.IOUNITS'
7619       include 'COMMON.FFIELD'
7620       include 'COMMON.TORCNSTR'
7621       include 'COMMON.CONTROL'
7622 ! 6/20/98 - dihedral angle constraints
7623       edihcnstr=0.0d0
7624 c      do i=1,ndih_constr
7625 c      write (iout,*) "idihconstr_start",idihconstr_start,
7626 c     &  " idihconstr_end",idihconstr_end
7627       do i=idihconstr_start,idihconstr_end
7628         itori=idih_constr(i)
7629         phii=phi(itori)
7630         difi=pinorm(phii-phi0(i))
7631         if (difi.gt.drange(i)) then
7632           difi=difi-drange(i)
7633           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7634           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7635         else if (difi.lt.-drange(i)) then
7636           difi=difi+drange(i)
7637           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7638           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7639         else
7640           difi=0.0
7641         endif
7642       enddo
7643       return
7644       end
7645 c----------------------------------------------------------------------------
7646 C The rigorous attempt to derive energy function
7647       subroutine ebend_kcc(etheta)
7648
7649       implicit real*8 (a-h,o-z)
7650       include 'DIMENSIONS'
7651       include 'DIMENSIONS.ZSCOPT'
7652       include 'COMMON.VAR'
7653       include 'COMMON.GEO'
7654       include 'COMMON.LOCAL'
7655       include 'COMMON.TORSION'
7656       include 'COMMON.INTERACT'
7657       include 'COMMON.DERIV'
7658       include 'COMMON.CHAIN'
7659       include 'COMMON.NAMES'
7660       include 'COMMON.IOUNITS'
7661       include 'COMMON.FFIELD'
7662       include 'COMMON.TORCNSTR'
7663       include 'COMMON.CONTROL'
7664       include 'COMMON.WEIGHTDER'
7665       logical lprn
7666       double precision thybt1(maxang_kcc)
7667 C Set lprn=.true. for debugging
7668       lprn=energy_dec
7669 c     lprn=.true.
7670 C      print *,"wchodze kcc"
7671       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7672       do i=0,ntyp
7673         do j=1,maxang_kcc
7674           ebend_temp_kcc(j,i)=0.0d0
7675         enddo
7676       enddo
7677       etheta=0.0D0
7678       do i=ithet_start,ithet_end
7679 c        print *,i,itype(i-1),itype(i),itype(i-2)
7680         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7681      &  .or.itype(i).eq.ntyp1) cycle
7682         iti=iabs(itortyp(itype(i-1)))
7683         sinthet=dsin(theta(i))
7684         costhet=dcos(theta(i))
7685         do j=1,nbend_kcc_Tb(iti)
7686           thybt1(j)=v1bend_chyb(j,iti)
7687           ebend_temp_kcc(j,iabs(iti))=
7688      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7689         enddo
7690         sumth1thyb=v1bend_chyb(0,iti)+
7691      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7692         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7693      &    sumth1thyb
7694         ihelp=nbend_kcc_Tb(iti)-1
7695         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7696         etheta=etheta+sumth1thyb
7697 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7698         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7699       enddo
7700       return
7701       end
7702 c-------------------------------------------------------------------------------------
7703       subroutine etheta_constr(ethetacnstr)
7704
7705       implicit real*8 (a-h,o-z)
7706       include 'DIMENSIONS'
7707       include 'DIMENSIONS.ZSCOPT'
7708       include 'COMMON.VAR'
7709       include 'COMMON.GEO'
7710       include 'COMMON.LOCAL'
7711       include 'COMMON.TORSION'
7712       include 'COMMON.INTERACT'
7713       include 'COMMON.DERIV'
7714       include 'COMMON.CHAIN'
7715       include 'COMMON.NAMES'
7716       include 'COMMON.IOUNITS'
7717       include 'COMMON.FFIELD'
7718       include 'COMMON.TORCNSTR'
7719       include 'COMMON.CONTROL'
7720       ethetacnstr=0.0d0
7721 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7722       do i=ithetaconstr_start,ithetaconstr_end
7723         itheta=itheta_constr(i)
7724         thetiii=theta(itheta)
7725         difi=pinorm(thetiii-theta_constr0(i))
7726         if (difi.gt.theta_drange(i)) then
7727           difi=difi-theta_drange(i)
7728           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7729           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7730      &    +for_thet_constr(i)*difi**3
7731         else if (difi.lt.-drange(i)) then
7732           difi=difi+drange(i)
7733           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7734           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7735      &    +for_thet_constr(i)*difi**3
7736         else
7737           difi=0.0
7738         endif
7739        if (energy_dec) then
7740         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7741      &    i,itheta,rad2deg*thetiii,
7742      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7743      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7744      &    gloc(itheta+nphi-2,icg)
7745         endif
7746       enddo
7747       return
7748       end
7749 c------------------------------------------------------------------------------
7750       subroutine eback_sc_corr(esccor)
7751 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7752 c        conformational states; temporarily implemented as differences
7753 c        between UNRES torsional potentials (dependent on three types of
7754 c        residues) and the torsional potentials dependent on all 20 types
7755 c        of residues computed from AM1 energy surfaces of terminally-blocked
7756 c        amino-acid residues.
7757       implicit real*8 (a-h,o-z)
7758       include 'DIMENSIONS'
7759       include 'DIMENSIONS.ZSCOPT'
7760       include 'COMMON.VAR'
7761       include 'COMMON.GEO'
7762       include 'COMMON.LOCAL'
7763       include 'COMMON.TORSION'
7764       include 'COMMON.SCCOR'
7765       include 'COMMON.INTERACT'
7766       include 'COMMON.DERIV'
7767       include 'COMMON.CHAIN'
7768       include 'COMMON.NAMES'
7769       include 'COMMON.IOUNITS'
7770       include 'COMMON.FFIELD'
7771       include 'COMMON.CONTROL'
7772       logical lprn
7773 C Set lprn=.true. for debugging
7774       lprn=.false.
7775 c      lprn=.true.
7776 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7777       esccor=0.0D0
7778       do i=itau_start,itau_end
7779         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7780         esccor_ii=0.0D0
7781         isccori=isccortyp(itype(i-2))
7782         isccori1=isccortyp(itype(i-1))
7783         phii=phi(i)
7784         do intertyp=1,3 !intertyp
7785 cc Added 09 May 2012 (Adasko)
7786 cc  Intertyp means interaction type of backbone mainchain correlation:
7787 c   1 = SC...Ca...Ca...Ca
7788 c   2 = Ca...Ca...Ca...SC
7789 c   3 = SC...Ca...Ca...SCi
7790         gloci=0.0D0
7791         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7792      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7793      &      (itype(i-1).eq.ntyp1)))
7794      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7795      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7796      &     .or.(itype(i).eq.ntyp1)))
7797      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7798      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7799      &      (itype(i-3).eq.ntyp1)))) cycle
7800         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7801         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7802      & cycle
7803        do j=1,nterm_sccor(isccori,isccori1)
7804           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7805           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7806           cosphi=dcos(j*tauangle(intertyp,i))
7807           sinphi=dsin(j*tauangle(intertyp,i))
7808            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7809            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7810          enddo
7811 C      write (iout,*)"EBACK_SC_COR",esccor,i
7812 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7813 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7814 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7815         if (lprn)
7816      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7817      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7818      &  (v1sccor(j,1,itori,itori1),j=1,6)
7819      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7820 c        gsccor_loc(i-3)=gloci
7821        enddo !intertyp
7822       enddo
7823       return
7824       end
7825 c------------------------------------------------------------------------------
7826       subroutine multibody(ecorr)
7827 C This subroutine calculates multi-body contributions to energy following
7828 C the idea of Skolnick et al. If side chains I and J make a contact and
7829 C at the same time side chains I+1 and J+1 make a contact, an extra
7830 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7831       implicit real*8 (a-h,o-z)
7832       include 'DIMENSIONS'
7833       include 'DIMENSIONS.ZSCOPT'
7834       include 'COMMON.IOUNITS'
7835       include 'COMMON.DERIV'
7836       include 'COMMON.INTERACT'
7837       include 'COMMON.CONTACTS'
7838       double precision gx(3),gx1(3)
7839       logical lprn
7840
7841 C Set lprn=.true. for debugging
7842       lprn=.false.
7843
7844       if (lprn) then
7845         write (iout,'(a)') 'Contact function values:'
7846         do i=nnt,nct-2
7847           write (iout,'(i2,20(1x,i2,f10.5))')
7848      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7849         enddo
7850       endif
7851       ecorr=0.0D0
7852       do i=nnt,nct
7853         do j=1,3
7854           gradcorr(j,i)=0.0D0
7855           gradxorr(j,i)=0.0D0
7856         enddo
7857       enddo
7858       do i=nnt,nct-2
7859
7860         DO ISHIFT = 3,4
7861
7862         i1=i+ishift
7863         num_conti=num_cont(i)
7864         num_conti1=num_cont(i1)
7865         do jj=1,num_conti
7866           j=jcont(jj,i)
7867           do kk=1,num_conti1
7868             j1=jcont(kk,i1)
7869             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7870 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7871 cd   &                   ' ishift=',ishift
7872 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7873 C The system gains extra energy.
7874               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7875             endif   ! j1==j+-ishift
7876           enddo     ! kk
7877         enddo       ! jj
7878
7879         ENDDO ! ISHIFT
7880
7881       enddo         ! i
7882       return
7883       end
7884 c------------------------------------------------------------------------------
7885       double precision function esccorr(i,j,k,l,jj,kk)
7886       implicit real*8 (a-h,o-z)
7887       include 'DIMENSIONS'
7888       include 'DIMENSIONS.ZSCOPT'
7889       include 'COMMON.IOUNITS'
7890       include 'COMMON.DERIV'
7891       include 'COMMON.INTERACT'
7892       include 'COMMON.CONTACTS'
7893       double precision gx(3),gx1(3)
7894       logical lprn
7895       lprn=.false.
7896       eij=facont(jj,i)
7897       ekl=facont(kk,k)
7898 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7899 C Calculate the multi-body contribution to energy.
7900 C Calculate multi-body contributions to the gradient.
7901 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7902 cd   & k,l,(gacont(m,kk,k),m=1,3)
7903       do m=1,3
7904         gx(m) =ekl*gacont(m,jj,i)
7905         gx1(m)=eij*gacont(m,kk,k)
7906         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7907         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7908         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7909         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7910       enddo
7911       do m=i,j-1
7912         do ll=1,3
7913           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7914         enddo
7915       enddo
7916       do m=k,l-1
7917         do ll=1,3
7918           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7919         enddo
7920       enddo
7921       esccorr=-eij*ekl
7922       return
7923       end
7924 c------------------------------------------------------------------------------
7925       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7926 C This subroutine calculates multi-body contributions to hydrogen-bonding
7927       implicit real*8 (a-h,o-z)
7928       include 'DIMENSIONS'
7929       include 'DIMENSIONS.ZSCOPT'
7930       include 'COMMON.IOUNITS'
7931       include 'COMMON.FFIELD'
7932       include 'COMMON.DERIV'
7933       include 'COMMON.INTERACT'
7934       include 'COMMON.CONTACTS'
7935       double precision gx(3),gx1(3)
7936       logical lprn,ldone
7937
7938 C Set lprn=.true. for debugging
7939       lprn=.false.
7940       if (lprn) then
7941         write (iout,'(a)') 'Contact function values:'
7942         do i=nnt,nct-2
7943           write (iout,'(2i3,50(1x,i2,f5.2))')
7944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7945      &    j=1,num_cont_hb(i))
7946         enddo
7947       endif
7948       ecorr=0.0D0
7949 C Remove the loop below after debugging !!!
7950       do i=nnt,nct
7951         do j=1,3
7952           gradcorr(j,i)=0.0D0
7953           gradxorr(j,i)=0.0D0
7954         enddo
7955       enddo
7956 C Calculate the local-electrostatic correlation terms
7957       do i=iatel_s,iatel_e+1
7958         i1=i+1
7959         num_conti=num_cont_hb(i)
7960         num_conti1=num_cont_hb(i+1)
7961         do jj=1,num_conti
7962           j=jcont_hb(jj,i)
7963           do kk=1,num_conti1
7964             j1=jcont_hb(kk,i1)
7965 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7966 c     &         ' jj=',jj,' kk=',kk
7967             if (j1.eq.j+1 .or. j1.eq.j-1) then
7968 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7969 C The system gains extra energy.
7970               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7971               n_corr=n_corr+1
7972             else if (j1.eq.j) then
7973 C Contacts I-J and I-(J+1) occur simultaneously.
7974 C The system loses extra energy.
7975 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7976             endif
7977           enddo ! kk
7978           do kk=1,num_conti
7979             j1=jcont_hb(kk,i)
7980 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7981 c    &         ' jj=',jj,' kk=',kk
7982             if (j1.eq.j+1) then
7983 C Contacts I-J and (I+1)-J occur simultaneously.
7984 C The system loses extra energy.
7985 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7986             endif ! j1==j+1
7987           enddo ! kk
7988         enddo ! jj
7989       enddo ! i
7990       return
7991       end
7992 c------------------------------------------------------------------------------
7993       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7994      &  n_corr1)
7995 C This subroutine calculates multi-body contributions to hydrogen-bonding
7996       implicit real*8 (a-h,o-z)
7997       include 'DIMENSIONS'
7998       include 'DIMENSIONS.ZSCOPT'
7999       include 'COMMON.IOUNITS'
8000 #ifdef MPI
8001       include "mpif.h"
8002 #endif
8003       include 'COMMON.FFIELD'
8004       include 'COMMON.DERIV'
8005       include 'COMMON.LOCAL'
8006       include 'COMMON.INTERACT'
8007       include 'COMMON.CONTACTS'
8008       include 'COMMON.CHAIN'
8009       include 'COMMON.CONTROL'
8010       include 'COMMON.SHIELD'
8011       double precision gx(3),gx1(3)
8012       integer num_cont_hb_old(maxres)
8013       logical lprn,ldone
8014       double precision eello4,eello5,eelo6,eello_turn6
8015       external eello4,eello5,eello6,eello_turn6
8016 C Set lprn=.true. for debugging
8017       lprn=.false.
8018       eturn6=0.0d0
8019       if (lprn) then
8020         write (iout,'(a)') 'Contact function values:'
8021         do i=nnt,nct-2
8022           write (iout,'(2i3,50(1x,i2,5f6.3))')
8023      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8024      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8025         enddo
8026       endif
8027       ecorr=0.0D0
8028       ecorr5=0.0d0
8029       ecorr6=0.0d0
8030 C Remove the loop below after debugging !!!
8031       do i=nnt,nct
8032         do j=1,3
8033           gradcorr(j,i)=0.0D0
8034           gradxorr(j,i)=0.0D0
8035         enddo
8036       enddo
8037 C Calculate the dipole-dipole interaction energies
8038       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8039       do i=iatel_s,iatel_e+1
8040         num_conti=num_cont_hb(i)
8041         do jj=1,num_conti
8042           j=jcont_hb(jj,i)
8043 #ifdef MOMENT
8044           call dipole(i,j,jj)
8045 #endif
8046         enddo
8047       enddo
8048       endif
8049 C Calculate the local-electrostatic correlation terms
8050 c                write (iout,*) "gradcorr5 in eello5 before loop"
8051 c                do iii=1,nres
8052 c                  write (iout,'(i5,3f10.5)')
8053 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8054 c                enddo
8055       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8056 c        write (iout,*) "corr loop i",i
8057         i1=i+1
8058         num_conti=num_cont_hb(i)
8059         num_conti1=num_cont_hb(i+1)
8060         do jj=1,num_conti
8061           j=jcont_hb(jj,i)
8062           jp=iabs(j)
8063           do kk=1,num_conti1
8064             j1=jcont_hb(kk,i1)
8065             jp1=iabs(j1)
8066 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8067 c     &         ' jj=',jj,' kk=',kk
8068 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8069             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8070      &          .or. j.lt.0 .and. j1.gt.0) .and.
8071      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8072 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8073 C The system gains extra energy.
8074               n_corr=n_corr+1
8075               sqd1=dsqrt(d_cont(jj,i))
8076               sqd2=dsqrt(d_cont(kk,i1))
8077               sred_geom = sqd1*sqd2
8078               IF (sred_geom.lt.cutoff_corr) THEN
8079                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8080      &            ekont,fprimcont)
8081 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8082 cd     &         ' jj=',jj,' kk=',kk
8083                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8084                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8085                 do l=1,3
8086                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8087                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8088                 enddo
8089                 n_corr1=n_corr1+1
8090 cd               write (iout,*) 'sred_geom=',sred_geom,
8091 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8092 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8093 cd               write (iout,*) "g_contij",g_contij
8094 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8095 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8096                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8097                 if (wcorr4.gt.0.0d0)
8098      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8099 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8100                   if (energy_dec.and.wcorr4.gt.0.0d0)
8101      1                 write (iout,'(a6,4i5,0pf7.3)')
8102      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8103 c                write (iout,*) "gradcorr5 before eello5"
8104 c                do iii=1,nres
8105 c                  write (iout,'(i5,3f10.5)')
8106 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8107 c                enddo
8108                 if (wcorr5.gt.0.0d0)
8109      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8110 c                write (iout,*) "gradcorr5 after eello5"
8111 c                do iii=1,nres
8112 c                  write (iout,'(i5,3f10.5)')
8113 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8114 c                enddo
8115                   if (energy_dec.and.wcorr5.gt.0.0d0)
8116      1                 write (iout,'(a6,4i5,0pf7.3)')
8117      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8118 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8119 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8120                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8121      &               .or. wturn6.eq.0.0d0))then
8122 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8123                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8124                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8125      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8126 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8127 cd     &            'ecorr6=',ecorr6
8128 cd                write (iout,'(4e15.5)') sred_geom,
8129 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8130 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8131 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8132                 else if (wturn6.gt.0.0d0
8133      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8134 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8135                   eturn6=eturn6+eello_turn6(i,jj,kk)
8136                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8137      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8138 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8139                 endif
8140               ENDIF
8141 1111          continue
8142             endif
8143           enddo ! kk
8144         enddo ! jj
8145       enddo ! i
8146       do i=1,nres
8147         num_cont_hb(i)=num_cont_hb_old(i)
8148       enddo
8149 c                write (iout,*) "gradcorr5 in eello5"
8150 c                do iii=1,nres
8151 c                  write (iout,'(i5,3f10.5)')
8152 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8153 c                enddo
8154       return
8155       end
8156 c------------------------------------------------------------------------------
8157       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8158       implicit real*8 (a-h,o-z)
8159       include 'DIMENSIONS'
8160       include 'DIMENSIONS.ZSCOPT'
8161       include 'COMMON.IOUNITS'
8162       include 'COMMON.DERIV'
8163       include 'COMMON.INTERACT'
8164       include 'COMMON.CONTACTS'
8165       include 'COMMON.SHIELD'
8166       include 'COMMON.CONTROL'
8167       double precision gx(3),gx1(3)
8168       logical lprn
8169       lprn=.false.
8170 C      print *,"wchodze",fac_shield(i),shield_mode
8171       eij=facont_hb(jj,i)
8172       ekl=facont_hb(kk,k)
8173       ees0pij=ees0p(jj,i)
8174       ees0pkl=ees0p(kk,k)
8175       ees0mij=ees0m(jj,i)
8176       ees0mkl=ees0m(kk,k)
8177       ekont=eij*ekl
8178       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8179 C*
8180 C     & fac_shield(i)**2*fac_shield(j)**2
8181 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8182 C Following 4 lines for diagnostics.
8183 cd    ees0pkl=0.0D0
8184 cd    ees0pij=1.0D0
8185 cd    ees0mkl=0.0D0
8186 cd    ees0mij=1.0D0
8187 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8188 c     & 'Contacts ',i,j,
8189 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8190 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8191 c     & 'gradcorr_long'
8192 C Calculate the multi-body contribution to energy.
8193 C      ecorr=ecorr+ekont*ees
8194 C Calculate multi-body contributions to the gradient.
8195       coeffpees0pij=coeffp*ees0pij
8196       coeffmees0mij=coeffm*ees0mij
8197       coeffpees0pkl=coeffp*ees0pkl
8198       coeffmees0mkl=coeffm*ees0mkl
8199       do ll=1,3
8200 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8201         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8202      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8203      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8204         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8205      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8206      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8207 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8208         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8209      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8210      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8211         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8212      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8213      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8214         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8215      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8216      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8217         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8218         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8219         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8220      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8221      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8222         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8223         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8224 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8225       enddo
8226 c      write (iout,*)
8227 cgrad      do m=i+1,j-1
8228 cgrad        do ll=1,3
8229 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8230 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8231 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8232 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8233 cgrad        enddo
8234 cgrad      enddo
8235 cgrad      do m=k+1,l-1
8236 cgrad        do ll=1,3
8237 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8238 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8239 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8240 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8241 cgrad        enddo
8242 cgrad      enddo
8243 c      write (iout,*) "ehbcorr",ekont*ees
8244 C      print *,ekont,ees,i,k
8245       ehbcorr=ekont*ees
8246 C now gradient over shielding
8247 C      return
8248       if (shield_mode.gt.0) then
8249        j=ees0plist(jj,i)
8250        l=ees0plist(kk,k)
8251 C        print *,i,j,fac_shield(i),fac_shield(j),
8252 C     &fac_shield(k),fac_shield(l)
8253         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8254      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8255           do ilist=1,ishield_list(i)
8256            iresshield=shield_list(ilist,i)
8257            do m=1,3
8258            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8259 C     &      *2.0
8260            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8261      &              rlocshield
8262      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8263             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8264      &+rlocshield
8265            enddo
8266           enddo
8267           do ilist=1,ishield_list(j)
8268            iresshield=shield_list(ilist,j)
8269            do m=1,3
8270            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8271 C     &     *2.0
8272            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8273      &              rlocshield
8274      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8275            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8276      &     +rlocshield
8277            enddo
8278           enddo
8279
8280           do ilist=1,ishield_list(k)
8281            iresshield=shield_list(ilist,k)
8282            do m=1,3
8283            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8284 C     &     *2.0
8285            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8286      &              rlocshield
8287      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8288            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8289      &     +rlocshield
8290            enddo
8291           enddo
8292           do ilist=1,ishield_list(l)
8293            iresshield=shield_list(ilist,l)
8294            do m=1,3
8295            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8296 C     &     *2.0
8297            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8298      &              rlocshield
8299      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8300            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8301      &     +rlocshield
8302            enddo
8303           enddo
8304 C          print *,gshieldx(m,iresshield)
8305           do m=1,3
8306             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8307      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8308             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8309      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8310             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8311      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8312             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8313      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8314
8315             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8316      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8317             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8318      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8319             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8320      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8321             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8322      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8323
8324            enddo
8325       endif
8326       endif
8327       return
8328       end
8329 #ifdef MOMENT
8330 C---------------------------------------------------------------------------
8331       subroutine dipole(i,j,jj)
8332       implicit real*8 (a-h,o-z)
8333       include 'DIMENSIONS'
8334       include 'DIMENSIONS.ZSCOPT'
8335       include 'COMMON.IOUNITS'
8336       include 'COMMON.CHAIN'
8337       include 'COMMON.FFIELD'
8338       include 'COMMON.DERIV'
8339       include 'COMMON.INTERACT'
8340       include 'COMMON.CONTACTS'
8341       include 'COMMON.TORSION'
8342       include 'COMMON.VAR'
8343       include 'COMMON.GEO'
8344       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8345      &  auxmat(2,2)
8346       iti1 = itortyp(itype(i+1))
8347       if (j.lt.nres-1) then
8348         itj1 = itype2loc(itype(j+1))
8349       else
8350         itj1=nloctyp
8351       endif
8352       do iii=1,2
8353         dipi(iii,1)=Ub2(iii,i)
8354         dipderi(iii)=Ub2der(iii,i)
8355         dipi(iii,2)=b1(iii,i+1)
8356         dipj(iii,1)=Ub2(iii,j)
8357         dipderj(iii)=Ub2der(iii,j)
8358         dipj(iii,2)=b1(iii,j+1)
8359       enddo
8360       kkk=0
8361       do iii=1,2
8362         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8363         do jjj=1,2
8364           kkk=kkk+1
8365           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8366         enddo
8367       enddo
8368       do kkk=1,5
8369         do lll=1,3
8370           mmm=0
8371           do iii=1,2
8372             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8373      &        auxvec(1))
8374             do jjj=1,2
8375               mmm=mmm+1
8376               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8377             enddo
8378           enddo
8379         enddo
8380       enddo
8381       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8382       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8383       do iii=1,2
8384         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8385       enddo
8386       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8387       do iii=1,2
8388         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8389       enddo
8390       return
8391       end
8392 #endif
8393 C---------------------------------------------------------------------------
8394       subroutine calc_eello(i,j,k,l,jj,kk)
8395 C
8396 C This subroutine computes matrices and vectors needed to calculate
8397 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8398 C
8399       implicit real*8 (a-h,o-z)
8400       include 'DIMENSIONS'
8401       include 'DIMENSIONS.ZSCOPT'
8402       include 'COMMON.IOUNITS'
8403       include 'COMMON.CHAIN'
8404       include 'COMMON.DERIV'
8405       include 'COMMON.INTERACT'
8406       include 'COMMON.CONTACTS'
8407       include 'COMMON.TORSION'
8408       include 'COMMON.VAR'
8409       include 'COMMON.GEO'
8410       include 'COMMON.FFIELD'
8411       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8412      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8413       logical lprn
8414       common /kutas/ lprn
8415 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8416 cd     & ' jj=',jj,' kk=',kk
8417 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8418 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8419 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8420       do iii=1,2
8421         do jjj=1,2
8422           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8423           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8424         enddo
8425       enddo
8426       call transpose2(aa1(1,1),aa1t(1,1))
8427       call transpose2(aa2(1,1),aa2t(1,1))
8428       do kkk=1,5
8429         do lll=1,3
8430           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8431      &      aa1tder(1,1,lll,kkk))
8432           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8433      &      aa2tder(1,1,lll,kkk))
8434         enddo
8435       enddo
8436       if (l.eq.j+1) then
8437 C parallel orientation of the two CA-CA-CA frames.
8438         if (i.gt.1) then
8439           iti=itype2loc(itype(i))
8440         else
8441           iti=nloctyp
8442         endif
8443         itk1=itype2loc(itype(k+1))
8444         itj=itype2loc(itype(j))
8445         if (l.lt.nres-1) then
8446           itl1=itype2loc(itype(l+1))
8447         else
8448           itl1=nloctyp
8449         endif
8450 C A1 kernel(j+1) A2T
8451 cd        do iii=1,2
8452 cd          write (iout,'(3f10.5,5x,3f10.5)')
8453 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8454 cd        enddo
8455         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8456      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8457      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8458 C Following matrices are needed only for 6-th order cumulants
8459         IF (wcorr6.gt.0.0d0) THEN
8460         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8461      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8462      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8463         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8464      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8465      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8466      &   ADtEAderx(1,1,1,1,1,1))
8467         lprn=.false.
8468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8469      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8470      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8471      &   ADtEA1derx(1,1,1,1,1,1))
8472         ENDIF
8473 C End 6-th order cumulants
8474 cd        lprn=.false.
8475 cd        if (lprn) then
8476 cd        write (2,*) 'In calc_eello6'
8477 cd        do iii=1,2
8478 cd          write (2,*) 'iii=',iii
8479 cd          do kkk=1,5
8480 cd            write (2,*) 'kkk=',kkk
8481 cd            do jjj=1,2
8482 cd              write (2,'(3(2f10.5),5x)')
8483 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8484 cd            enddo
8485 cd          enddo
8486 cd        enddo
8487 cd        endif
8488         call transpose2(EUgder(1,1,k),auxmat(1,1))
8489         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8490         call transpose2(EUg(1,1,k),auxmat(1,1))
8491         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8492         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8493         do iii=1,2
8494           do kkk=1,5
8495             do lll=1,3
8496               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8497      &          EAEAderx(1,1,lll,kkk,iii,1))
8498             enddo
8499           enddo
8500         enddo
8501 C A1T kernel(i+1) A2
8502         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8503      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8504      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8505 C Following matrices are needed only for 6-th order cumulants
8506         IF (wcorr6.gt.0.0d0) THEN
8507         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8508      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8509      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8510         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8511      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8512      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8513      &   ADtEAderx(1,1,1,1,1,2))
8514         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8515      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8516      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8517      &   ADtEA1derx(1,1,1,1,1,2))
8518         ENDIF
8519 C End 6-th order cumulants
8520         call transpose2(EUgder(1,1,l),auxmat(1,1))
8521         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8522         call transpose2(EUg(1,1,l),auxmat(1,1))
8523         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8524         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8525         do iii=1,2
8526           do kkk=1,5
8527             do lll=1,3
8528               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8529      &          EAEAderx(1,1,lll,kkk,iii,2))
8530             enddo
8531           enddo
8532         enddo
8533 C AEAb1 and AEAb2
8534 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8535 C They are needed only when the fifth- or the sixth-order cumulants are
8536 C indluded.
8537         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8538         call transpose2(AEA(1,1,1),auxmat(1,1))
8539         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8540         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8541         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8542         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8543         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8544         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8545         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8546         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8547         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8548         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8549         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8550         call transpose2(AEA(1,1,2),auxmat(1,1))
8551         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8552         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8553         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8554         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8555         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8556         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8557         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8558         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8559         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8560         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8561         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8562 C Calculate the Cartesian derivatives of the vectors.
8563         do iii=1,2
8564           do kkk=1,5
8565             do lll=1,3
8566               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8567               call matvec2(auxmat(1,1),b1(1,i),
8568      &          AEAb1derx(1,lll,kkk,iii,1,1))
8569               call matvec2(auxmat(1,1),Ub2(1,i),
8570      &          AEAb2derx(1,lll,kkk,iii,1,1))
8571               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8572      &          AEAb1derx(1,lll,kkk,iii,2,1))
8573               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8574      &          AEAb2derx(1,lll,kkk,iii,2,1))
8575               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8576               call matvec2(auxmat(1,1),b1(1,j),
8577      &          AEAb1derx(1,lll,kkk,iii,1,2))
8578               call matvec2(auxmat(1,1),Ub2(1,j),
8579      &          AEAb2derx(1,lll,kkk,iii,1,2))
8580               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8581      &          AEAb1derx(1,lll,kkk,iii,2,2))
8582               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8583      &          AEAb2derx(1,lll,kkk,iii,2,2))
8584             enddo
8585           enddo
8586         enddo
8587         ENDIF
8588 C End vectors
8589       else
8590 C Antiparallel orientation of the two CA-CA-CA frames.
8591         if (i.gt.1) then
8592           iti=itype2loc(itype(i))
8593         else
8594           iti=nloctyp
8595         endif
8596         itk1=itype2loc(itype(k+1))
8597         itl=itype2loc(itype(l))
8598         itj=itype2loc(itype(j))
8599         if (j.lt.nres-1) then
8600           itj1=itype2loc(itype(j+1))
8601         else
8602           itj1=nloctyp
8603         endif
8604 C A2 kernel(j-1)T A1T
8605         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8606      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8607      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8608 C Following matrices are needed only for 6-th order cumulants
8609         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8610      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8611         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8612      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8613      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8614         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8615      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8616      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8617      &   ADtEAderx(1,1,1,1,1,1))
8618         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8619      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8620      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8621      &   ADtEA1derx(1,1,1,1,1,1))
8622         ENDIF
8623 C End 6-th order cumulants
8624         call transpose2(EUgder(1,1,k),auxmat(1,1))
8625         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8626         call transpose2(EUg(1,1,k),auxmat(1,1))
8627         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8628         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8629         do iii=1,2
8630           do kkk=1,5
8631             do lll=1,3
8632               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8633      &          EAEAderx(1,1,lll,kkk,iii,1))
8634             enddo
8635           enddo
8636         enddo
8637 C A2T kernel(i+1)T A1
8638         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8639      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8640      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8641 C Following matrices are needed only for 6-th order cumulants
8642         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8643      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8644         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8645      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8646      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8647         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8648      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8649      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8650      &   ADtEAderx(1,1,1,1,1,2))
8651         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8652      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8653      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8654      &   ADtEA1derx(1,1,1,1,1,2))
8655         ENDIF
8656 C End 6-th order cumulants
8657         call transpose2(EUgder(1,1,j),auxmat(1,1))
8658         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8659         call transpose2(EUg(1,1,j),auxmat(1,1))
8660         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8661         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8662         do iii=1,2
8663           do kkk=1,5
8664             do lll=1,3
8665               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8666      &          EAEAderx(1,1,lll,kkk,iii,2))
8667             enddo
8668           enddo
8669         enddo
8670 C AEAb1 and AEAb2
8671 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8672 C They are needed only when the fifth- or the sixth-order cumulants are
8673 C indluded.
8674         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8675      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8676         call transpose2(AEA(1,1,1),auxmat(1,1))
8677         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8678         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8679         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8680         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8681         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8682         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8683         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8684         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8685         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8686         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8687         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8688         call transpose2(AEA(1,1,2),auxmat(1,1))
8689         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8690         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8691         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8692         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8693         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8694         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8695         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8696         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8697         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8698         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8699         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8700 C Calculate the Cartesian derivatives of the vectors.
8701         do iii=1,2
8702           do kkk=1,5
8703             do lll=1,3
8704               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8705               call matvec2(auxmat(1,1),b1(1,i),
8706      &          AEAb1derx(1,lll,kkk,iii,1,1))
8707               call matvec2(auxmat(1,1),Ub2(1,i),
8708      &          AEAb2derx(1,lll,kkk,iii,1,1))
8709               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8710      &          AEAb1derx(1,lll,kkk,iii,2,1))
8711               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8712      &          AEAb2derx(1,lll,kkk,iii,2,1))
8713               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8714               call matvec2(auxmat(1,1),b1(1,l),
8715      &          AEAb1derx(1,lll,kkk,iii,1,2))
8716               call matvec2(auxmat(1,1),Ub2(1,l),
8717      &          AEAb2derx(1,lll,kkk,iii,1,2))
8718               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8719      &          AEAb1derx(1,lll,kkk,iii,2,2))
8720               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8721      &          AEAb2derx(1,lll,kkk,iii,2,2))
8722             enddo
8723           enddo
8724         enddo
8725         ENDIF
8726 C End vectors
8727       endif
8728       return
8729       end
8730 C---------------------------------------------------------------------------
8731       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8732      &  KK,KKderg,AKA,AKAderg,AKAderx)
8733       implicit none
8734       integer nderg
8735       logical transp
8736       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8737      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8738      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8739       integer iii,kkk,lll
8740       integer jjj,mmm
8741       logical lprn
8742       common /kutas/ lprn
8743       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8744       do iii=1,nderg
8745         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8746      &    AKAderg(1,1,iii))
8747       enddo
8748 cd      if (lprn) write (2,*) 'In kernel'
8749       do kkk=1,5
8750 cd        if (lprn) write (2,*) 'kkk=',kkk
8751         do lll=1,3
8752           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8753      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8754 cd          if (lprn) then
8755 cd            write (2,*) 'lll=',lll
8756 cd            write (2,*) 'iii=1'
8757 cd            do jjj=1,2
8758 cd              write (2,'(3(2f10.5),5x)')
8759 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8760 cd            enddo
8761 cd          endif
8762           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8763      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8764 cd          if (lprn) then
8765 cd            write (2,*) 'lll=',lll
8766 cd            write (2,*) 'iii=2'
8767 cd            do jjj=1,2
8768 cd              write (2,'(3(2f10.5),5x)')
8769 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8770 cd            enddo
8771 cd          endif
8772         enddo
8773       enddo
8774       return
8775       end
8776 C---------------------------------------------------------------------------
8777       double precision function eello4(i,j,k,l,jj,kk)
8778       implicit real*8 (a-h,o-z)
8779       include 'DIMENSIONS'
8780       include 'DIMENSIONS.ZSCOPT'
8781       include 'COMMON.IOUNITS'
8782       include 'COMMON.CHAIN'
8783       include 'COMMON.DERIV'
8784       include 'COMMON.INTERACT'
8785       include 'COMMON.CONTACTS'
8786       include 'COMMON.TORSION'
8787       include 'COMMON.VAR'
8788       include 'COMMON.GEO'
8789       double precision pizda(2,2),ggg1(3),ggg2(3)
8790 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8791 cd        eello4=0.0d0
8792 cd        return
8793 cd      endif
8794 cd      print *,'eello4:',i,j,k,l,jj,kk
8795 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8796 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8797 cold      eij=facont_hb(jj,i)
8798 cold      ekl=facont_hb(kk,k)
8799 cold      ekont=eij*ekl
8800       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8801       if (calc_grad) then
8802 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8803       gcorr_loc(k-1)=gcorr_loc(k-1)
8804      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8805       if (l.eq.j+1) then
8806         gcorr_loc(l-1)=gcorr_loc(l-1)
8807      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8808       else
8809         gcorr_loc(j-1)=gcorr_loc(j-1)
8810      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8811       endif
8812       do iii=1,2
8813         do kkk=1,5
8814           do lll=1,3
8815             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8816      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8817 cd            derx(lll,kkk,iii)=0.0d0
8818           enddo
8819         enddo
8820       enddo
8821 cd      gcorr_loc(l-1)=0.0d0
8822 cd      gcorr_loc(j-1)=0.0d0
8823 cd      gcorr_loc(k-1)=0.0d0
8824 cd      eel4=1.0d0
8825 cd      write (iout,*)'Contacts have occurred for peptide groups',
8826 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8827 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8828       if (j.lt.nres-1) then
8829         j1=j+1
8830         j2=j-1
8831       else
8832         j1=j-1
8833         j2=j-2
8834       endif
8835       if (l.lt.nres-1) then
8836         l1=l+1
8837         l2=l-1
8838       else
8839         l1=l-1
8840         l2=l-2
8841       endif
8842       do ll=1,3
8843 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8844 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8845         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8846         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8847 cgrad        ghalf=0.5d0*ggg1(ll)
8848         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8849         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8850         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8851         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8852         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8853         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8854 cgrad        ghalf=0.5d0*ggg2(ll)
8855         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8856         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8857         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8858         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8859         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8860         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8861       enddo
8862 cgrad      do m=i+1,j-1
8863 cgrad        do ll=1,3
8864 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8865 cgrad        enddo
8866 cgrad      enddo
8867 cgrad      do m=k+1,l-1
8868 cgrad        do ll=1,3
8869 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad      do m=i+2,j2
8873 cgrad        do ll=1,3
8874 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8875 cgrad        enddo
8876 cgrad      enddo
8877 cgrad      do m=k+2,l2
8878 cgrad        do ll=1,3
8879 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8880 cgrad        enddo
8881 cgrad      enddo
8882 cd      do iii=1,nres-3
8883 cd        write (2,*) iii,gcorr_loc(iii)
8884 cd      enddo
8885       endif ! calc_grad
8886       eello4=ekont*eel4
8887 cd      write (2,*) 'ekont',ekont
8888 cd      write (iout,*) 'eello4',ekont*eel4
8889       return
8890       end
8891 C---------------------------------------------------------------------------
8892       double precision function eello5(i,j,k,l,jj,kk)
8893       implicit real*8 (a-h,o-z)
8894       include 'DIMENSIONS'
8895       include 'DIMENSIONS.ZSCOPT'
8896       include 'COMMON.IOUNITS'
8897       include 'COMMON.CHAIN'
8898       include 'COMMON.DERIV'
8899       include 'COMMON.INTERACT'
8900       include 'COMMON.CONTACTS'
8901       include 'COMMON.TORSION'
8902       include 'COMMON.VAR'
8903       include 'COMMON.GEO'
8904       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8905       double precision ggg1(3),ggg2(3)
8906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8907 C                                                                              C
8908 C                            Parallel chains                                   C
8909 C                                                                              C
8910 C          o             o                   o             o                   C
8911 C         /l\           / \             \   / \           / \   /              C
8912 C        /   \         /   \             \ /   \         /   \ /               C
8913 C       j| o |l1       | o |              o| o |         | o |o                C
8914 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8915 C      \i/   \         /   \ /             /   \         /   \                 C
8916 C       o    k1             o                                                  C
8917 C         (I)          (II)                (III)          (IV)                 C
8918 C                                                                              C
8919 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8920 C                                                                              C
8921 C                            Antiparallel chains                               C
8922 C                                                                              C
8923 C          o             o                   o             o                   C
8924 C         /j\           / \             \   / \           / \   /              C
8925 C        /   \         /   \             \ /   \         /   \ /               C
8926 C      j1| o |l        | o |              o| o |         | o |o                C
8927 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8928 C      \i/   \         /   \ /             /   \         /   \                 C
8929 C       o     k1            o                                                  C
8930 C         (I)          (II)                (III)          (IV)                 C
8931 C                                                                              C
8932 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8933 C                                                                              C
8934 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8935 C                                                                              C
8936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8937 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8938 cd        eello5=0.0d0
8939 cd        return
8940 cd      endif
8941 cd      write (iout,*)
8942 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8943 cd     &   ' and',k,l
8944       itk=itype2loc(itype(k))
8945       itl=itype2loc(itype(l))
8946       itj=itype2loc(itype(j))
8947       eello5_1=0.0d0
8948       eello5_2=0.0d0
8949       eello5_3=0.0d0
8950       eello5_4=0.0d0
8951 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8952 cd     &   eel5_3_num,eel5_4_num)
8953       do iii=1,2
8954         do kkk=1,5
8955           do lll=1,3
8956             derx(lll,kkk,iii)=0.0d0
8957           enddo
8958         enddo
8959       enddo
8960 cd      eij=facont_hb(jj,i)
8961 cd      ekl=facont_hb(kk,k)
8962 cd      ekont=eij*ekl
8963 cd      write (iout,*)'Contacts have occurred for peptide groups',
8964 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8965 cd      goto 1111
8966 C Contribution from the graph I.
8967 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8968 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8969       call transpose2(EUg(1,1,k),auxmat(1,1))
8970       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8971       vv(1)=pizda(1,1)-pizda(2,2)
8972       vv(2)=pizda(1,2)+pizda(2,1)
8973       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8974      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8975       if (calc_grad) then
8976 C Explicit gradient in virtual-dihedral angles.
8977       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8978      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8979      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8980       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8981       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8982       vv(1)=pizda(1,1)-pizda(2,2)
8983       vv(2)=pizda(1,2)+pizda(2,1)
8984       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8985      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8986      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8987       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8988       vv(1)=pizda(1,1)-pizda(2,2)
8989       vv(2)=pizda(1,2)+pizda(2,1)
8990       if (l.eq.j+1) then
8991         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8992      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8993      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8994       else
8995         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8996      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8997      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8998       endif
8999 C Cartesian gradient
9000       do iii=1,2
9001         do kkk=1,5
9002           do lll=1,3
9003             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9004      &        pizda(1,1))
9005             vv(1)=pizda(1,1)-pizda(2,2)
9006             vv(2)=pizda(1,2)+pizda(2,1)
9007             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9008      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9009      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9010           enddo
9011         enddo
9012       enddo
9013       endif ! calc_grad
9014 c      goto 1112
9015 c1111  continue
9016 C Contribution from graph II
9017       call transpose2(EE(1,1,k),auxmat(1,1))
9018       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9019       vv(1)=pizda(1,1)+pizda(2,2)
9020       vv(2)=pizda(2,1)-pizda(1,2)
9021       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9022      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9023       if (calc_grad) then
9024 C Explicit gradient in virtual-dihedral angles.
9025       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9026      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9027       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9028       vv(1)=pizda(1,1)+pizda(2,2)
9029       vv(2)=pizda(2,1)-pizda(1,2)
9030       if (l.eq.j+1) then
9031         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9032      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9033      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9034       else
9035         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9036      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9037      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9038       endif
9039 C Cartesian gradient
9040       do iii=1,2
9041         do kkk=1,5
9042           do lll=1,3
9043             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9044      &        pizda(1,1))
9045             vv(1)=pizda(1,1)+pizda(2,2)
9046             vv(2)=pizda(2,1)-pizda(1,2)
9047             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9048      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9049      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9050           enddo
9051         enddo
9052       enddo
9053       endif ! calc_grad
9054 cd      goto 1112
9055 cd1111  continue
9056       if (l.eq.j+1) then
9057 cd        goto 1110
9058 C Parallel orientation
9059 C Contribution from graph III
9060         call transpose2(EUg(1,1,l),auxmat(1,1))
9061         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9062         vv(1)=pizda(1,1)-pizda(2,2)
9063         vv(2)=pizda(1,2)+pizda(2,1)
9064         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9065      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9066         if (calc_grad) then
9067 C Explicit gradient in virtual-dihedral angles.
9068         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9069      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9070      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9071         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9072         vv(1)=pizda(1,1)-pizda(2,2)
9073         vv(2)=pizda(1,2)+pizda(2,1)
9074         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9075      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9076      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9077         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9078         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9079         vv(1)=pizda(1,1)-pizda(2,2)
9080         vv(2)=pizda(1,2)+pizda(2,1)
9081         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9082      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9083      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9084 C Cartesian gradient
9085         do iii=1,2
9086           do kkk=1,5
9087             do lll=1,3
9088               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9089      &          pizda(1,1))
9090               vv(1)=pizda(1,1)-pizda(2,2)
9091               vv(2)=pizda(1,2)+pizda(2,1)
9092               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9093      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9094      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9095             enddo
9096           enddo
9097         enddo
9098 cd        goto 1112
9099 C Contribution from graph IV
9100 cd1110    continue
9101         call transpose2(EE(1,1,l),auxmat(1,1))
9102         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9103         vv(1)=pizda(1,1)+pizda(2,2)
9104         vv(2)=pizda(2,1)-pizda(1,2)
9105         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9106      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9107 C Explicit gradient in virtual-dihedral angles.
9108         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9109      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9110         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9111         vv(1)=pizda(1,1)+pizda(2,2)
9112         vv(2)=pizda(2,1)-pizda(1,2)
9113         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9114      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9115      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9116 C Cartesian gradient
9117         do iii=1,2
9118           do kkk=1,5
9119             do lll=1,3
9120               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9121      &          pizda(1,1))
9122               vv(1)=pizda(1,1)+pizda(2,2)
9123               vv(2)=pizda(2,1)-pizda(1,2)
9124               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9125      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9126      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9127             enddo
9128           enddo
9129         enddo
9130         endif ! calc_grad
9131       else
9132 C Antiparallel orientation
9133 C Contribution from graph III
9134 c        goto 1110
9135         call transpose2(EUg(1,1,j),auxmat(1,1))
9136         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9137         vv(1)=pizda(1,1)-pizda(2,2)
9138         vv(2)=pizda(1,2)+pizda(2,1)
9139         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9140      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9141         if (calc_grad) then
9142 C Explicit gradient in virtual-dihedral angles.
9143         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9144      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9145      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9146         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9147         vv(1)=pizda(1,1)-pizda(2,2)
9148         vv(2)=pizda(1,2)+pizda(2,1)
9149         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9150      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9151      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9152         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9153         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9154         vv(1)=pizda(1,1)-pizda(2,2)
9155         vv(2)=pizda(1,2)+pizda(2,1)
9156         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9157      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9158      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9159 C Cartesian gradient
9160         do iii=1,2
9161           do kkk=1,5
9162             do lll=1,3
9163               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9164      &          pizda(1,1))
9165               vv(1)=pizda(1,1)-pizda(2,2)
9166               vv(2)=pizda(1,2)+pizda(2,1)
9167               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9168      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9169      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9170             enddo
9171           enddo
9172         enddo
9173         endif ! calc_grad
9174 cd        goto 1112
9175 C Contribution from graph IV
9176 1110    continue
9177         call transpose2(EE(1,1,j),auxmat(1,1))
9178         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9179         vv(1)=pizda(1,1)+pizda(2,2)
9180         vv(2)=pizda(2,1)-pizda(1,2)
9181         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9182      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9183         if (calc_grad) then
9184 C Explicit gradient in virtual-dihedral angles.
9185         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9186      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9187         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9188         vv(1)=pizda(1,1)+pizda(2,2)
9189         vv(2)=pizda(2,1)-pizda(1,2)
9190         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9191      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9192      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9193 C Cartesian gradient
9194         do iii=1,2
9195           do kkk=1,5
9196             do lll=1,3
9197               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9198      &          pizda(1,1))
9199               vv(1)=pizda(1,1)+pizda(2,2)
9200               vv(2)=pizda(2,1)-pizda(1,2)
9201               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9202      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9203      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9204             enddo
9205           enddo
9206         enddo
9207         endif ! calc_grad
9208       endif
9209 1112  continue
9210       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9211 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9212 cd        write (2,*) 'ijkl',i,j,k,l
9213 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9214 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9215 cd      endif
9216 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9217 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9218 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9219 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9220       if (calc_grad) then
9221       if (j.lt.nres-1) then
9222         j1=j+1
9223         j2=j-1
9224       else
9225         j1=j-1
9226         j2=j-2
9227       endif
9228       if (l.lt.nres-1) then
9229         l1=l+1
9230         l2=l-1
9231       else
9232         l1=l-1
9233         l2=l-2
9234       endif
9235 cd      eij=1.0d0
9236 cd      ekl=1.0d0
9237 cd      ekont=1.0d0
9238 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9239 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9240 C        summed up outside the subrouine as for the other subroutines
9241 C        handling long-range interactions. The old code is commented out
9242 C        with "cgrad" to keep track of changes.
9243       do ll=1,3
9244 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9245 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9246         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9247         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9248 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9249 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9250 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9251 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9252 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9253 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9254 c     &   gradcorr5ij,
9255 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9256 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9257 cgrad        ghalf=0.5d0*ggg1(ll)
9258 cd        ghalf=0.0d0
9259         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9260         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9261         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9262         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9263         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9264         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9265 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9266 cgrad        ghalf=0.5d0*ggg2(ll)
9267 cd        ghalf=0.0d0
9268         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9269         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9270         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9271         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9272         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9273         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9274       enddo
9275       endif ! calc_grad
9276 cd      goto 1112
9277 cgrad      do m=i+1,j-1
9278 cgrad        do ll=1,3
9279 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9280 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9281 cgrad        enddo
9282 cgrad      enddo
9283 cgrad      do m=k+1,l-1
9284 cgrad        do ll=1,3
9285 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9286 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9287 cgrad        enddo
9288 cgrad      enddo
9289 c1112  continue
9290 cgrad      do m=i+2,j2
9291 cgrad        do ll=1,3
9292 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9293 cgrad        enddo
9294 cgrad      enddo
9295 cgrad      do m=k+2,l2
9296 cgrad        do ll=1,3
9297 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9298 cgrad        enddo
9299 cgrad      enddo
9300 cd      do iii=1,nres-3
9301 cd        write (2,*) iii,g_corr5_loc(iii)
9302 cd      enddo
9303       eello5=ekont*eel5
9304 cd      write (2,*) 'ekont',ekont
9305 cd      write (iout,*) 'eello5',ekont*eel5
9306       return
9307       end
9308 c--------------------------------------------------------------------------
9309       double precision function eello6(i,j,k,l,jj,kk)
9310       implicit real*8 (a-h,o-z)
9311       include 'DIMENSIONS'
9312       include 'DIMENSIONS.ZSCOPT'
9313       include 'COMMON.IOUNITS'
9314       include 'COMMON.CHAIN'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       include 'COMMON.FFIELD'
9322       double precision ggg1(3),ggg2(3)
9323 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9324 cd        eello6=0.0d0
9325 cd        return
9326 cd      endif
9327 cd      write (iout,*)
9328 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9329 cd     &   ' and',k,l
9330       eello6_1=0.0d0
9331       eello6_2=0.0d0
9332       eello6_3=0.0d0
9333       eello6_4=0.0d0
9334       eello6_5=0.0d0
9335       eello6_6=0.0d0
9336 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9337 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9338       do iii=1,2
9339         do kkk=1,5
9340           do lll=1,3
9341             derx(lll,kkk,iii)=0.0d0
9342           enddo
9343         enddo
9344       enddo
9345 cd      eij=facont_hb(jj,i)
9346 cd      ekl=facont_hb(kk,k)
9347 cd      ekont=eij*ekl
9348 cd      eij=1.0d0
9349 cd      ekl=1.0d0
9350 cd      ekont=1.0d0
9351       if (l.eq.j+1) then
9352         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9353         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9354         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9355         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9356         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9357         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9358       else
9359         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9360         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9361         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9362         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9363         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9364           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9365         else
9366           eello6_5=0.0d0
9367         endif
9368         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9369       endif
9370 C If turn contributions are considered, they will be handled separately.
9371       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9372 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9373 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9374 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9375 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9376 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9377 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9378 cd      goto 1112
9379       if (calc_grad) then
9380       if (j.lt.nres-1) then
9381         j1=j+1
9382         j2=j-1
9383       else
9384         j1=j-1
9385         j2=j-2
9386       endif
9387       if (l.lt.nres-1) then
9388         l1=l+1
9389         l2=l-1
9390       else
9391         l1=l-1
9392         l2=l-2
9393       endif
9394       do ll=1,3
9395 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9396 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9397 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9398 cgrad        ghalf=0.5d0*ggg1(ll)
9399 cd        ghalf=0.0d0
9400         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9401         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9402         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9403         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9404         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9405         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9406         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9407         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9408 cgrad        ghalf=0.5d0*ggg2(ll)
9409 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9410 cd        ghalf=0.0d0
9411         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9412         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9413         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9414         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9415         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9416         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9417       enddo
9418       endif ! calc_grad
9419 cd      goto 1112
9420 cgrad      do m=i+1,j-1
9421 cgrad        do ll=1,3
9422 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9423 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9424 cgrad        enddo
9425 cgrad      enddo
9426 cgrad      do m=k+1,l-1
9427 cgrad        do ll=1,3
9428 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9429 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9430 cgrad        enddo
9431 cgrad      enddo
9432 cgrad1112  continue
9433 cgrad      do m=i+2,j2
9434 cgrad        do ll=1,3
9435 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9436 cgrad        enddo
9437 cgrad      enddo
9438 cgrad      do m=k+2,l2
9439 cgrad        do ll=1,3
9440 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9441 cgrad        enddo
9442 cgrad      enddo
9443 cd      do iii=1,nres-3
9444 cd        write (2,*) iii,g_corr6_loc(iii)
9445 cd      enddo
9446       eello6=ekont*eel6
9447 cd      write (2,*) 'ekont',ekont
9448 cd      write (iout,*) 'eello6',ekont*eel6
9449       return
9450       end
9451 c--------------------------------------------------------------------------
9452       double precision function eello6_graph1(i,j,k,l,imat,swap)
9453       implicit real*8 (a-h,o-z)
9454       include 'DIMENSIONS'
9455       include 'DIMENSIONS.ZSCOPT'
9456       include 'COMMON.IOUNITS'
9457       include 'COMMON.CHAIN'
9458       include 'COMMON.DERIV'
9459       include 'COMMON.INTERACT'
9460       include 'COMMON.CONTACTS'
9461       include 'COMMON.TORSION'
9462       include 'COMMON.VAR'
9463       include 'COMMON.GEO'
9464       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9465       logical swap
9466       logical lprn
9467       common /kutas/ lprn
9468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9469 C                                                                              C
9470 C      Parallel       Antiparallel                                             C
9471 C                                                                              C
9472 C          o             o                                                     C
9473 C         /l\           /j\                                                    C
9474 C        /   \         /   \                                                   C
9475 C       /| o |         | o |\                                                  C
9476 C     \ j|/k\|  /   \  |/k\|l /                                                C
9477 C      \ /   \ /     \ /   \ /                                                 C
9478 C       o     o       o     o                                                  C
9479 C       i             i                                                        C
9480 C                                                                              C
9481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9482       itk=itype2loc(itype(k))
9483       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9484       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9485       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9486       call transpose2(EUgC(1,1,k),auxmat(1,1))
9487       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9488       vv1(1)=pizda1(1,1)-pizda1(2,2)
9489       vv1(2)=pizda1(1,2)+pizda1(2,1)
9490       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9491       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9492       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9493       s5=scalar2(vv(1),Dtobr2(1,i))
9494 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9495       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9496       if (calc_grad) then
9497       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9498      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9499      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9500      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9501      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9502      & +scalar2(vv(1),Dtobr2der(1,i)))
9503       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9504       vv1(1)=pizda1(1,1)-pizda1(2,2)
9505       vv1(2)=pizda1(1,2)+pizda1(2,1)
9506       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9507       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9508       if (l.eq.j+1) then
9509         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9510      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9511      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9512      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9513      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9514       else
9515         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9516      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9517      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9518      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9519      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9520       endif
9521       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9522       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9523       vv1(1)=pizda1(1,1)-pizda1(2,2)
9524       vv1(2)=pizda1(1,2)+pizda1(2,1)
9525       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9526      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9527      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9528      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9529       do iii=1,2
9530         if (swap) then
9531           ind=3-iii
9532         else
9533           ind=iii
9534         endif
9535         do kkk=1,5
9536           do lll=1,3
9537             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9538             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9539             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9540             call transpose2(EUgC(1,1,k),auxmat(1,1))
9541             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9542      &        pizda1(1,1))
9543             vv1(1)=pizda1(1,1)-pizda1(2,2)
9544             vv1(2)=pizda1(1,2)+pizda1(2,1)
9545             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9546             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9547      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9548             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9549      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9550             s5=scalar2(vv(1),Dtobr2(1,i))
9551             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9552           enddo
9553         enddo
9554       enddo
9555       endif ! calc_grad
9556       return
9557       end
9558 c----------------------------------------------------------------------------
9559       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9560       implicit real*8 (a-h,o-z)
9561       include 'DIMENSIONS'
9562       include 'DIMENSIONS.ZSCOPT'
9563       include 'COMMON.IOUNITS'
9564       include 'COMMON.CHAIN'
9565       include 'COMMON.DERIV'
9566       include 'COMMON.INTERACT'
9567       include 'COMMON.CONTACTS'
9568       include 'COMMON.TORSION'
9569       include 'COMMON.VAR'
9570       include 'COMMON.GEO'
9571       logical swap
9572       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9573      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9574       logical lprn
9575       common /kutas/ lprn
9576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9577 C                                                                              C
9578 C      Parallel       Antiparallel                                             C
9579 C                                                                              C
9580 C          o             o                                                     C
9581 C     \   /l\           /j\   /                                                C
9582 C      \ /   \         /   \ /                                                 C
9583 C       o| o |         | o |o                                                  C
9584 C     \ j|/k\|      \  |/k\|l                                                  C
9585 C      \ /   \       \ /   \                                                   C
9586 C       o             o                                                        C
9587 C       i             i                                                        C
9588 C                                                                              C
9589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9590 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9591 C AL 7/4/01 s1 would occur in the sixth-order moment,
9592 C           but not in a cluster cumulant
9593 #ifdef MOMENT
9594       s1=dip(1,jj,i)*dip(1,kk,k)
9595 #endif
9596       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9597       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9598       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9599       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9600       call transpose2(EUg(1,1,k),auxmat(1,1))
9601       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9602       vv(1)=pizda(1,1)-pizda(2,2)
9603       vv(2)=pizda(1,2)+pizda(2,1)
9604       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9605 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9606 #ifdef MOMENT
9607       eello6_graph2=-(s1+s2+s3+s4)
9608 #else
9609       eello6_graph2=-(s2+s3+s4)
9610 #endif
9611 c      eello6_graph2=-s3
9612 C Derivatives in gamma(i-1)
9613       if (calc_grad) then
9614       if (i.gt.1) then
9615 #ifdef MOMENT
9616         s1=dipderg(1,jj,i)*dip(1,kk,k)
9617 #endif
9618         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9619         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9620         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9621         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9622 #ifdef MOMENT
9623         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9624 #else
9625         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9626 #endif
9627 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9628       endif
9629 C Derivatives in gamma(k-1)
9630 #ifdef MOMENT
9631       s1=dip(1,jj,i)*dipderg(1,kk,k)
9632 #endif
9633       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9634       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9635       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9636       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9637       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9638       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9639       vv(1)=pizda(1,1)-pizda(2,2)
9640       vv(2)=pizda(1,2)+pizda(2,1)
9641       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9642 #ifdef MOMENT
9643       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9644 #else
9645       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9646 #endif
9647 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9648 C Derivatives in gamma(j-1) or gamma(l-1)
9649       if (j.gt.1) then
9650 #ifdef MOMENT
9651         s1=dipderg(3,jj,i)*dip(1,kk,k)
9652 #endif
9653         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9654         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9655         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9656         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9657         vv(1)=pizda(1,1)-pizda(2,2)
9658         vv(2)=pizda(1,2)+pizda(2,1)
9659         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9660 #ifdef MOMENT
9661         if (swap) then
9662           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9663         else
9664           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9665         endif
9666 #endif
9667         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9668 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9669       endif
9670 C Derivatives in gamma(l-1) or gamma(j-1)
9671       if (l.gt.1) then
9672 #ifdef MOMENT
9673         s1=dip(1,jj,i)*dipderg(3,kk,k)
9674 #endif
9675         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9676         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9677         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9678         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9679         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9680         vv(1)=pizda(1,1)-pizda(2,2)
9681         vv(2)=pizda(1,2)+pizda(2,1)
9682         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9683 #ifdef MOMENT
9684         if (swap) then
9685           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9686         else
9687           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9688         endif
9689 #endif
9690         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9691 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9692       endif
9693 C Cartesian derivatives.
9694       if (lprn) then
9695         write (2,*) 'In eello6_graph2'
9696         do iii=1,2
9697           write (2,*) 'iii=',iii
9698           do kkk=1,5
9699             write (2,*) 'kkk=',kkk
9700             do jjj=1,2
9701               write (2,'(3(2f10.5),5x)')
9702      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9703             enddo
9704           enddo
9705         enddo
9706       endif
9707       do iii=1,2
9708         do kkk=1,5
9709           do lll=1,3
9710 #ifdef MOMENT
9711             if (iii.eq.1) then
9712               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9713             else
9714               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9715             endif
9716 #endif
9717             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9718      &        auxvec(1))
9719             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9720             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9721      &        auxvec(1))
9722             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9723             call transpose2(EUg(1,1,k),auxmat(1,1))
9724             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9725      &        pizda(1,1))
9726             vv(1)=pizda(1,1)-pizda(2,2)
9727             vv(2)=pizda(1,2)+pizda(2,1)
9728             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9729 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9730 #ifdef MOMENT
9731             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9732 #else
9733             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9734 #endif
9735             if (swap) then
9736               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9737             else
9738               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9739             endif
9740           enddo
9741         enddo
9742       enddo
9743       endif ! calc_grad
9744       return
9745       end
9746 c----------------------------------------------------------------------------
9747       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9748       implicit real*8 (a-h,o-z)
9749       include 'DIMENSIONS'
9750       include 'DIMENSIONS.ZSCOPT'
9751       include 'COMMON.IOUNITS'
9752       include 'COMMON.CHAIN'
9753       include 'COMMON.DERIV'
9754       include 'COMMON.INTERACT'
9755       include 'COMMON.CONTACTS'
9756       include 'COMMON.TORSION'
9757       include 'COMMON.VAR'
9758       include 'COMMON.GEO'
9759       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9760       logical swap
9761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9762 C                                                                              C
9763 C      Parallel       Antiparallel                                             C
9764 C                                                                              C
9765 C          o             o                                                     C
9766 C         /l\   /   \   /j\                                                    C
9767 C        /   \ /     \ /   \                                                   C
9768 C       /| o |o       o| o |\                                                  C
9769 C       j|/k\|  /      |/k\|l /                                                C
9770 C        /   \ /       /   \ /                                                 C
9771 C       /     o       /     o                                                  C
9772 C       i             i                                                        C
9773 C                                                                              C
9774 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9775 C
9776 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9777 C           energy moment and not to the cluster cumulant.
9778       iti=itortyp(itype(i))
9779       if (j.lt.nres-1) then
9780         itj1=itype2loc(itype(j+1))
9781       else
9782         itj1=nloctyp
9783       endif
9784       itk=itype2loc(itype(k))
9785       itk1=itype2loc(itype(k+1))
9786       if (l.lt.nres-1) then
9787         itl1=itype2loc(itype(l+1))
9788       else
9789         itl1=nloctyp
9790       endif
9791 #ifdef MOMENT
9792       s1=dip(4,jj,i)*dip(4,kk,k)
9793 #endif
9794       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9795       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9796       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9797       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9798       call transpose2(EE(1,1,k),auxmat(1,1))
9799       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9800       vv(1)=pizda(1,1)+pizda(2,2)
9801       vv(2)=pizda(2,1)-pizda(1,2)
9802       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9803 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9804 cd     & "sum",-(s2+s3+s4)
9805 #ifdef MOMENT
9806       eello6_graph3=-(s1+s2+s3+s4)
9807 #else
9808       eello6_graph3=-(s2+s3+s4)
9809 #endif
9810 c      eello6_graph3=-s4
9811 C Derivatives in gamma(k-1)
9812       if (calc_grad) then
9813       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9814       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9815       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9816       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9817 C Derivatives in gamma(l-1)
9818       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9819       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9820       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9821       vv(1)=pizda(1,1)+pizda(2,2)
9822       vv(2)=pizda(2,1)-pizda(1,2)
9823       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9824       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9825 C Cartesian derivatives.
9826       do iii=1,2
9827         do kkk=1,5
9828           do lll=1,3
9829 #ifdef MOMENT
9830             if (iii.eq.1) then
9831               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9832             else
9833               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9834             endif
9835 #endif
9836             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9837      &        auxvec(1))
9838             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9839             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9840      &        auxvec(1))
9841             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9842             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9843      &        pizda(1,1))
9844             vv(1)=pizda(1,1)+pizda(2,2)
9845             vv(2)=pizda(2,1)-pizda(1,2)
9846             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9847 #ifdef MOMENT
9848             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9849 #else
9850             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9851 #endif
9852             if (swap) then
9853               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9854             else
9855               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9856             endif
9857 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9858           enddo
9859         enddo
9860       enddo
9861       endif ! calc_grad
9862       return
9863       end
9864 c----------------------------------------------------------------------------
9865       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9866       implicit real*8 (a-h,o-z)
9867       include 'DIMENSIONS'
9868       include 'DIMENSIONS.ZSCOPT'
9869       include 'COMMON.IOUNITS'
9870       include 'COMMON.CHAIN'
9871       include 'COMMON.DERIV'
9872       include 'COMMON.INTERACT'
9873       include 'COMMON.CONTACTS'
9874       include 'COMMON.TORSION'
9875       include 'COMMON.VAR'
9876       include 'COMMON.GEO'
9877       include 'COMMON.FFIELD'
9878       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9879      & auxvec1(2),auxmat1(2,2)
9880       logical swap
9881 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9882 C                                                                              C
9883 C      Parallel       Antiparallel                                             C
9884 C                                                                              C
9885 C          o             o                                                     C
9886 C         /l\   /   \   /j\                                                    C
9887 C        /   \ /     \ /   \                                                   C
9888 C       /| o |o       o| o |\                                                  C
9889 C     \ j|/k\|      \  |/k\|l                                                  C
9890 C      \ /   \       \ /   \                                                   C
9891 C       o     \       o     \                                                  C
9892 C       i             i                                                        C
9893 C                                                                              C
9894 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9895 C
9896 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9897 C           energy moment and not to the cluster cumulant.
9898 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9899       iti=itype2loc(itype(i))
9900       itj=itype2loc(itype(j))
9901       if (j.lt.nres-1) then
9902         itj1=itype2loc(itype(j+1))
9903       else
9904         itj1=nloctyp
9905       endif
9906       itk=itype2loc(itype(k))
9907       if (k.lt.nres-1) then
9908         itk1=itype2loc(itype(k+1))
9909       else
9910         itk1=nloctyp
9911       endif
9912       itl=itype2loc(itype(l))
9913       if (l.lt.nres-1) then
9914         itl1=itype2loc(itype(l+1))
9915       else
9916         itl1=nloctyp
9917       endif
9918 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9919 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9920 cd     & ' itl',itl,' itl1',itl1
9921 #ifdef MOMENT
9922       if (imat.eq.1) then
9923         s1=dip(3,jj,i)*dip(3,kk,k)
9924       else
9925         s1=dip(2,jj,j)*dip(2,kk,l)
9926       endif
9927 #endif
9928       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9929       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9930       if (j.eq.l+1) then
9931         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9932         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9933       else
9934         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9935         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9936       endif
9937       call transpose2(EUg(1,1,k),auxmat(1,1))
9938       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9939       vv(1)=pizda(1,1)-pizda(2,2)
9940       vv(2)=pizda(2,1)+pizda(1,2)
9941       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9942 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9943 #ifdef MOMENT
9944       eello6_graph4=-(s1+s2+s3+s4)
9945 #else
9946       eello6_graph4=-(s2+s3+s4)
9947 #endif
9948 C Derivatives in gamma(i-1)
9949       if (calc_grad) then
9950       if (i.gt.1) then
9951 #ifdef MOMENT
9952         if (imat.eq.1) then
9953           s1=dipderg(2,jj,i)*dip(3,kk,k)
9954         else
9955           s1=dipderg(4,jj,j)*dip(2,kk,l)
9956         endif
9957 #endif
9958         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9959         if (j.eq.l+1) then
9960           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9961           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9962         else
9963           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9964           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9965         endif
9966         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9967         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9968 cd          write (2,*) 'turn6 derivatives'
9969 #ifdef MOMENT
9970           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9971 #else
9972           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9973 #endif
9974         else
9975 #ifdef MOMENT
9976           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9977 #else
9978           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9979 #endif
9980         endif
9981       endif
9982 C Derivatives in gamma(k-1)
9983 #ifdef MOMENT
9984       if (imat.eq.1) then
9985         s1=dip(3,jj,i)*dipderg(2,kk,k)
9986       else
9987         s1=dip(2,jj,j)*dipderg(4,kk,l)
9988       endif
9989 #endif
9990       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9991       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9992       if (j.eq.l+1) then
9993         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9994         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9995       else
9996         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9997         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9998       endif
9999       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10000       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10001       vv(1)=pizda(1,1)-pizda(2,2)
10002       vv(2)=pizda(2,1)+pizda(1,2)
10003       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10004       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10005 #ifdef MOMENT
10006         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10007 #else
10008         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10009 #endif
10010       else
10011 #ifdef MOMENT
10012         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10013 #else
10014         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10015 #endif
10016       endif
10017 C Derivatives in gamma(j-1) or gamma(l-1)
10018       if (l.eq.j+1 .and. l.gt.1) then
10019         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10020         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10021         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10022         vv(1)=pizda(1,1)-pizda(2,2)
10023         vv(2)=pizda(2,1)+pizda(1,2)
10024         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10025         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10026       else if (j.gt.1) then
10027         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10028         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10029         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10030         vv(1)=pizda(1,1)-pizda(2,2)
10031         vv(2)=pizda(2,1)+pizda(1,2)
10032         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10033         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10034           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10035         else
10036           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10037         endif
10038       endif
10039 C Cartesian derivatives.
10040       do iii=1,2
10041         do kkk=1,5
10042           do lll=1,3
10043 #ifdef MOMENT
10044             if (iii.eq.1) then
10045               if (imat.eq.1) then
10046                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10047               else
10048                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10049               endif
10050             else
10051               if (imat.eq.1) then
10052                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10053               else
10054                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10055               endif
10056             endif
10057 #endif
10058             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10059      &        auxvec(1))
10060             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10061             if (j.eq.l+1) then
10062               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10063      &          b1(1,j+1),auxvec(1))
10064               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10065             else
10066               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10067      &          b1(1,l+1),auxvec(1))
10068               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10069             endif
10070             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10071      &        pizda(1,1))
10072             vv(1)=pizda(1,1)-pizda(2,2)
10073             vv(2)=pizda(2,1)+pizda(1,2)
10074             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10075             if (swap) then
10076               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10077 #ifdef MOMENT
10078                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10079      &             -(s1+s2+s4)
10080 #else
10081                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10082      &             -(s2+s4)
10083 #endif
10084                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10085               else
10086 #ifdef MOMENT
10087                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10088 #else
10089                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10090 #endif
10091                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10092               endif
10093             else
10094 #ifdef MOMENT
10095               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10096 #else
10097               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10098 #endif
10099               if (l.eq.j+1) then
10100                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10101               else
10102                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10103               endif
10104             endif
10105           enddo
10106         enddo
10107       enddo
10108       endif ! calc_grad
10109       return
10110       end
10111 c----------------------------------------------------------------------------
10112       double precision function eello_turn6(i,jj,kk)
10113       implicit real*8 (a-h,o-z)
10114       include 'DIMENSIONS'
10115       include 'DIMENSIONS.ZSCOPT'
10116       include 'COMMON.IOUNITS'
10117       include 'COMMON.CHAIN'
10118       include 'COMMON.DERIV'
10119       include 'COMMON.INTERACT'
10120       include 'COMMON.CONTACTS'
10121       include 'COMMON.TORSION'
10122       include 'COMMON.VAR'
10123       include 'COMMON.GEO'
10124       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10125      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10126      &  ggg1(3),ggg2(3)
10127       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10128      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10129 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10130 C           the respective energy moment and not to the cluster cumulant.
10131       s1=0.0d0
10132       s8=0.0d0
10133       s13=0.0d0
10134 c
10135       eello_turn6=0.0d0
10136       j=i+4
10137       k=i+1
10138       l=i+3
10139       iti=itype2loc(itype(i))
10140       itk=itype2loc(itype(k))
10141       itk1=itype2loc(itype(k+1))
10142       itl=itype2loc(itype(l))
10143       itj=itype2loc(itype(j))
10144 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10145 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10146 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10147 cd        eello6=0.0d0
10148 cd        return
10149 cd      endif
10150 cd      write (iout,*)
10151 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10152 cd     &   ' and',k,l
10153 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10154       do iii=1,2
10155         do kkk=1,5
10156           do lll=1,3
10157             derx_turn(lll,kkk,iii)=0.0d0
10158           enddo
10159         enddo
10160       enddo
10161 cd      eij=1.0d0
10162 cd      ekl=1.0d0
10163 cd      ekont=1.0d0
10164       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10165 cd      eello6_5=0.0d0
10166 cd      write (2,*) 'eello6_5',eello6_5
10167 #ifdef MOMENT
10168       call transpose2(AEA(1,1,1),auxmat(1,1))
10169       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10170       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10171       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10172 #endif
10173       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10174       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10175       s2 = scalar2(b1(1,k),vtemp1(1))
10176 #ifdef MOMENT
10177       call transpose2(AEA(1,1,2),atemp(1,1))
10178       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10179       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10180       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10181 #endif
10182       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10183       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10184       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10185 #ifdef MOMENT
10186       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10187       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10188       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10189       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10190       ss13 = scalar2(b1(1,k),vtemp4(1))
10191       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10192 #endif
10193 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10194 c      s1=0.0d0
10195 c      s2=0.0d0
10196 c      s8=0.0d0
10197 c      s12=0.0d0
10198 c      s13=0.0d0
10199       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10200 C Derivatives in gamma(i+2)
10201       if (calc_grad) then
10202       s1d =0.0d0
10203       s8d =0.0d0
10204 #ifdef MOMENT
10205       call transpose2(AEA(1,1,1),auxmatd(1,1))
10206       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10207       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10208       call transpose2(AEAderg(1,1,2),atempd(1,1))
10209       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10210       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10211 #endif
10212       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10213       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10214       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10215 c      s1d=0.0d0
10216 c      s2d=0.0d0
10217 c      s8d=0.0d0
10218 c      s12d=0.0d0
10219 c      s13d=0.0d0
10220       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10221 C Derivatives in gamma(i+3)
10222 #ifdef MOMENT
10223       call transpose2(AEA(1,1,1),auxmatd(1,1))
10224       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10225       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10226       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10227 #endif
10228       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10229       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10230       s2d = scalar2(b1(1,k),vtemp1d(1))
10231 #ifdef MOMENT
10232       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10233       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10234 #endif
10235       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10236 #ifdef MOMENT
10237       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10238       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10239       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10240 #endif
10241 c      s1d=0.0d0
10242 c      s2d=0.0d0
10243 c      s8d=0.0d0
10244 c      s12d=0.0d0
10245 c      s13d=0.0d0
10246 #ifdef MOMENT
10247       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10248      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10249 #else
10250       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10251      &               -0.5d0*ekont*(s2d+s12d)
10252 #endif
10253 C Derivatives in gamma(i+4)
10254       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10255       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10256       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10257 #ifdef MOMENT
10258       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10259       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10260       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10261 #endif
10262 c      s1d=0.0d0
10263 c      s2d=0.0d0
10264 c      s8d=0.0d0
10265 C      s12d=0.0d0
10266 c      s13d=0.0d0
10267 #ifdef MOMENT
10268       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10269 #else
10270       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10271 #endif
10272 C Derivatives in gamma(i+5)
10273 #ifdef MOMENT
10274       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10275       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10276       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10277 #endif
10278       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10279       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10280       s2d = scalar2(b1(1,k),vtemp1d(1))
10281 #ifdef MOMENT
10282       call transpose2(AEA(1,1,2),atempd(1,1))
10283       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10284       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10285 #endif
10286       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10287       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10288 #ifdef MOMENT
10289       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10290       ss13d = scalar2(b1(1,k),vtemp4d(1))
10291       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10292 #endif
10293 c      s1d=0.0d0
10294 c      s2d=0.0d0
10295 c      s8d=0.0d0
10296 c      s12d=0.0d0
10297 c      s13d=0.0d0
10298 #ifdef MOMENT
10299       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10300      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10301 #else
10302       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10303      &               -0.5d0*ekont*(s2d+s12d)
10304 #endif
10305 C Cartesian derivatives
10306       do iii=1,2
10307         do kkk=1,5
10308           do lll=1,3
10309 #ifdef MOMENT
10310             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10311             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10312             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10313 #endif
10314             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10315             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10316      &          vtemp1d(1))
10317             s2d = scalar2(b1(1,k),vtemp1d(1))
10318 #ifdef MOMENT
10319             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10320             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10321             s8d = -(atempd(1,1)+atempd(2,2))*
10322      &           scalar2(cc(1,1,l),vtemp2(1))
10323 #endif
10324             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10325      &           auxmatd(1,1))
10326             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10327             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10328 c      s1d=0.0d0
10329 c      s2d=0.0d0
10330 c      s8d=0.0d0
10331 c      s12d=0.0d0
10332 c      s13d=0.0d0
10333 #ifdef MOMENT
10334             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10335      &        - 0.5d0*(s1d+s2d)
10336 #else
10337             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10338      &        - 0.5d0*s2d
10339 #endif
10340 #ifdef MOMENT
10341             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10342      &        - 0.5d0*(s8d+s12d)
10343 #else
10344             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10345      &        - 0.5d0*s12d
10346 #endif
10347           enddo
10348         enddo
10349       enddo
10350 #ifdef MOMENT
10351       do kkk=1,5
10352         do lll=1,3
10353           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10354      &      achuj_tempd(1,1))
10355           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10356           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10357           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10358           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10359           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10360      &      vtemp4d(1))
10361           ss13d = scalar2(b1(1,k),vtemp4d(1))
10362           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10363           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10364         enddo
10365       enddo
10366 #endif
10367 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10368 cd     &  16*eel_turn6_num
10369 cd      goto 1112
10370       if (j.lt.nres-1) then
10371         j1=j+1
10372         j2=j-1
10373       else
10374         j1=j-1
10375         j2=j-2
10376       endif
10377       if (l.lt.nres-1) then
10378         l1=l+1
10379         l2=l-1
10380       else
10381         l1=l-1
10382         l2=l-2
10383       endif
10384       do ll=1,3
10385 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10386 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10387 cgrad        ghalf=0.5d0*ggg1(ll)
10388 cd        ghalf=0.0d0
10389         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10390         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10391         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10392      &    +ekont*derx_turn(ll,2,1)
10393         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10394         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10395      &    +ekont*derx_turn(ll,4,1)
10396         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10397         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10398         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10399 cgrad        ghalf=0.5d0*ggg2(ll)
10400 cd        ghalf=0.0d0
10401         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10402      &    +ekont*derx_turn(ll,2,2)
10403         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10404         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10405      &    +ekont*derx_turn(ll,4,2)
10406         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10407         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10408         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10409       enddo
10410 cd      goto 1112
10411 cgrad      do m=i+1,j-1
10412 cgrad        do ll=1,3
10413 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10414 cgrad        enddo
10415 cgrad      enddo
10416 cgrad      do m=k+1,l-1
10417 cgrad        do ll=1,3
10418 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10419 cgrad        enddo
10420 cgrad      enddo
10421 cgrad1112  continue
10422 cgrad      do m=i+2,j2
10423 cgrad        do ll=1,3
10424 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10425 cgrad        enddo
10426 cgrad      enddo
10427 cgrad      do m=k+2,l2
10428 cgrad        do ll=1,3
10429 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10430 cgrad        enddo
10431 cgrad      enddo
10432 cd      do iii=1,nres-3
10433 cd        write (2,*) iii,g_corr6_loc(iii)
10434 cd      enddo
10435       endif ! calc_grad
10436       eello_turn6=ekont*eel_turn6
10437 cd      write (2,*) 'ekont',ekont
10438 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10439       return
10440       end
10441
10442 crc-------------------------------------------------
10443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10444       subroutine Eliptransfer(eliptran)
10445       implicit real*8 (a-h,o-z)
10446       include 'DIMENSIONS'
10447       include 'DIMENSIONS.ZSCOPT'
10448       include 'COMMON.GEO'
10449       include 'COMMON.VAR'
10450       include 'COMMON.LOCAL'
10451       include 'COMMON.CHAIN'
10452       include 'COMMON.DERIV'
10453       include 'COMMON.INTERACT'
10454       include 'COMMON.IOUNITS'
10455       include 'COMMON.CALC'
10456       include 'COMMON.CONTROL'
10457       include 'COMMON.SPLITELE'
10458       include 'COMMON.SBRIDGE'
10459 C this is done by Adasko
10460 C      print *,"wchodze"
10461 C structure of box:
10462 C      water
10463 C--bordliptop-- buffore starts
10464 C--bufliptop--- here true lipid starts
10465 C      lipid
10466 C--buflipbot--- lipid ends buffore starts
10467 C--bordlipbot--buffore ends
10468       eliptran=0.0
10469       do i=1,nres
10470 C       do i=1,1
10471         if (itype(i).eq.ntyp1) cycle
10472
10473         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10474         if (positi.le.0) positi=positi+boxzsize
10475 C        print *,i
10476 C first for peptide groups
10477 c for each residue check if it is in lipid or lipid water border area
10478        if ((positi.gt.bordlipbot)
10479      &.and.(positi.lt.bordliptop)) then
10480 C the energy transfer exist
10481         if (positi.lt.buflipbot) then
10482 C what fraction I am in
10483          fracinbuf=1.0d0-
10484      &        ((positi-bordlipbot)/lipbufthick)
10485 C lipbufthick is thickenes of lipid buffore
10486          sslip=sscalelip(fracinbuf)
10487          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10488          eliptran=eliptran+sslip*pepliptran
10489          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10490          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10491 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10492         elseif (positi.gt.bufliptop) then
10493          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10494          sslip=sscalelip(fracinbuf)
10495          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10496          eliptran=eliptran+sslip*pepliptran
10497          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10498          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10499 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10500 C          print *, "doing sscalefor top part"
10501 C         print *,i,sslip,fracinbuf,ssgradlip
10502         else
10503          eliptran=eliptran+pepliptran
10504 C         print *,"I am in true lipid"
10505         endif
10506 C       else
10507 C       eliptran=elpitran+0.0 ! I am in water
10508        endif
10509        enddo
10510 C       print *, "nic nie bylo w lipidzie?"
10511 C now multiply all by the peptide group transfer factor
10512 C       eliptran=eliptran*pepliptran
10513 C now the same for side chains
10514 CV       do i=1,1
10515        do i=1,nres
10516         if (itype(i).eq.ntyp1) cycle
10517         positi=(mod(c(3,i+nres),boxzsize))
10518         if (positi.le.0) positi=positi+boxzsize
10519 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10520 c for each residue check if it is in lipid or lipid water border area
10521 C       respos=mod(c(3,i+nres),boxzsize)
10522 C       print *,positi,bordlipbot,buflipbot
10523        if ((positi.gt.bordlipbot)
10524      & .and.(positi.lt.bordliptop)) then
10525 C the energy transfer exist
10526         if (positi.lt.buflipbot) then
10527          fracinbuf=1.0d0-
10528      &     ((positi-bordlipbot)/lipbufthick)
10529 C lipbufthick is thickenes of lipid buffore
10530          sslip=sscalelip(fracinbuf)
10531          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10532          eliptran=eliptran+sslip*liptranene(itype(i))
10533          gliptranx(3,i)=gliptranx(3,i)
10534      &+ssgradlip*liptranene(itype(i))
10535          gliptranc(3,i-1)= gliptranc(3,i-1)
10536      &+ssgradlip*liptranene(itype(i))
10537 C         print *,"doing sccale for lower part"
10538         elseif (positi.gt.bufliptop) then
10539          fracinbuf=1.0d0-
10540      &((bordliptop-positi)/lipbufthick)
10541          sslip=sscalelip(fracinbuf)
10542          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10543          eliptran=eliptran+sslip*liptranene(itype(i))
10544          gliptranx(3,i)=gliptranx(3,i)
10545      &+ssgradlip*liptranene(itype(i))
10546          gliptranc(3,i-1)= gliptranc(3,i-1)
10547      &+ssgradlip*liptranene(itype(i))
10548 C          print *, "doing sscalefor top part",sslip,fracinbuf
10549         else
10550          eliptran=eliptran+liptranene(itype(i))
10551 C         print *,"I am in true lipid"
10552         endif
10553         endif ! if in lipid or buffor
10554 C       else
10555 C       eliptran=elpitran+0.0 ! I am in water
10556        enddo
10557        return
10558        end
10559
10560
10561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10562
10563       SUBROUTINE MATVEC2(A1,V1,V2)
10564       implicit real*8 (a-h,o-z)
10565       include 'DIMENSIONS'
10566       DIMENSION A1(2,2),V1(2),V2(2)
10567 c      DO 1 I=1,2
10568 c        VI=0.0
10569 c        DO 3 K=1,2
10570 c    3     VI=VI+A1(I,K)*V1(K)
10571 c        Vaux(I)=VI
10572 c    1 CONTINUE
10573
10574       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10575       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10576
10577       v2(1)=vaux1
10578       v2(2)=vaux2
10579       END
10580 C---------------------------------------
10581       SUBROUTINE MATMAT2(A1,A2,A3)
10582       implicit real*8 (a-h,o-z)
10583       include 'DIMENSIONS'
10584       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10585 c      DIMENSION AI3(2,2)
10586 c        DO  J=1,2
10587 c          A3IJ=0.0
10588 c          DO K=1,2
10589 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10590 c          enddo
10591 c          A3(I,J)=A3IJ
10592 c       enddo
10593 c      enddo
10594
10595       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10596       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10597       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10598       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10599
10600       A3(1,1)=AI3_11
10601       A3(2,1)=AI3_21
10602       A3(1,2)=AI3_12
10603       A3(2,2)=AI3_22
10604       END
10605
10606 c-------------------------------------------------------------------------
10607       double precision function scalar2(u,v)
10608       implicit none
10609       double precision u(2),v(2)
10610       double precision sc
10611       integer i
10612       scalar2=u(1)*v(1)+u(2)*v(2)
10613       return
10614       end
10615
10616 C-----------------------------------------------------------------------------
10617
10618       subroutine transpose2(a,at)
10619       implicit none
10620       double precision a(2,2),at(2,2)
10621       at(1,1)=a(1,1)
10622       at(1,2)=a(2,1)
10623       at(2,1)=a(1,2)
10624       at(2,2)=a(2,2)
10625       return
10626       end
10627 c--------------------------------------------------------------------------
10628       subroutine transpose(n,a,at)
10629       implicit none
10630       integer n,i,j
10631       double precision a(n,n),at(n,n)
10632       do i=1,n
10633         do j=1,n
10634           at(j,i)=a(i,j)
10635         enddo
10636       enddo
10637       return
10638       end
10639 C---------------------------------------------------------------------------
10640       subroutine prodmat3(a1,a2,kk,transp,prod)
10641       implicit none
10642       integer i,j
10643       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10644       logical transp
10645 crc      double precision auxmat(2,2),prod_(2,2)
10646
10647       if (transp) then
10648 crc        call transpose2(kk(1,1),auxmat(1,1))
10649 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10650 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10651
10652            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10653      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10654            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10655      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10656            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10657      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10658            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10659      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10660
10661       else
10662 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10663 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10664
10665            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10666      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10667            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10668      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10669            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10670      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10671            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10672      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10673
10674       endif
10675 c      call transpose2(a2(1,1),a2t(1,1))
10676
10677 crc      print *,transp
10678 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10679 crc      print *,((prod(i,j),i=1,2),j=1,2)
10680
10681       return
10682       end
10683 C-----------------------------------------------------------------------------
10684       double precision function scalar(u,v)
10685       implicit none
10686       double precision u(3),v(3)
10687       double precision sc
10688       integer i
10689       sc=0.0d0
10690       do i=1,3
10691         sc=sc+u(i)*v(i)
10692       enddo
10693       scalar=sc
10694       return
10695       end
10696 C-----------------------------------------------------------------------
10697       double precision function sscale(r)
10698       double precision r,gamm
10699       include "COMMON.SPLITELE"
10700       if(r.lt.r_cut-rlamb) then
10701         sscale=1.0d0
10702       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10703         gamm=(r-(r_cut-rlamb))/rlamb
10704         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10705       else
10706         sscale=0d0
10707       endif
10708       return
10709       end
10710 C-----------------------------------------------------------------------
10711 C-----------------------------------------------------------------------
10712       double precision function sscagrad(r)
10713       double precision r,gamm
10714       include "COMMON.SPLITELE"
10715       if(r.lt.r_cut-rlamb) then
10716         sscagrad=0.0d0
10717       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10718         gamm=(r-(r_cut-rlamb))/rlamb
10719         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10720       else
10721         sscagrad=0.0d0
10722       endif
10723       return
10724       end
10725 C-----------------------------------------------------------------------
10726 C-----------------------------------------------------------------------
10727       double precision function sscalelip(r)
10728       double precision r,gamm
10729       include "COMMON.SPLITELE"
10730 C      if(r.lt.r_cut-rlamb) then
10731 C        sscale=1.0d0
10732 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10733 C        gamm=(r-(r_cut-rlamb))/rlamb
10734         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10735 C      else
10736 C        sscale=0d0
10737 C      endif
10738       return
10739       end
10740 C-----------------------------------------------------------------------
10741       double precision function sscagradlip(r)
10742       double precision r,gamm
10743       include "COMMON.SPLITELE"
10744 C     if(r.lt.r_cut-rlamb) then
10745 C        sscagrad=0.0d0
10746 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10747 C        gamm=(r-(r_cut-rlamb))/rlamb
10748         sscagradlip=r*(6*r-6.0d0)
10749 C      else
10750 C        sscagrad=0.0d0
10751 C      endif
10752       return
10753       end
10754
10755 C-----------------------------------------------------------------------
10756        subroutine set_shield_fac
10757       implicit real*8 (a-h,o-z)
10758       include 'DIMENSIONS'
10759       include 'DIMENSIONS.ZSCOPT'
10760       include 'COMMON.CHAIN'
10761       include 'COMMON.DERIV'
10762       include 'COMMON.IOUNITS'
10763       include 'COMMON.SHIELD'
10764       include 'COMMON.INTERACT'
10765 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10766       double precision div77_81/0.974996043d0/,
10767      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10768
10769 C the vector between center of side_chain and peptide group
10770        double precision pep_side(3),long,side_calf(3),
10771      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10772      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10773 C the line belowe needs to be changed for FGPROC>1
10774       do i=1,nres-1
10775       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10776       ishield_list(i)=0
10777 Cif there two consequtive dummy atoms there is no peptide group between them
10778 C the line below has to be changed for FGPROC>1
10779       VolumeTotal=0.0
10780       do k=1,nres
10781        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10782        dist_pep_side=0.0
10783        dist_side_calf=0.0
10784        do j=1,3
10785 C first lets set vector conecting the ithe side-chain with kth side-chain
10786       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10787 C      pep_side(j)=2.0d0
10788 C and vector conecting the side-chain with its proper calfa
10789       side_calf(j)=c(j,k+nres)-c(j,k)
10790 C      side_calf(j)=2.0d0
10791       pept_group(j)=c(j,i)-c(j,i+1)
10792 C lets have their lenght
10793       dist_pep_side=pep_side(j)**2+dist_pep_side
10794       dist_side_calf=dist_side_calf+side_calf(j)**2
10795       dist_pept_group=dist_pept_group+pept_group(j)**2
10796       enddo
10797        dist_pep_side=dsqrt(dist_pep_side)
10798        dist_pept_group=dsqrt(dist_pept_group)
10799        dist_side_calf=dsqrt(dist_side_calf)
10800       do j=1,3
10801         pep_side_norm(j)=pep_side(j)/dist_pep_side
10802         side_calf_norm(j)=dist_side_calf
10803       enddo
10804 C now sscale fraction
10805        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10806 C       print *,buff_shield,"buff"
10807 C now sscale
10808         if (sh_frac_dist.le.0.0) cycle
10809 C If we reach here it means that this side chain reaches the shielding sphere
10810 C Lets add him to the list for gradient
10811         ishield_list(i)=ishield_list(i)+1
10812 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10813 C this list is essential otherwise problem would be O3
10814         shield_list(ishield_list(i),i)=k
10815 C Lets have the sscale value
10816         if (sh_frac_dist.gt.1.0) then
10817          scale_fac_dist=1.0d0
10818          do j=1,3
10819          sh_frac_dist_grad(j)=0.0d0
10820          enddo
10821         else
10822          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10823      &                   *(2.0*sh_frac_dist-3.0d0)
10824          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10825      &                  /dist_pep_side/buff_shield*0.5
10826 C remember for the final gradient multiply sh_frac_dist_grad(j)
10827 C for side_chain by factor -2 !
10828          do j=1,3
10829          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10830 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10831 C     &                    sh_frac_dist_grad(j)
10832          enddo
10833         endif
10834 C        if ((i.eq.3).and.(k.eq.2)) then
10835 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10836 C     & ,"TU"
10837 C        endif
10838
10839 C this is what is now we have the distance scaling now volume...
10840       short=short_r_sidechain(itype(k))
10841       long=long_r_sidechain(itype(k))
10842       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10843 C now costhet_grad
10844 C       costhet=0.0d0
10845        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10846 C       costhet_fac=0.0d0
10847        do j=1,3
10848          costhet_grad(j)=costhet_fac*pep_side(j)
10849        enddo
10850 C remember for the final gradient multiply costhet_grad(j)
10851 C for side_chain by factor -2 !
10852 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10853 C pep_side0pept_group is vector multiplication
10854       pep_side0pept_group=0.0
10855       do j=1,3
10856       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10857       enddo
10858       cosalfa=(pep_side0pept_group/
10859      & (dist_pep_side*dist_side_calf))
10860       fac_alfa_sin=1.0-cosalfa**2
10861       fac_alfa_sin=dsqrt(fac_alfa_sin)
10862       rkprim=fac_alfa_sin*(long-short)+short
10863 C now costhet_grad
10864        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10865        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10866
10867        do j=1,3
10868          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10869      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10870      &*(long-short)/fac_alfa_sin*cosalfa/
10871      &((dist_pep_side*dist_side_calf))*
10872      &((side_calf(j))-cosalfa*
10873      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10874
10875         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10876      &*(long-short)/fac_alfa_sin*cosalfa
10877      &/((dist_pep_side*dist_side_calf))*
10878      &(pep_side(j)-
10879      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10880        enddo
10881
10882       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10883      &                    /VSolvSphere_div
10884      &                    *wshield
10885 C now the gradient...
10886 C grad_shield is gradient of Calfa for peptide groups
10887 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10888 C     &               costhet,cosphi
10889 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10890 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10891       do j=1,3
10892       grad_shield(j,i)=grad_shield(j,i)
10893 C gradient po skalowaniu
10894      &                +(sh_frac_dist_grad(j)
10895 C  gradient po costhet
10896      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10897      &-scale_fac_dist*(cosphi_grad_long(j))
10898      &/(1.0-cosphi) )*div77_81
10899      &*VofOverlap
10900 C grad_shield_side is Cbeta sidechain gradient
10901       grad_shield_side(j,ishield_list(i),i)=
10902      &        (sh_frac_dist_grad(j)*-2.0d0
10903      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10904      &       +scale_fac_dist*(cosphi_grad_long(j))
10905      &        *2.0d0/(1.0-cosphi))
10906      &        *div77_81*VofOverlap
10907
10908        grad_shield_loc(j,ishield_list(i),i)=
10909      &   scale_fac_dist*cosphi_grad_loc(j)
10910      &        *2.0d0/(1.0-cosphi)
10911      &        *div77_81*VofOverlap
10912       enddo
10913       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10914       enddo
10915       fac_shield(i)=VolumeTotal*div77_81+div4_81
10916 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10917       enddo
10918       return
10919       end
10920 C--------------------------------------------------------------------------
10921 C first for shielding is setting of function of side-chains
10922        subroutine set_shield_fac2
10923       implicit real*8 (a-h,o-z)
10924       include 'DIMENSIONS'
10925       include 'DIMENSIONS.ZSCOPT'
10926       include 'COMMON.CHAIN'
10927       include 'COMMON.DERIV'
10928       include 'COMMON.IOUNITS'
10929       include 'COMMON.SHIELD'
10930       include 'COMMON.INTERACT'
10931 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10932       double precision div77_81/0.974996043d0/,
10933      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10934
10935 C the vector between center of side_chain and peptide group
10936        double precision pep_side(3),long,side_calf(3),
10937      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10938      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10939 C the line belowe needs to be changed for FGPROC>1
10940       do i=1,nres-1
10941       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10942       ishield_list(i)=0
10943 Cif there two consequtive dummy atoms there is no peptide group between them
10944 C the line below has to be changed for FGPROC>1
10945       VolumeTotal=0.0
10946       do k=1,nres
10947        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10948        dist_pep_side=0.0
10949        dist_side_calf=0.0
10950        do j=1,3
10951 C first lets set vector conecting the ithe side-chain with kth side-chain
10952       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10953 C      pep_side(j)=2.0d0
10954 C and vector conecting the side-chain with its proper calfa
10955       side_calf(j)=c(j,k+nres)-c(j,k)
10956 C      side_calf(j)=2.0d0
10957       pept_group(j)=c(j,i)-c(j,i+1)
10958 C lets have their lenght
10959       dist_pep_side=pep_side(j)**2+dist_pep_side
10960       dist_side_calf=dist_side_calf+side_calf(j)**2
10961       dist_pept_group=dist_pept_group+pept_group(j)**2
10962       enddo
10963        dist_pep_side=dsqrt(dist_pep_side)
10964        dist_pept_group=dsqrt(dist_pept_group)
10965        dist_side_calf=dsqrt(dist_side_calf)
10966       do j=1,3
10967         pep_side_norm(j)=pep_side(j)/dist_pep_side
10968         side_calf_norm(j)=dist_side_calf
10969       enddo
10970 C now sscale fraction
10971        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10972 C       print *,buff_shield,"buff"
10973 C now sscale
10974         if (sh_frac_dist.le.0.0) cycle
10975 C If we reach here it means that this side chain reaches the shielding sphere
10976 C Lets add him to the list for gradient
10977         ishield_list(i)=ishield_list(i)+1
10978 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10979 C this list is essential otherwise problem would be O3
10980         shield_list(ishield_list(i),i)=k
10981 C Lets have the sscale value
10982         if (sh_frac_dist.gt.1.0) then
10983          scale_fac_dist=1.0d0
10984          do j=1,3
10985          sh_frac_dist_grad(j)=0.0d0
10986          enddo
10987         else
10988          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10989      &                   *(2.0d0*sh_frac_dist-3.0d0)
10990          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10991      &                  /dist_pep_side/buff_shield*0.5d0
10992 C remember for the final gradient multiply sh_frac_dist_grad(j)
10993 C for side_chain by factor -2 !
10994          do j=1,3
10995          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10996 C         sh_frac_dist_grad(j)=0.0d0
10997 C         scale_fac_dist=1.0d0
10998 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10999 C     &                    sh_frac_dist_grad(j)
11000          enddo
11001         endif
11002 C this is what is now we have the distance scaling now volume...
11003       short=short_r_sidechain(itype(k))
11004       long=long_r_sidechain(itype(k))
11005       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11006       sinthet=short/dist_pep_side*costhet
11007 C now costhet_grad
11008 C       costhet=0.6d0
11009 C       sinthet=0.8
11010        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11011 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11012 C     &             -short/dist_pep_side**2/costhet)
11013 C       costhet_fac=0.0d0
11014        do j=1,3
11015          costhet_grad(j)=costhet_fac*pep_side(j)
11016        enddo
11017 C remember for the final gradient multiply costhet_grad(j)
11018 C for side_chain by factor -2 !
11019 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11020 C pep_side0pept_group is vector multiplication
11021       pep_side0pept_group=0.0d0
11022       do j=1,3
11023       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11024       enddo
11025       cosalfa=(pep_side0pept_group/
11026      & (dist_pep_side*dist_side_calf))
11027       fac_alfa_sin=1.0d0-cosalfa**2
11028       fac_alfa_sin=dsqrt(fac_alfa_sin)
11029       rkprim=fac_alfa_sin*(long-short)+short
11030 C      rkprim=short
11031
11032 C now costhet_grad
11033        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11034 C       cosphi=0.6
11035        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11036        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11037      &      dist_pep_side**2)
11038 C       sinphi=0.8
11039        do j=1,3
11040          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11041      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11042      &*(long-short)/fac_alfa_sin*cosalfa/
11043      &((dist_pep_side*dist_side_calf))*
11044      &((side_calf(j))-cosalfa*
11045      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11046 C       cosphi_grad_long(j)=0.0d0
11047         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11048      &*(long-short)/fac_alfa_sin*cosalfa
11049      &/((dist_pep_side*dist_side_calf))*
11050      &(pep_side(j)-
11051      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11052 C       cosphi_grad_loc(j)=0.0d0
11053        enddo
11054 C      print *,sinphi,sinthet
11055       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11056      &                    /VSolvSphere_div
11057 C     &                    *wshield
11058 C now the gradient...
11059       do j=1,3
11060       grad_shield(j,i)=grad_shield(j,i)
11061 C gradient po skalowaniu
11062      &                +(sh_frac_dist_grad(j)*VofOverlap
11063 C  gradient po costhet
11064      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11065      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11066      &       sinphi/sinthet*costhet*costhet_grad(j)
11067      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11068      & )*wshield
11069 C grad_shield_side is Cbeta sidechain gradient
11070       grad_shield_side(j,ishield_list(i),i)=
11071      &        (sh_frac_dist_grad(j)*-2.0d0
11072      &        *VofOverlap
11073      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11074      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11075      &       sinphi/sinthet*costhet*costhet_grad(j)
11076      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11077      &       )*wshield
11078
11079        grad_shield_loc(j,ishield_list(i),i)=
11080      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11081      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11082      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11083      &        ))
11084      &        *wshield
11085       enddo
11086       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11087       enddo
11088       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11089 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11090 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11091       enddo
11092       return
11093       end
11094 C--------------------------------------------------------------------------
11095       double precision function tschebyshev(m,n,x,y)
11096       implicit none
11097       include "DIMENSIONS"
11098       integer i,m,n
11099       double precision x(n),y,yy(0:maxvar),aux
11100 c Tschebyshev polynomial. Note that the first term is omitted
11101 c m=0: the constant term is included
11102 c m=1: the constant term is not included
11103       yy(0)=1.0d0
11104       yy(1)=y
11105       do i=2,n
11106         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11107       enddo
11108       aux=0.0d0
11109       do i=m,n
11110         aux=aux+x(i)*yy(i)
11111       enddo
11112       tschebyshev=aux
11113       return
11114       end
11115 C--------------------------------------------------------------------------
11116       double precision function gradtschebyshev(m,n,x,y)
11117       implicit none
11118       include "DIMENSIONS"
11119       integer i,m,n
11120       double precision x(n+1),y,yy(0:maxvar),aux
11121 c Tschebyshev polynomial. Note that the first term is omitted
11122 c m=0: the constant term is included
11123 c m=1: the constant term is not included
11124       yy(0)=1.0d0
11125       yy(1)=2.0d0*y
11126       do i=2,n
11127         yy(i)=2*y*yy(i-1)-yy(i-2)
11128       enddo
11129       aux=0.0d0
11130       do i=m,n
11131         aux=aux+x(i+1)*yy(i)*(i+1)
11132 C        print *, x(i+1),yy(i),i
11133       enddo
11134       gradtschebyshev=aux
11135       return
11136       end
11137