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

   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.GEO'
 923       include 'COMMON.VAR'
 924       include 'COMMON.LOCAL'
 925       include 'COMMON.CHAIN'
 926       include 'COMMON.DERIV'
 927       include 'COMMON.NAMES'
 928       include 'COMMON.INTERACT'
 929       include 'COMMON.WEIGHTDER'
 930       include 'COMMON.IOUNITS'
 931       include 'COMMON.CALC'
 932       logical lprn
 933       common /srutu/icall
 934       integer icant
 935       external icant
 936       do i=1,nntyp
 937         do j=1,2
 938           eneps_temp(j,i)=0.0d0
 939         enddo
 940       enddo
 941       evdw=0.0D0
 942 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 943       evdw=0.0D0
 944       lprn=.false.
 945 c      if (icall.gt.0) lprn=.true.
 946       ind=0
 947       do i=iatsc_s,iatsc_e
 948         itypi=itype(i)
 949         if (itypi.eq.ntyp1) cycle
 950         itypi1=itype(i+1)
 951         xi=c(1,nres+i)
 952         yi=c(2,nres+i)
 953         zi=c(3,nres+i)
 954         dxi=dc_norm(1,nres+i)
 955         dyi=dc_norm(2,nres+i)
 956         dzi=dc_norm(3,nres+i)
 957         dsci_inv=vbld_inv(i+nres)
 958 C
 959 C Calculate SC interaction energy.
 960 C
 961         do iint=1,nint_gr(i)
 962           do j=istart(i,iint),iend(i,iint)
 963             ind=ind+1
 964             itypj=itype(j)
 965             if (itypj.eq.ntyp1) cycle
 966             dscj_inv=vbld_inv(j+nres)
 967             sig0ij=sigma(itypi,itypj)
 968             chi1=chi(itypi,itypj)
 969             chi2=chi(itypj,itypi)
 970             chi12=chi1*chi2
 971             chip1=chip(itypi)
 972             chip2=chip(itypj)
 973             chip12=chip1*chip2
 974             alf1=alp(itypi)
 975             alf2=alp(itypj)
 976             alf12=0.5D0*(alf1+alf2)
 977 C For diagnostics only!!!
 978 c           chi1=0.0D0
 979 c           chi2=0.0D0
 980 c           chi12=0.0D0
 981 c           chip1=0.0D0
 982 c           chip2=0.0D0
 983 c           chip12=0.0D0
 984 c           alf1=0.0D0
 985 c           alf2=0.0D0
 986 c           alf12=0.0D0
 987             xj=c(1,nres+j)-xi
 988             yj=c(2,nres+j)-yi
 989             zj=c(3,nres+j)-zi
 990             dxj=dc_norm(1,nres+j)
 991             dyj=dc_norm(2,nres+j)
 992             dzj=dc_norm(3,nres+j)
 993 c            write (iout,*) i,j,xj,yj,zj
 994             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 995             rij=dsqrt(rrij)
 996 C Calculate angle-dependent terms of energy and contributions to their
 997 C derivatives.
 998             call sc_angular
 999             sigsq=1.0D0/sigsq
1000             sig=sig0ij*dsqrt(sigsq)
1001             rij_shift=1.0D0/rij-sig+sig0ij
1002 C I hate to put IF's in the loops, but here don't have another choice!!!!
1003             if (rij_shift.le.0.0D0) then
1004               evdw=1.0D20
1005               return
1006             endif
1007             sigder=-sig*sigsq
1008 c---------------------------------------------------------------
1009             rij_shift=1.0D0/rij_shift
1010             fac=rij_shift**expon
1011             e1=fac*fac*aa(itypi,itypj)
1012             e2=fac*bb(itypi,itypj)
1013             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1014             eps2der=evdwij*eps3rt
1015             eps3der=evdwij*eps2rt
1016             evdwij=evdwij*eps2rt*eps3rt
1017             evdw=evdw+evdwij
1018             ij=icant(itypi,itypj)
1019             aux=eps1*eps2rt**2*eps3rt**2
1020 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1021 c     &        /dabs(eps(itypi,itypj))
1022 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1023 c-----------------------
1024             eps0ij=eps(itypi,itypj)
1025             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1026             rr0ij=r0(itypi,itypj)
1027             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1028 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1029 c-----------------------
1030 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1031 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1032 c     &         aux*e2/eps(itypi,itypj)
1033             if (lprn) then
1034             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1035             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1036             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1037      &        restyp(itypi),i,restyp(itypj),j,
1038      &        epsi,sigm,chi1,chi2,chip1,chip2,
1039      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1040      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1041      &        evdwij
1042             endif
1043             if (calc_grad) then
1044 C Calculate gradient components.
1045             e1=e1*eps1*eps2rt**2*eps3rt**2
1046             fac=-expon*(e1+evdwij)*rij_shift
1047             sigder=fac*sigder
1048             fac=rij*fac
1049 C Calculate the radial part of the gradient
1050             gg(1)=xj*fac
1051             gg(2)=yj*fac
1052             gg(3)=zj*fac
1053 C Calculate angular part of the gradient.
1054             call sc_grad
1055             endif
1056           enddo      ! j
1057         enddo        ! iint
1058       enddo          ! i
1059       return
1060       end
1061 C-----------------------------------------------------------------------------
1062       subroutine egbv(evdw)
1063 C
1064 C This subroutine calculates the interaction energy of nonbonded side chains
1065 C assuming the Gay-Berne-Vorobjev potential of interaction.
1066 C
1067       implicit real*8 (a-h,o-z)
1068       include 'DIMENSIONS'
1069       include 'DIMENSIONS.ZSCOPT'
1070       include 'COMMON.GEO'
1071       include 'COMMON.VAR'
1072       include 'COMMON.LOCAL'
1073       include 'COMMON.CHAIN'
1074       include 'COMMON.DERIV'
1075       include 'COMMON.NAMES'
1076       include 'COMMON.INTERACT'
1077       include 'COMMON.WEIGHTDER'
1078       include 'COMMON.IOUNITS'
1079       include 'COMMON.CALC'
1080       common /srutu/ icall
1081       logical lprn
1082       integer icant
1083       external icant
1084       do i=1,nntyp
1085         do j=1,2
1086           eneps_temp(j,i)=0.0d0
1087         enddo
1088       enddo
1089       evdw=0.0D0
1090 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1091       evdw=0.0D0
1092       lprn=.false.
1093 c      if (icall.gt.0) lprn=.true.
1094       ind=0
1095       do i=iatsc_s,iatsc_e
1096         itypi=itype(i)
1097         itypi1=itype(i+1)
1098         xi=c(1,nres+i)
1099         yi=c(2,nres+i)
1100         zi=c(3,nres+i)
1101         dxi=dc_norm(1,nres+i)
1102         dyi=dc_norm(2,nres+i)
1103         dzi=dc_norm(3,nres+i)
1104         dsci_inv=vbld_inv(i+nres)
1105 C
1106 C Calculate SC interaction energy.
1107 C
1108         do iint=1,nint_gr(i)
1109           do j=istart(i,iint),iend(i,iint)
1110             ind=ind+1
1111             itypj=itype(j)
1112             dscj_inv=vbld_inv(j+nres)
1113             sig0ij=sigma(itypi,itypj)
1114             r0ij=r0(itypi,itypj)
1115             chi1=chi(itypi,itypj)
1116             chi2=chi(itypj,itypi)
1117             chi12=chi1*chi2
1118             chip1=chip(itypi)
1119             chip2=chip(itypj)
1120             chip12=chip1*chip2
1121             alf1=alp(itypi)
1122             alf2=alp(itypj)
1123             alf12=0.5D0*(alf1+alf2)
1124 C For diagnostics only!!!
1125 c           chi1=0.0D0
1126 c           chi2=0.0D0
1127 c           chi12=0.0D0
1128 c           chip1=0.0D0
1129 c           chip2=0.0D0
1130 c           chip12=0.0D0
1131 c           alf1=0.0D0
1132 c           alf2=0.0D0
1133 c           alf12=0.0D0
1134             xj=c(1,nres+j)-xi
1135             yj=c(2,nres+j)-yi
1136             zj=c(3,nres+j)-zi
1137             dxj=dc_norm(1,nres+j)
1138             dyj=dc_norm(2,nres+j)
1139             dzj=dc_norm(3,nres+j)
1140             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1141             rij=dsqrt(rrij)
1142 C Calculate angle-dependent terms of energy and contributions to their
1143 C derivatives.
1144             call sc_angular
1145             sigsq=1.0D0/sigsq
1146             sig=sig0ij*dsqrt(sigsq)
1147             rij_shift=1.0D0/rij-sig+r0ij
1148 C I hate to put IF's in the loops, but here don't have another choice!!!!
1149             if (rij_shift.le.0.0D0) then
1150               evdw=1.0D20
1151               return
1152             endif
1153             sigder=-sig*sigsq
1154 c---------------------------------------------------------------
1155             rij_shift=1.0D0/rij_shift
1156             fac=rij_shift**expon
1157             e1=fac*fac*aa(itypi,itypj)
1158             e2=fac*bb(itypi,itypj)
1159             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1160             eps2der=evdwij*eps3rt
1161             eps3der=evdwij*eps2rt
1162             fac_augm=rrij**expon
1163             e_augm=augm(itypi,itypj)*fac_augm
1164             evdwij=evdwij*eps2rt*eps3rt
1165             evdw=evdw+evdwij+e_augm
1166             ij=icant(itypi,itypj)
1167             aux=eps1*eps2rt**2*eps3rt**2
1168             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1169      &        /dabs(eps(itypi,itypj))
1170             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1171 c            eneps_temp(ij)=eneps_temp(ij)
1172 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1173 c            if (lprn) then
1174 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1175 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1176 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1177 c     &        restyp(itypi),i,restyp(itypj),j,
1178 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1179 c     &        chi1,chi2,chip1,chip2,
1180 c     &        eps1,eps2rt**2,eps3rt**2,
1181 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1182 c     &        evdwij+e_augm
1183 c            endif
1184             if (calc_grad) then
1185 C Calculate gradient components.
1186             e1=e1*eps1*eps2rt**2*eps3rt**2
1187             fac=-expon*(e1+evdwij)*rij_shift
1188             sigder=fac*sigder
1189             fac=rij*fac-2*expon*rrij*e_augm
1190 C Calculate the radial part of the gradient
1191             gg(1)=xj*fac
1192             gg(2)=yj*fac
1193             gg(3)=zj*fac
1194 C Calculate angular part of the gradient.
1195             call sc_grad
1196             endif
1197           enddo      ! j
1198         enddo        ! iint
1199       enddo          ! i
1200       return
1201       end
1202 C-----------------------------------------------------------------------------
1203       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1204 C
1205 C This subroutine calculates the interaction energy of nonbonded side chains
1206 C assuming the Gay-Berne potential of interaction.
1207 C
1208        IMPLICIT NONE
1209        INCLUDE 'DIMENSIONS'
1210        INCLUDE 'DIMENSIONS.ZSCOPT'
1211        INCLUDE 'COMMON.CALC'
1212        INCLUDE 'COMMON.CONTROL'
1213        INCLUDE 'COMMON.CHAIN'
1214        INCLUDE 'COMMON.DERIV'
1215        INCLUDE 'COMMON.EMP'
1216        INCLUDE 'COMMON.GEO'
1217        INCLUDE 'COMMON.INTERACT'
1218        INCLUDE 'COMMON.IOUNITS'
1219        INCLUDE 'COMMON.LOCAL'
1220        INCLUDE 'COMMON.NAMES'
1221        INCLUDE 'COMMON.VAR'
1222        INCLUDE 'COMMON.WEIGHTDER'
1223        logical lprn
1224        double precision scalar
1225        double precision ener(4)
1226        integer troll
1227        integer iint,ij
1228        integer icant
1229
1230        energy_dec=.false.
1231        IF (energy_dec) write (iout,'(a)')
1232      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1233      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1234        evdw   = 0.0D0
1235        evdw_p = 0.0D0
1236        evdw_m = 0.0D0
1237 c DIAGNOSTICS
1238 ccccc      energy_dec=.false.
1239 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1240 c      lprn   = .false.
1241 c     if (icall.eq.0) lprn=.false.
1242 c END DIAGNOSTICS
1243 c      ind = 0
1244        DO i = iatsc_s, iatsc_e
1245         itypi  = itype(i)
1246 c        itypi1 = itype(i+1)
1247         dxi    = dc_norm(1,nres+i)
1248         dyi    = dc_norm(2,nres+i)
1249         dzi    = dc_norm(3,nres+i)
1250 c        dsci_inv=dsc_inv(itypi)
1251         dsci_inv = vbld_inv(i+nres)
1252 c        DO k = 1, 3
1253 c         ctail(k,1) = c(k, i+nres)
1254 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1255 c        END DO
1256         xi=c(1,nres+i)
1257         yi=c(2,nres+i)
1258         zi=c(3,nres+i)
1259 c!-------------------------------------------------------------------
1260 C Calculate SC interaction energy.
1261         DO iint = 1, nint_gr(i)
1262          DO j = istart(i,iint), iend(i,iint)
1263 c! initialize variables for electrostatic gradients
1264           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1265 c            ind=ind+1
1266 c            dscj_inv = dsc_inv(itypj)
1267           dscj_inv = vbld_inv(j+nres)
1268 c! rij holds 1/(distance of Calpha atoms)
1269           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1270           rij  = dsqrt(rrij)
1271 c!-------------------------------------------------------------------
1272 C Calculate angle-dependent terms of energy and contributions to their
1273 C derivatives.
1274
1275 #ifdef CHECK_MOMO
1276 c!      DO troll = 10, 5000
1277 c!      om1    = 0.0d0
1278 c!      om2    = 0.0d0
1279 c!      om12   = 1.0d0
1280 c!      sqom1  = om1 * om1
1281 c!      sqom2  = om2 * om2
1282 c!      sqom12 = om12 * om12
1283 c!      rij    = 5.0d0 / troll
1284 c!      rrij   = rij * rij
1285 c!      Rtail  = troll / 5.0d0
1286 c!      Rhead  = troll / 5.0d0
1287 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1288 c!      Rtail = dsqrt((Rtail**2)
1289 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1290 c!      rij = 1.0d0/Rtail
1291 c!      rrij = rij * rij
1292 #endif
1293           CALL sc_angular
1294 c! this should be in elgrad_init but om's are calculated by sc_angular
1295 c! which in turn is used by older potentials
1296 c! which proves how tangled UNRES code is >.<
1297 c! om = omega, sqom = om^2
1298           sqom1  = om1 * om1
1299           sqom2  = om2 * om2
1300           sqom12 = om12 * om12
1301
1302 c! now we calculate EGB - Gey-Berne
1303 c! It will be summed up in evdwij and saved in evdw
1304           sigsq     = 1.0D0  / sigsq
1305           sig       = sig0ij * dsqrt(sigsq)
1306 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1307           rij_shift = Rtail - sig + sig0ij
1308           IF (rij_shift.le.0.0D0) THEN
1309            evdw = 1.0D20
1310            RETURN
1311           END IF
1312           sigder = -sig * sigsq
1313           rij_shift = 1.0D0 / rij_shift
1314           fac       = rij_shift**expon
1315           c1        = fac  * fac * aa(itypi,itypj)
1316 c!          c1        = 0.0d0
1317           c2        = fac  * bb(itypi,itypj)
1318 c!          c2        = 0.0d0
1319           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1320           eps2der   = eps3rt * evdwij
1321           eps3der   = eps2rt * evdwij
1322 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1323           evdwij    = eps2rt * eps3rt * evdwij
1324 c!      evdwij = 0.0d0
1325 c!      write (*,*) "Gey Berne = ", evdwij
1326 #ifdef TSCSC
1327           IF (bb(itypi,itypj).gt.0) THEN
1328            evdw_p = evdw_p + evdwij
1329           ELSE
1330            evdw_m = evdw_m + evdwij
1331           END IF
1332 #else
1333           evdw = evdw
1334      &         + evdwij
1335 #endif
1336 c!-------------------------------------------------------------------
1337 c! Calculate some components of GGB
1338           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1339           fac    = -expon * (c1 + evdwij) * rij_shift
1340           sigder = fac * sigder
1341 c!          fac    = rij * fac
1342 c! Calculate distance derivative
1343 c!          gg(1) = xj * fac
1344 c!          gg(2) = yj * fac
1345 c!          gg(3) = zj * fac
1346           gg(1) = fac
1347           gg(2) = fac
1348           gg(3) = fac
1349 c!      write (*,*) "gg(1) = ", gg(1)
1350 c!      write (*,*) "gg(2) = ", gg(2)
1351 c!      write (*,*) "gg(3) = ", gg(3)
1352 c! The angular derivatives of GGB are brought together in sc_grad
1353 c!-------------------------------------------------------------------
1354 c! Fcav
1355 c!
1356 c! Catch gly-gly interactions to skip calculation of something that
1357 c! does not exist
1358
1359       IF (itypi.eq.10.and.itypj.eq.10) THEN
1360        Fcav = 0.0d0
1361        dFdR = 0.0d0
1362        dCAVdOM1  = 0.0d0
1363        dCAVdOM2  = 0.0d0
1364        dCAVdOM12 = 0.0d0
1365       ELSE
1366
1367 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1368        fac = chis1 * sqom1 + chis2 * sqom2
1369      &     - 2.0d0 * chis12 * om1 * om2 * om12
1370 c! we will use pom later in Gcav, so dont mess with it!
1371        pom = 1.0d0 - chis1 * chis2 * sqom12
1372
1373        Lambf = (1.0d0 - (fac / pom))
1374        Lambf = dsqrt(Lambf)
1375
1376
1377        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1378 c!       write (*,*) "sparrow = ", sparrow
1379        Chif = Rtail * sparrow
1380        ChiLambf = Chif * Lambf
1381        eagle = dsqrt(ChiLambf)
1382        bat = ChiLambf ** 11.0d0
1383
1384        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1385        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1386        botsq = bot * bot
1387
1388 c!      write (*,*) "sig1 = ",sig1
1389 c!      write (*,*) "sig2 = ",sig2
1390 c!      write (*,*) "Rtail = ",Rtail
1391 c!      write (*,*) "sparrow = ",sparrow
1392 c!      write (*,*) "Chis1 = ", chis1
1393 c!      write (*,*) "Chis2 = ", chis2
1394 c!      write (*,*) "Chis12 = ", chis12
1395 c!      write (*,*) "om1 = ", om1
1396 c!      write (*,*) "om2 = ", om2
1397 c!      write (*,*) "om12 = ", om12
1398 c!      write (*,*) "sqom1 = ", sqom1
1399 c!      write (*,*) "sqom2 = ", sqom2
1400 c!      write (*,*) "sqom12 = ", sqom12
1401 c!      write (*,*) "Lambf = ",Lambf
1402 c!      write (*,*) "b1 = ",b1
1403 c!      write (*,*) "b2 = ",b2
1404 c!      write (*,*) "b3 = ",b3
1405 c!      write (*,*) "b4 = ",b4
1406 c!      write (*,*) "top = ",top
1407 c!      write (*,*) "bot = ",bot
1408        Fcav = top / bot
1409 c!       Fcav = 0.0d0
1410 c!      write (*,*) "Fcav = ", Fcav
1411 c!-------------------------------------------------------------------
1412 c! derivative of Fcav is Gcav...
1413 c!---------------------------------------------------
1414
1415        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1416        dbot = 12.0d0 * b4 * bat * Lambf
1417        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1418 c!       dFdR = 0.0d0
1419 c!      write (*,*) "dFcav/dR = ", dFdR
1420
1421        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1422        dbot = 12.0d0 * b4 * bat * Chif
1423        eagle = Lambf * pom
1424        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1425        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1426        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1427      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1428
1429        dFdL = ((dtop * bot - top * dbot) / botsq)
1430 c!       dFdL = 0.0d0
1431        dCAVdOM1  = dFdL * ( dFdOM1 )
1432        dCAVdOM2  = dFdL * ( dFdOM2 )
1433        dCAVdOM12 = dFdL * ( dFdOM12 )
1434 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1435 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1436 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1437 c!      write (*,*) ""
1438 c!-------------------------------------------------------------------
1439 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1440 c! Pom is used here to project the gradient vector into
1441 c! cartesian coordinates and at the same time contains
1442 c! dXhb/dXsc derivative (for charged amino acids
1443 c! location of hydrophobic centre of interaction is not
1444 c! the same as geometric centre of side chain, this
1445 c! derivative takes that into account)
1446 c! derivatives of omega angles will be added in sc_grad
1447
1448        DO k= 1, 3
1449         ertail(k) = Rtail_distance(k)/Rtail
1450        END DO
1451        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1452        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1453        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1454        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1455        DO k = 1, 3
1456 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1457 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1458         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1459         gvdwx(k,i) = gvdwx(k,i)
1460      &             - (( dFdR + gg(k) ) * pom)
1461 c!     &             - ( dFdR * pom )
1462         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1463         gvdwx(k,j) = gvdwx(k,j)
1464      &             + (( dFdR + gg(k) ) * pom)
1465 c!     &             + ( dFdR * pom )
1466
1467         gvdwc(k,i) = gvdwc(k,i)
1468      &             - (( dFdR + gg(k) ) * ertail(k))
1469 c!     &             - ( dFdR * ertail(k))
1470
1471         gvdwc(k,j) = gvdwc(k,j)
1472      &             + (( dFdR + gg(k) ) * ertail(k))
1473 c!     &             + ( dFdR * ertail(k))
1474
1475         gg(k) = 0.0d0
1476 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1477 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1478       END DO
1479
1480 c!-------------------------------------------------------------------
1481 c! Compute head-head and head-tail energies for each state
1482
1483           isel = iabs(Qi) + iabs(Qj)
1484           IF (isel.eq.0) THEN
1485 c! No charges - do nothing
1486            eheadtail = 0.0d0
1487
1488           ELSE IF (isel.eq.4) THEN
1489 c! Calculate dipole-dipole interactions
1490            CALL edd(ecl)
1491            eheadtail = ECL
1492
1493           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1494 c! Charge-nonpolar interactions
1495            CALL eqn(epol)
1496            eheadtail = epol
1497
1498           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1499 c! Nonpolar-charge interactions
1500            CALL enq(epol)
1501            eheadtail = epol
1502
1503           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1504 c! Charge-dipole interactions
1505            CALL eqd(ecl, elj, epol)
1506            eheadtail = ECL + elj + epol
1507
1508           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1509 c! Dipole-charge interactions
1510            CALL edq(ecl, elj, epol)
1511            eheadtail = ECL + elj + epol
1512
1513           ELSE IF ((isel.eq.2.and.
1514      &          iabs(Qi).eq.1).and.
1515      &          nstate(itypi,itypj).eq.1) THEN
1516 c! Same charge-charge interaction ( +/+ or -/- )
1517            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1518            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1519
1520           ELSE IF ((isel.eq.2.and.
1521      &          iabs(Qi).eq.1).and.
1522      &          nstate(itypi,itypj).ne.1) THEN
1523 c! Different charge-charge interaction ( +/- or -/+ )
1524            CALL energy_quad
1525      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1526           END IF
1527        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1528 c!      write (*,*) "evdw = ", evdw
1529 c!      write (*,*) "Fcav = ", Fcav
1530 c!      write (*,*) "eheadtail = ", eheadtail
1531        evdw = evdw
1532      &      + Fcav
1533      &      + eheadtail
1534        ij=icant(itypi,itypj)
1535        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1536        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1537        eneps_temp(3,ij)=eheadtail
1538        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1539      &  restyp(itype(i)),i,restyp(itype(j)),j,
1540      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1541      &  Equad,evdw
1542        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1543      &  restyp(itype(i)),i,restyp(itype(j)),j,
1544      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1545      &  Equad,evdw
1546 #ifdef CHECK_MOMO
1547        evdw = 0.0d0
1548        END DO ! troll
1549 #endif
1550
1551 c!-------------------------------------------------------------------
1552 c! As all angular derivatives are done, now we sum them up,
1553 c! then transform and project into cartesian vectors and add to gvdwc
1554 c! We call sc_grad always, with the exception of +/- interaction.
1555 c! This is because energy_quad subroutine needs to handle
1556 c! this job in his own way.
1557 c! This IS probably not very efficient and SHOULD be optimised
1558 c! but it will require major restructurization of emomo
1559 c! so it will be left as it is for now
1560 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1561        IF (nstate(itypi,itypj).eq.1) THEN
1562 #ifdef TSCSC
1563         IF (bb(itypi,itypj).gt.0) THEN
1564          CALL sc_grad
1565         ELSE
1566          CALL sc_grad_T
1567         END IF
1568 #else
1569         CALL sc_grad
1570 #endif
1571        END IF
1572 c!-------------------------------------------------------------------
1573 c! NAPISY KONCOWE
1574          END DO   ! j
1575         END DO    ! iint
1576        END DO     ! i
1577 c      write (iout,*) "Number of loop steps in EGB:",ind
1578 c      energy_dec=.false.
1579        RETURN
1580       END SUBROUTINE emomo
1581 c! END OF MOMO
1582 C-----------------------------------------------------------------------------
1583       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1584        IMPLICIT NONE
1585        INCLUDE 'DIMENSIONS'
1586        INCLUDE 'DIMENSIONS.ZSCOPT'
1587        INCLUDE 'COMMON.CALC'
1588        INCLUDE 'COMMON.CHAIN'
1589        INCLUDE 'COMMON.CONTROL'
1590        INCLUDE 'COMMON.DERIV'
1591        INCLUDE 'COMMON.EMP'
1592        INCLUDE 'COMMON.GEO'
1593        INCLUDE 'COMMON.INTERACT'
1594        INCLUDE 'COMMON.IOUNITS'
1595        INCLUDE 'COMMON.LOCAL'
1596        INCLUDE 'COMMON.NAMES'
1597        INCLUDE 'COMMON.VAR'
1598        double precision scalar, facd3, facd4, federmaus, adler
1599 c! Epol and Gpol analytical parameters
1600        alphapol1 = alphapol(itypi,itypj)
1601        alphapol2 = alphapol(itypj,itypi)
1602 c! Fisocav and Gisocav analytical parameters
1603        al1  = alphiso(1,itypi,itypj)
1604        al2  = alphiso(2,itypi,itypj)
1605        al3  = alphiso(3,itypi,itypj)
1606        al4  = alphiso(4,itypi,itypj)
1607        csig = (1.0d0
1608      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1609      &      + sigiso2(itypi,itypj)**2.0d0))
1610 c!
1611        pis  = sig0head(itypi,itypj)
1612        eps_head = epshead(itypi,itypj)
1613        Rhead_sq = Rhead * Rhead
1614 c! R1 - distance between head of ith side chain and tail of jth sidechain
1615 c! R2 - distance between head of jth side chain and tail of ith sidechain
1616        R1 = 0.0d0
1617        R2 = 0.0d0
1618        DO k = 1, 3
1619 c! Calculate head-to-tail distances needed by Epol
1620         R1=R1+(ctail(k,2)-chead(k,1))**2
1621         R2=R2+(chead(k,2)-ctail(k,1))**2
1622        END DO
1623 c! Pitagoras
1624        R1 = dsqrt(R1)
1625        R2 = dsqrt(R2)
1626
1627 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1628 c!     &        +dhead(1,1,itypi,itypj))**2))
1629 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1630 c!     &        +dhead(2,1,itypi,itypj))**2))
1631 c!-------------------------------------------------------------------
1632 c! Coulomb electrostatic interaction
1633        Ecl = (332.0d0 * Qij) / Rhead
1634 c! derivative of Ecl is Gcl...
1635        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1636        dGCLdOM1 = 0.0d0
1637        dGCLdOM2 = 0.0d0
1638        dGCLdOM12 = 0.0d0
1639 c!-------------------------------------------------------------------
1640 c! Generalised Born Solvent Polarization
1641 c! Charged head polarizes the solvent
1642        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1643        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1644        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1645 c! Derivative of Egb is Ggb...
1646        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1647        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1648      &        / ( 2.0d0 * Fgb )
1649        dGGBdR = dGGBdFGB * dFGBdR
1650 c!-------------------------------------------------------------------
1651 c! Fisocav - isotropic cavity creation term
1652 c! or "how much energy it costs to put charged head in water"
1653        pom = Rhead * csig
1654        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1655        bot = (1.0d0 + al4 * pom**12.0d0)
1656        botsq = bot * bot
1657        FisoCav = top / bot
1658 c!      write (*,*) "Rhead = ",Rhead
1659 c!      write (*,*) "csig = ",csig
1660 c!      write (*,*) "pom = ",pom
1661 c!      write (*,*) "al1 = ",al1
1662 c!      write (*,*) "al2 = ",al2
1663 c!      write (*,*) "al3 = ",al3
1664 c!      write (*,*) "al4 = ",al4
1665 c!      write (*,*) "top = ",top
1666 c!      write (*,*) "bot = ",bot
1667 c! Derivative of Fisocav is GCV...
1668        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1669        dbot = 12.0d0 * al4 * pom ** 11.0d0
1670        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1671 c!-------------------------------------------------------------------
1672 c! Epol
1673 c! Polarization energy - charged heads polarize hydrophobic "neck"
1674        MomoFac1 = (1.0d0 - chi1 * sqom2)
1675        MomoFac2 = (1.0d0 - chi2 * sqom1)
1676        RR1  = ( R1 * R1 ) / MomoFac1
1677        RR2  = ( R2 * R2 ) / MomoFac2
1678        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1679        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1680        fgb1 = sqrt( RR1 + a12sq * ee1 )
1681        fgb2 = sqrt( RR2 + a12sq * ee2 )
1682        epol = 332.0d0 * eps_inout_fac * (
1683      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1684 c!       epol = 0.0d0
1685 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1686 c       write (*,*) "alphapol1 = ", alphapol1
1687 c       write (*,*) "alphapol2 = ", alphapol2
1688 c       write (*,*) "fgb1 = ", fgb1
1689 c       write (*,*) "fgb2 = ", fgb2
1690 c       write (*,*) "epol = ", epol
1691 c! derivative of Epol is Gpol...
1692        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1693      &          / (fgb1 ** 5.0d0)
1694        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1695      &          / (fgb2 ** 5.0d0)
1696        dFGBdR1 = ( (R1 / MomoFac1)
1697      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1698      &        / ( 2.0d0 * fgb1 )
1699        dFGBdR2 = ( (R2 / MomoFac2)
1700      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1701      &        / ( 2.0d0 * fgb2 )
1702        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1703      &          * ( 2.0d0 - 0.5d0 * ee1) )
1704      &          / ( 2.0d0 * fgb1 )
1705        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1706      &          * ( 2.0d0 - 0.5d0 * ee2) )
1707      &          / ( 2.0d0 * fgb2 )
1708        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1709 c!       dPOLdR1 = 0.0d0
1710        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1711 c!       dPOLdR2 = 0.0d0
1712        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1713 c!       dPOLdOM1 = 0.0d0
1714        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1715 c!       dPOLdOM2 = 0.0d0
1716 c!-------------------------------------------------------------------
1717 c! Elj
1718 c! Lennard-Jones 6-12 interaction between heads
1719        pom = (pis / Rhead)**6.0d0
1720        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1721 c! derivative of Elj is Glj
1722        dGLJdR = 4.0d0 * eps_head
1723      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1724      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1725 c!-------------------------------------------------------------------
1726 c! Return the results
1727 c! These things do the dRdX derivatives, that is
1728 c! allow us to change what we see from function that changes with
1729 c! distance to function that changes with LOCATION (of the interaction
1730 c! site)
1731        DO k = 1, 3
1732         erhead(k) = Rhead_distance(k)/Rhead
1733         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1734         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1735        END DO
1736
1737        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1738        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1739        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1740        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1741        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1742        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1743        facd1 = d1 * vbld_inv(i+nres)
1744        facd2 = d2 * vbld_inv(j+nres)
1745        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1746        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1747
1748 c! Now we add appropriate partial derivatives (one in each dimension)
1749        DO k = 1, 3
1750         hawk   = (erhead_tail(k,1) +
1751      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1752         condor = (erhead_tail(k,2) +
1753      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1754
1755         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1756         gvdwx(k,i) = gvdwx(k,i)
1757      &             - dGCLdR * pom
1758      &             - dGGBdR * pom
1759      &             - dGCVdR * pom
1760      &             - dPOLdR1 * hawk
1761      &             - dPOLdR2 * (erhead_tail(k,2)
1762      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1763      &             - dGLJdR * pom
1764
1765         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1766         gvdwx(k,j) = gvdwx(k,j)
1767      &             + dGCLdR * pom
1768      &             + dGGBdR * pom
1769      &             + dGCVdR * pom
1770      &             + dPOLdR1 * (erhead_tail(k,1)
1771      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1772      &             + dPOLdR2 * condor
1773      &             + dGLJdR * pom
1774
1775         gvdwc(k,i) = gvdwc(k,i)
1776      &             - dGCLdR * erhead(k)
1777      &             - dGGBdR * erhead(k)
1778      &             - dGCVdR * erhead(k)
1779      &             - dPOLdR1 * erhead_tail(k,1)
1780      &             - dPOLdR2 * erhead_tail(k,2)
1781      &             - dGLJdR * erhead(k)
1782
1783         gvdwc(k,j) = gvdwc(k,j)
1784      &             + dGCLdR * erhead(k)
1785      &             + dGGBdR * erhead(k)
1786      &             + dGCVdR * erhead(k)
1787      &             + dPOLdR1 * erhead_tail(k,1)
1788      &             + dPOLdR2 * erhead_tail(k,2)
1789      &             + dGLJdR * erhead(k)
1790
1791        END DO
1792        RETURN
1793       END SUBROUTINE eqq
1794 c!-------------------------------------------------------------------
1795       SUBROUTINE energy_quad
1796      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1797        IMPLICIT NONE
1798        INCLUDE 'DIMENSIONS'
1799        INCLUDE 'DIMENSIONS.ZSCOPT'
1800        INCLUDE 'COMMON.CALC'
1801        INCLUDE 'COMMON.CHAIN'
1802        INCLUDE 'COMMON.CONTROL'
1803        INCLUDE 'COMMON.DERIV'
1804        INCLUDE 'COMMON.EMP'
1805        INCLUDE 'COMMON.GEO'
1806        INCLUDE 'COMMON.INTERACT'
1807        INCLUDE 'COMMON.IOUNITS'
1808        INCLUDE 'COMMON.LOCAL'
1809        INCLUDE 'COMMON.NAMES'
1810        INCLUDE 'COMMON.VAR'
1811        double precision scalar
1812        double precision ener(4)
1813        double precision dcosom1(3),dcosom2(3)
1814 c! used in Epol derivatives
1815        double precision facd3, facd4
1816        double precision federmaus, adler
1817 c! Epol and Gpol analytical parameters
1818        alphapol1 = alphapol(itypi,itypj)
1819        alphapol2 = alphapol(itypj,itypi)
1820 c! Fisocav and Gisocav analytical parameters
1821        al1  = alphiso(1,itypi,itypj)
1822        al2  = alphiso(2,itypi,itypj)
1823        al3  = alphiso(3,itypi,itypj)
1824        al4  = alphiso(4,itypi,itypj)
1825        csig = (1.0d0
1826      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1827      &      + sigiso2(itypi,itypj)**2.0d0))
1828 c!
1829        w1   = wqdip(1,itypi,itypj)
1830        w2   = wqdip(2,itypi,itypj)
1831        pis  = sig0head(itypi,itypj)
1832        eps_head = epshead(itypi,itypj)
1833 c! First things first:
1834 c! We need to do sc_grad's job with GB and Fcav
1835        eom1  =
1836      &         eps2der * eps2rt_om1
1837      &       - 2.0D0 * alf1 * eps3der
1838      &       + sigder * sigsq_om1
1839      &       + dCAVdOM1
1840        eom2  =
1841      &         eps2der * eps2rt_om2
1842      &       + 2.0D0 * alf2 * eps3der
1843      &       + sigder * sigsq_om2
1844      &       + dCAVdOM2
1845        eom12 =
1846      &         evdwij  * eps1_om12
1847      &       + eps2der * eps2rt_om12
1848      &       - 2.0D0 * alf12 * eps3der
1849      &       + sigder *sigsq_om12
1850      &       + dCAVdOM12
1851 c! now some magical transformations to project gradient into
1852 c! three cartesian vectors
1853        DO k = 1, 3
1854         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1855         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1856         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1857 c! this acts on hydrophobic center of interaction
1858         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1859      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1860      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1861         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1862      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1863      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1864 c! this acts on Calpha
1865         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1866         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1867        END DO
1868 c! sc_grad is done, now we will compute
1869        eheadtail = 0.0d0
1870        eom1 = 0.0d0
1871        eom2 = 0.0d0
1872        eom12 = 0.0d0
1873
1874 c! ENERGY DEBUG
1875 c!       ii = 1
1876 c!       jj = 1
1877 c!       d1 = dhead(1, 1, itypi, itypj)
1878 c!       d2 = dhead(2, 1, itypi, itypj)
1879 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1880 c!     &        +dhead(1,ii,itypi,itypj))**2))
1881 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1882 c!     &        +dhead(2,jj,itypi,itypj))**2))
1883 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1884 c! END OF ENERGY DEBUG
1885 c*************************************************************
1886        DO istate = 1, nstate(itypi,itypj)
1887 c*************************************************************
1888         IF (istate.ne.1) THEN
1889          IF (istate.lt.3) THEN
1890           ii = 1
1891          ELSE
1892           ii = 2
1893          END IF
1894         jj = istate/ii
1895         d1 = dhead(1,ii,itypi,itypj)
1896         d2 = dhead(2,jj,itypi,itypj)
1897         DO k = 1,3
1898          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1899          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1900          Rhead_distance(k) = chead(k,2) - chead(k,1)
1901         END DO
1902 c! pitagoras (root of sum of squares)
1903         Rhead = dsqrt(
1904      &          (Rhead_distance(1)*Rhead_distance(1))
1905      &        + (Rhead_distance(2)*Rhead_distance(2))
1906      &        + (Rhead_distance(3)*Rhead_distance(3)))
1907         END IF
1908         Rhead_sq = Rhead * Rhead
1909
1910 c! R1 - distance between head of ith side chain and tail of jth sidechain
1911 c! R2 - distance between head of jth side chain and tail of ith sidechain
1912         R1 = 0.0d0
1913         R2 = 0.0d0
1914         DO k = 1, 3
1915 c! Calculate head-to-tail distances
1916          R1=R1+(ctail(k,2)-chead(k,1))**2
1917          R2=R2+(chead(k,2)-ctail(k,1))**2
1918         END DO
1919 c! Pitagoras
1920         R1 = dsqrt(R1)
1921         R2 = dsqrt(R2)
1922
1923 c! ENERGY DEBUG
1924 c!      write (*,*) "istate = ", istate
1925 c!      write (*,*) "ii = ", ii
1926 c!      write (*,*) "jj = ", jj
1927 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1928 c!     &        +dhead(1,ii,itypi,itypj))**2))
1929 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1930 c!     &        +dhead(2,jj,itypi,itypj))**2))
1931 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1932 c!      Rhead_sq = Rhead * Rhead
1933 c!      write (*,*) "d1 = ",d1
1934 c!      write (*,*) "d2 = ",d2
1935 c!      write (*,*) "R1 = ",R1
1936 c!      write (*,*) "R2 = ",R2
1937 c!      write (*,*) "Rhead = ",Rhead
1938 c! END OF ENERGY DEBUG
1939
1940 c!-------------------------------------------------------------------
1941 c! Coulomb electrostatic interaction
1942         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1943 c!        Ecl = 0.0d0
1944 c!        write (*,*) "Ecl = ", Ecl
1945 c! derivative of Ecl is Gcl...
1946         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1947 c!        dGCLdR = 0.0d0
1948         dGCLdOM1 = 0.0d0
1949         dGCLdOM2 = 0.0d0
1950         dGCLdOM12 = 0.0d0
1951 c!-------------------------------------------------------------------
1952 c! Generalised Born Solvent Polarization
1953         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1954         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1955         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1956 c!        Egb = 0.0d0
1957 c!      write (*,*) "a1*a2 = ", a12sq
1958 c!      write (*,*) "Rhead = ", Rhead
1959 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1960 c!      write (*,*) "ee = ", ee
1961 c!      write (*,*) "Fgb = ", Fgb
1962 c!      write (*,*) "fac = ", eps_inout_fac
1963 c!      write (*,*) "Qij = ", Qij
1964 c!      write (*,*) "Egb = ", Egb
1965 c! Derivative of Egb is Ggb...
1966 c! dFGBdR is used by Quad's later...
1967         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1968         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1969      &         / ( 2.0d0 * Fgb )
1970         dGGBdR = dGGBdFGB * dFGBdR
1971 c!        dGGBdR = 0.0d0
1972 c!-------------------------------------------------------------------
1973 c! Fisocav - isotropic cavity creation term
1974         pom = Rhead * csig
1975         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1976         bot = (1.0d0 + al4 * pom**12.0d0)
1977         botsq = bot * bot
1978         FisoCav = top / bot
1979 c!        FisoCav = 0.0d0
1980 c!      write (*,*) "pom = ",pom
1981 c!      write (*,*) "al1 = ",al1
1982 c!      write (*,*) "al2 = ",al2
1983 c!      write (*,*) "al3 = ",al3
1984 c!      write (*,*) "al4 = ",al4
1985 c!      write (*,*) "top = ",top
1986 c!      write (*,*) "bot = ",bot
1987 c!      write (*,*) "Fisocav = ", Fisocav
1988
1989 c! Derivative of Fisocav is GCV...
1990         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1991         dbot = 12.0d0 * al4 * pom ** 11.0d0
1992         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1993 c!        dGCVdR = 0.0d0
1994 c!-------------------------------------------------------------------
1995 c! Polarization energy
1996 c! Epol
1997         MomoFac1 = (1.0d0 - chi1 * sqom2)
1998         MomoFac2 = (1.0d0 - chi2 * sqom1)
1999         RR1  = ( R1 * R1 ) / MomoFac1
2000         RR2  = ( R2 * R2 ) / MomoFac2
2001         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2002         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2003         fgb1 = sqrt( RR1 + a12sq * ee1 )
2004         fgb2 = sqrt( RR2 + a12sq * ee2 )
2005         epol = 332.0d0 * eps_inout_fac * (
2006      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2007 c!        epol = 0.0d0
2008 c! derivative of Epol is Gpol...
2009         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2010      &            / (fgb1 ** 5.0d0)
2011         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2012      &            / (fgb2 ** 5.0d0)
2013         dFGBdR1 = ( (R1 / MomoFac1)
2014      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2015      &          / ( 2.0d0 * fgb1 )
2016         dFGBdR2 = ( (R2 / MomoFac2)
2017      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2018      &          / ( 2.0d0 * fgb2 )
2019         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2020      &           * ( 2.0d0 - 0.5d0 * ee1) )
2021      &           / ( 2.0d0 * fgb1 )
2022         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2023      &           * ( 2.0d0 - 0.5d0 * ee2) )
2024      &           / ( 2.0d0 * fgb2 )
2025         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2026 c!        dPOLdR1 = 0.0d0
2027         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2028 c!        dPOLdR2 = 0.0d0
2029         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2030 c!        dPOLdOM1 = 0.0d0
2031         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2032 c!        dPOLdOM2 = 0.0d0
2033 c!-------------------------------------------------------------------
2034 c! Elj
2035         pom = (pis / Rhead)**6.0d0
2036         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2037 c!        Elj = 0.0d0
2038 c! derivative of Elj is Glj
2039         dGLJdR = 4.0d0 * eps_head
2040      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2041      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2042 c!        dGLJdR = 0.0d0
2043 c!-------------------------------------------------------------------
2044 c! Equad
2045        IF (Wqd.ne.0.0d0) THEN
2046         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2047      &        - 37.5d0  * ( sqom1 + sqom2 )
2048      &        + 157.5d0 * ( sqom1 * sqom2 )
2049      &        - 45.0d0  * om1*om2*om12
2050         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2051         Equad = fac * Beta1
2052 c!        Equad = 0.0d0
2053 c! derivative of Equad...
2054         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2055 c!        dQUADdR = 0.0d0
2056         dQUADdOM1 = fac
2057      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2058 c!        dQUADdOM1 = 0.0d0
2059         dQUADdOM2 = fac
2060      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2061 c!        dQUADdOM2 = 0.0d0
2062         dQUADdOM12 = fac
2063      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2064 c!        dQUADdOM12 = 0.0d0
2065         ELSE
2066          Beta1 = 0.0d0
2067          Equad = 0.0d0
2068         END IF
2069 c!-------------------------------------------------------------------
2070 c! Return the results
2071 c! Angular stuff
2072         eom1 = dPOLdOM1 + dQUADdOM1
2073         eom2 = dPOLdOM2 + dQUADdOM2
2074         eom12 = dQUADdOM12
2075 c! now some magical transformations to project gradient into
2076 c! three cartesian vectors
2077         DO k = 1, 3
2078          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2079          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2080          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2081         END DO
2082 c! Radial stuff
2083         DO k = 1, 3
2084          erhead(k) = Rhead_distance(k)/Rhead
2085          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2086          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2087         END DO
2088         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2089         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2090         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2091         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2092         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2093         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2094         facd1 = d1 * vbld_inv(i+nres)
2095         facd2 = d2 * vbld_inv(j+nres)
2096         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2097         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2098 c! Throw the results into gheadtail which holds gradients
2099 c! for each micro-state
2100         DO k = 1, 3
2101          hawk   = erhead_tail(k,1) +
2102      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2103          condor = erhead_tail(k,2) +
2104      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2105
2106          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2107 c! this acts on hydrophobic center of interaction
2108          gheadtail(k,1,1) = gheadtail(k,1,1)
2109      &                    - dGCLdR * pom
2110      &                    - dGGBdR * pom
2111      &                    - dGCVdR * pom
2112      &                    - dPOLdR1 * hawk
2113      &                    - dPOLdR2 * (erhead_tail(k,2)
2114      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2115      &                    - dGLJdR * pom
2116      &                    - dQUADdR * pom
2117      &                    - tuna(k)
2118      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2119      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2120
2121          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2122 c! this acts on hydrophobic center of interaction
2123          gheadtail(k,2,1) = gheadtail(k,2,1)
2124      &                    + dGCLdR * pom
2125      &                    + dGGBdR * pom
2126      &                    + dGCVdR * pom
2127      &                    + dPOLdR1 * (erhead_tail(k,1)
2128      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2129      &                    + dPOLdR2 * condor
2130      &                    + dGLJdR * pom
2131      &                    + dQUADdR * pom
2132      &                    + tuna(k)
2133      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2134      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2135
2136 c! this acts on Calpha
2137          gheadtail(k,3,1) = gheadtail(k,3,1)
2138      &                    - dGCLdR * erhead(k)
2139      &                    - dGGBdR * erhead(k)
2140      &                    - dGCVdR * erhead(k)
2141      &                    - dPOLdR1 * erhead_tail(k,1)
2142      &                    - dPOLdR2 * erhead_tail(k,2)
2143      &                    - dGLJdR * erhead(k)
2144      &                    - dQUADdR * erhead(k)
2145      &                    - tuna(k)
2146
2147 c! this acts on Calpha
2148          gheadtail(k,4,1) = gheadtail(k,4,1)
2149      &                    + dGCLdR * erhead(k)
2150      &                    + dGGBdR * erhead(k)
2151      &                    + dGCVdR * erhead(k)
2152      &                    + dPOLdR1 * erhead_tail(k,1)
2153      &                    + dPOLdR2 * erhead_tail(k,2)
2154      &                    + dGLJdR * erhead(k)
2155      &                    + dQUADdR * erhead(k)
2156      &                    + tuna(k)
2157         END DO
2158 c!      write(*,*) "ECL = ", Ecl
2159 c!      write(*,*) "Egb = ", Egb
2160 c!      write(*,*) "Epol = ", Epol
2161 c!      write(*,*) "Fisocav = ", Fisocav
2162 c!      write(*,*) "Elj = ", Elj
2163 c!      write(*,*) "Equad = ", Equad
2164 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2165 c!      write(*,*) "eheadtail = ", eheadtail
2166 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2167 c!      write(*,*) "dGCLdR = ", dGCLdR
2168 c!      write(*,*) "dGGBdR = ", dGGBdR
2169 c!      write(*,*) "dGCVdR = ", dGCVdR
2170 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2171 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2172 c!      write(*,*) "dGLJdR = ", dGLJdR
2173 c!      write(*,*) "dQUADdR = ", dQUADdR
2174 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2175         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2176         eheadtail = eheadtail
2177      &            + wstate(istate, itypi, itypj)
2178      &            * dexp(-betaT * ener(istate))
2179 c! foreach cartesian dimension
2180         DO k = 1, 3
2181 c! foreach of two gvdwx and gvdwc
2182          DO l = 1, 4
2183           gheadtail(k,l,2) = gheadtail(k,l,2)
2184      &                     + wstate( istate, itypi, itypj )
2185      &                     * dexp(-betaT * ener(istate))
2186      &                     * gheadtail(k,l,1)
2187           gheadtail(k,l,1) = 0.0d0
2188          END DO
2189         END DO
2190        END DO
2191 c! Here ended the gigantic DO istate = 1, 4, which starts
2192 c! at the beggining of the subroutine
2193
2194        DO k = 1, 3
2195         DO l = 1, 4
2196          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2197         END DO
2198         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2199         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2200         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2201         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2202         DO l = 1, 4
2203          gheadtail(k,l,1) = 0.0d0
2204          gheadtail(k,l,2) = 0.0d0
2205         END DO
2206        END DO
2207        eheadtail = (-dlog(eheadtail)) / betaT
2208        dPOLdOM1 = 0.0d0
2209        dPOLdOM2 = 0.0d0
2210        dQUADdOM1 = 0.0d0
2211        dQUADdOM2 = 0.0d0
2212        dQUADdOM12 = 0.0d0
2213        RETURN
2214       END SUBROUTINE energy_quad
2215 c!-------------------------------------------------------------------
2216       SUBROUTINE eqn(Epol)
2217       IMPLICIT NONE
2218       INCLUDE 'DIMENSIONS'
2219       INCLUDE 'DIMENSIONS.ZSCOPT'
2220       INCLUDE 'COMMON.CALC'
2221       INCLUDE 'COMMON.CHAIN'
2222       INCLUDE 'COMMON.CONTROL'
2223       INCLUDE 'COMMON.DERIV'
2224       INCLUDE 'COMMON.EMP'
2225       INCLUDE 'COMMON.GEO'
2226       INCLUDE 'COMMON.INTERACT'
2227       INCLUDE 'COMMON.IOUNITS'
2228       INCLUDE 'COMMON.LOCAL'
2229       INCLUDE 'COMMON.NAMES'
2230       INCLUDE 'COMMON.VAR'
2231       double precision scalar, facd4, federmaus
2232       alphapol1 = alphapol(itypi,itypj)
2233 c! R1 - distance between head of ith side chain and tail of jth sidechain
2234        R1 = 0.0d0
2235        DO k = 1, 3
2236 c! Calculate head-to-tail distances
2237         R1=R1+(ctail(k,2)-chead(k,1))**2
2238        END DO
2239 c! Pitagoras
2240        R1 = dsqrt(R1)
2241
2242 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2243 c!     &        +dhead(1,1,itypi,itypj))**2))
2244 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2245 c!     &        +dhead(2,1,itypi,itypj))**2))
2246 c--------------------------------------------------------------------
2247 c Polarization energy
2248 c Epol
2249        MomoFac1 = (1.0d0 - chi1 * sqom2)
2250        RR1  = R1 * R1 / MomoFac1
2251        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2252        fgb1 = sqrt( RR1 + a12sq * ee1)
2253        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2254 c!       epol = 0.0d0
2255 c!------------------------------------------------------------------
2256 c! derivative of Epol is Gpol...
2257        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2258      &          / (fgb1 ** 5.0d0)
2259        dFGBdR1 = ( (R1 / MomoFac1)
2260      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2261      &        / ( 2.0d0 * fgb1 )
2262        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2263      &          * (2.0d0 - 0.5d0 * ee1) )
2264      &          / (2.0d0 * fgb1)
2265        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2266 c!       dPOLdR1 = 0.0d0
2267        dPOLdOM1 = 0.0d0
2268        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2269 c!       dPOLdOM2 = 0.0d0
2270 c!-------------------------------------------------------------------
2271 c! Return the results
2272 c! (see comments in Eqq)
2273        DO k = 1, 3
2274         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2275        END DO
2276        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2277        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2278        facd1 = d1 * vbld_inv(i+nres)
2279        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2280
2281        DO k = 1, 3
2282         hawk = (erhead_tail(k,1) +
2283      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2284
2285         gvdwx(k,i) = gvdwx(k,i)
2286      &             - dPOLdR1 * hawk
2287         gvdwx(k,j) = gvdwx(k,j)
2288      &             + dPOLdR1 * (erhead_tail(k,1)
2289      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2290
2291         gvdwc(k,i) = gvdwc(k,i)
2292      &             - dPOLdR1 * erhead_tail(k,1)
2293         gvdwc(k,j) = gvdwc(k,j)
2294      &             + dPOLdR1 * erhead_tail(k,1)
2295
2296        END DO
2297        RETURN
2298       END SUBROUTINE eqn
2299
2300
2301 c!-------------------------------------------------------------------
2302
2303
2304
2305       SUBROUTINE enq(Epol)
2306        IMPLICIT NONE
2307        INCLUDE 'DIMENSIONS'
2308        INCLUDE 'DIMENSIONS.ZSCOPT'
2309        INCLUDE 'COMMON.CALC'
2310        INCLUDE 'COMMON.CHAIN'
2311        INCLUDE 'COMMON.CONTROL'
2312        INCLUDE 'COMMON.DERIV'
2313        INCLUDE 'COMMON.EMP'
2314        INCLUDE 'COMMON.GEO'
2315        INCLUDE 'COMMON.INTERACT'
2316        INCLUDE 'COMMON.IOUNITS'
2317        INCLUDE 'COMMON.LOCAL'
2318        INCLUDE 'COMMON.NAMES'
2319        INCLUDE 'COMMON.VAR'
2320        double precision scalar, facd3, adler
2321        alphapol2 = alphapol(itypj,itypi)
2322 c! R2 - distance between head of jth side chain and tail of ith sidechain
2323        R2 = 0.0d0
2324        DO k = 1, 3
2325 c! Calculate head-to-tail distances
2326         R2=R2+(chead(k,2)-ctail(k,1))**2
2327        END DO
2328 c! Pitagoras
2329        R2 = dsqrt(R2)
2330
2331 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2332 c!     &        +dhead(1,1,itypi,itypj))**2))
2333 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2334 c!     &        +dhead(2,1,itypi,itypj))**2))
2335 c------------------------------------------------------------------------
2336 c Polarization energy
2337        MomoFac2 = (1.0d0 - chi2 * sqom1)
2338        RR2  = R2 * R2 / MomoFac2
2339        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2340        fgb2 = sqrt(RR2  + a12sq * ee2)
2341        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2342 c!       epol = 0.0d0
2343 c!-------------------------------------------------------------------
2344 c! derivative of Epol is Gpol...
2345        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2346      &          / (fgb2 ** 5.0d0)
2347        dFGBdR2 = ( (R2 / MomoFac2)
2348      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2349      &        / (2.0d0 * fgb2)
2350        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2351      &          * (2.0d0 - 0.5d0 * ee2) )
2352      &          / (2.0d0 * fgb2)
2353        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2354 c!       dPOLdR2 = 0.0d0
2355        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2356 c!       dPOLdOM1 = 0.0d0
2357        dPOLdOM2 = 0.0d0
2358 c!-------------------------------------------------------------------
2359 c! Return the results
2360 c! (See comments in Eqq)
2361        DO k = 1, 3
2362         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2363        END DO
2364        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2365        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2366        facd2 = d2 * vbld_inv(j+nres)
2367        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2368        DO k = 1, 3
2369         condor = (erhead_tail(k,2)
2370      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2371
2372         gvdwx(k,i) = gvdwx(k,i)
2373      &             - dPOLdR2 * (erhead_tail(k,2)
2374      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2375         gvdwx(k,j) = gvdwx(k,j)
2376      &             + dPOLdR2 * condor
2377
2378         gvdwc(k,i) = gvdwc(k,i)
2379      &             - dPOLdR2 * erhead_tail(k,2)
2380         gvdwc(k,j) = gvdwc(k,j)
2381      &             + dPOLdR2 * erhead_tail(k,2)
2382
2383        END DO
2384       RETURN
2385       END SUBROUTINE enq
2386
2387
2388 c!-------------------------------------------------------------------
2389
2390
2391       SUBROUTINE eqd(Ecl,Elj,Epol)
2392        IMPLICIT NONE
2393        INCLUDE 'DIMENSIONS'
2394        INCLUDE 'DIMENSIONS.ZSCOPT'
2395        INCLUDE 'COMMON.CALC'
2396        INCLUDE 'COMMON.CHAIN'
2397        INCLUDE 'COMMON.CONTROL'
2398        INCLUDE 'COMMON.DERIV'
2399        INCLUDE 'COMMON.EMP'
2400        INCLUDE 'COMMON.GEO'
2401        INCLUDE 'COMMON.INTERACT'
2402        INCLUDE 'COMMON.IOUNITS'
2403        INCLUDE 'COMMON.LOCAL'
2404        INCLUDE 'COMMON.NAMES'
2405        INCLUDE 'COMMON.VAR'
2406        double precision scalar, facd4, federmaus
2407        alphapol1 = alphapol(itypi,itypj)
2408        w1        = wqdip(1,itypi,itypj)
2409        w2        = wqdip(2,itypi,itypj)
2410        pis       = sig0head(itypi,itypj)
2411        eps_head   = epshead(itypi,itypj)
2412 c!-------------------------------------------------------------------
2413 c! R1 - distance between head of ith side chain and tail of jth sidechain
2414        R1 = 0.0d0
2415        DO k = 1, 3
2416 c! Calculate head-to-tail distances
2417         R1=R1+(ctail(k,2)-chead(k,1))**2
2418        END DO
2419 c! Pitagoras
2420        R1 = dsqrt(R1)
2421
2422 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2423 c!     &        +dhead(1,1,itypi,itypj))**2))
2424 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2425 c!     &        +dhead(2,1,itypi,itypj))**2))
2426
2427 c!-------------------------------------------------------------------
2428 c! ecl
2429        sparrow  = w1 * Qi * om1
2430        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2431        Ecl = sparrow / Rhead**2.0d0
2432      &     - hawk    / Rhead**4.0d0
2433 c!-------------------------------------------------------------------
2434 c! derivative of ecl is Gcl
2435 c! dF/dr part
2436        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2437      &           + 4.0d0 * hawk    / Rhead**5.0d0
2438 c! dF/dom1
2439        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2440 c! dF/dom2
2441        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2442 c--------------------------------------------------------------------
2443 c Polarization energy
2444 c Epol
2445        MomoFac1 = (1.0d0 - chi1 * sqom2)
2446        RR1  = R1 * R1 / MomoFac1
2447        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2448        fgb1 = sqrt( RR1 + a12sq * ee1)
2449        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2450 c!       epol = 0.0d0
2451 c!------------------------------------------------------------------
2452 c! derivative of Epol is Gpol...
2453        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2454      &          / (fgb1 ** 5.0d0)
2455        dFGBdR1 = ( (R1 / MomoFac1)
2456      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2457      &        / ( 2.0d0 * fgb1 )
2458        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2459      &          * (2.0d0 - 0.5d0 * ee1) )
2460      &          / (2.0d0 * fgb1)
2461        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2462 c!       dPOLdR1 = 0.0d0
2463        dPOLdOM1 = 0.0d0
2464        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2465 c!       dPOLdOM2 = 0.0d0
2466 c!-------------------------------------------------------------------
2467 c! Elj
2468        pom = (pis / Rhead)**6.0d0
2469        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2470 c! derivative of Elj is Glj
2471        dGLJdR = 4.0d0 * eps_head
2472      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2473      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2474 c!-------------------------------------------------------------------
2475 c! Return the results
2476        DO k = 1, 3
2477         erhead(k) = Rhead_distance(k)/Rhead
2478         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2479        END DO
2480
2481        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2482        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2483        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2484        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2485        facd1 = d1 * vbld_inv(i+nres)
2486        facd2 = d2 * vbld_inv(j+nres)
2487        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2488
2489        DO k = 1, 3
2490         hawk = (erhead_tail(k,1) +
2491      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2492
2493         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2494         gvdwx(k,i) = gvdwx(k,i)
2495      &             - dGCLdR * pom
2496      &             - dPOLdR1 * hawk
2497      &             - dGLJdR * pom
2498
2499         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2500         gvdwx(k,j) = gvdwx(k,j)
2501      &             + dGCLdR * pom
2502      &             + dPOLdR1 * (erhead_tail(k,1)
2503      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2504      &             + dGLJdR * pom
2505
2506
2507         gvdwc(k,i) = gvdwc(k,i)
2508      &             - dGCLdR * erhead(k)
2509      &             - dPOLdR1 * erhead_tail(k,1)
2510      &             - dGLJdR * erhead(k)
2511
2512         gvdwc(k,j) = gvdwc(k,j)
2513      &             + dGCLdR * erhead(k)
2514      &             + dPOLdR1 * erhead_tail(k,1)
2515      &             + dGLJdR * erhead(k)
2516
2517        END DO
2518        RETURN
2519       END SUBROUTINE eqd
2520
2521
2522 c!-------------------------------------------------------------------
2523
2524
2525       SUBROUTINE edq(Ecl,Elj,Epol)
2526        IMPLICIT NONE
2527        INCLUDE 'DIMENSIONS'
2528        INCLUDE 'DIMENSIONS.ZSCOPT'
2529        INCLUDE 'COMMON.CALC'
2530        INCLUDE 'COMMON.CHAIN'
2531        INCLUDE 'COMMON.CONTROL'
2532        INCLUDE 'COMMON.DERIV'
2533        INCLUDE 'COMMON.EMP'
2534        INCLUDE 'COMMON.GEO'
2535        INCLUDE 'COMMON.INTERACT'
2536        INCLUDE 'COMMON.IOUNITS'
2537        INCLUDE 'COMMON.LOCAL'
2538        INCLUDE 'COMMON.NAMES'
2539        INCLUDE 'COMMON.VAR'
2540        double precision scalar, facd3, adler
2541        alphapol2 = alphapol(itypj,itypi)
2542        w1        = wqdip(1,itypi,itypj)
2543        w2        = wqdip(2,itypi,itypj)
2544        pis       = sig0head(itypi,itypj)
2545        eps_head  = epshead(itypi,itypj)
2546 c!-------------------------------------------------------------------
2547 c! R2 - distance between head of jth side chain and tail of ith sidechain
2548        R2 = 0.0d0
2549        DO k = 1, 3
2550 c! Calculate head-to-tail distances
2551         R2=R2+(chead(k,2)-ctail(k,1))**2
2552        END DO
2553 c! Pitagoras
2554        R2 = dsqrt(R2)
2555
2556 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2557 c!     &        +dhead(1,1,itypi,itypj))**2))
2558 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2559 c!     &        +dhead(2,1,itypi,itypj))**2))
2560
2561
2562 c!-------------------------------------------------------------------
2563 c! ecl
2564        sparrow  = w1 * Qi * om1
2565        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2566        ECL = sparrow / Rhead**2.0d0
2567      &     - hawk    / Rhead**4.0d0
2568 c!-------------------------------------------------------------------
2569 c! derivative of ecl is Gcl
2570 c! dF/dr part
2571        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2572      &           + 4.0d0 * hawk    / Rhead**5.0d0
2573 c! dF/dom1
2574        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2575 c! dF/dom2
2576        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2577 c--------------------------------------------------------------------
2578 c Polarization energy
2579 c Epol
2580        MomoFac2 = (1.0d0 - chi2 * sqom1)
2581        RR2  = R2 * R2 / MomoFac2
2582        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2583        fgb2 = sqrt(RR2  + a12sq * ee2)
2584        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2585 c!       epol = 0.0d0
2586 c! derivative of Epol is Gpol...
2587        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2588      &          / (fgb2 ** 5.0d0)
2589        dFGBdR2 = ( (R2 / MomoFac2)
2590      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2591      &        / (2.0d0 * fgb2)
2592        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2593      &          * (2.0d0 - 0.5d0 * ee2) )
2594      &          / (2.0d0 * fgb2)
2595        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2596 c!       dPOLdR2 = 0.0d0
2597        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2598 c!       dPOLdOM1 = 0.0d0
2599        dPOLdOM2 = 0.0d0
2600 c!-------------------------------------------------------------------
2601 c! Elj
2602        pom = (pis / Rhead)**6.0d0
2603        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2604 c! derivative of Elj is Glj
2605        dGLJdR = 4.0d0 * eps_head
2606      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2607      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2608 c!-------------------------------------------------------------------
2609 c! Return the results
2610 c! (see comments in Eqq)
2611        DO k = 1, 3
2612         erhead(k) = Rhead_distance(k)/Rhead
2613         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2614        END DO
2615        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2616        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2617        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2618        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2619        facd1 = d1 * vbld_inv(i+nres)
2620        facd2 = d2 * vbld_inv(j+nres)
2621        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2622
2623        DO k = 1, 3
2624         condor = (erhead_tail(k,2)
2625      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2626
2627         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2628         gvdwx(k,i) = gvdwx(k,i)
2629      &             - dGCLdR * pom
2630      &             - dPOLdR2 * (erhead_tail(k,2)
2631      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2632      &             - dGLJdR * pom
2633
2634         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2635         gvdwx(k,j) = gvdwx(k,j)
2636      &             + dGCLdR * pom
2637      &             + dPOLdR2 * condor
2638      &             + dGLJdR * pom
2639
2640
2641         gvdwc(k,i) = gvdwc(k,i)
2642      &             - dGCLdR * erhead(k)
2643      &             - dPOLdR2 * erhead_tail(k,2)
2644      &             - dGLJdR * erhead(k)
2645
2646         gvdwc(k,j) = gvdwc(k,j)
2647      &             + dGCLdR * erhead(k)
2648      &             + dPOLdR2 * erhead_tail(k,2)
2649      &             + dGLJdR * erhead(k)
2650
2651        END DO
2652        RETURN
2653       END SUBROUTINE edq
2654
2655
2656 C--------------------------------------------------------------------
2657
2658
2659       SUBROUTINE edd(ECL)
2660        IMPLICIT NONE
2661        INCLUDE 'DIMENSIONS'
2662        INCLUDE 'DIMENSIONS.ZSCOPT'
2663        INCLUDE 'COMMON.CALC'
2664        INCLUDE 'COMMON.CHAIN'
2665        INCLUDE 'COMMON.CONTROL'
2666        INCLUDE 'COMMON.DERIV'
2667        INCLUDE 'COMMON.EMP'
2668        INCLUDE 'COMMON.GEO'
2669        INCLUDE 'COMMON.INTERACT'
2670        INCLUDE 'COMMON.IOUNITS'
2671        INCLUDE 'COMMON.LOCAL'
2672        INCLUDE 'COMMON.NAMES'
2673        INCLUDE 'COMMON.VAR'
2674        double precision scalar
2675 c!       csig = sigiso(itypi,itypj)
2676        w1 = wqdip(1,itypi,itypj)
2677        w2 = wqdip(2,itypi,itypj)
2678 c!-------------------------------------------------------------------
2679 c! ECL
2680        fac = (om12 - 3.0d0 * om1 * om2)
2681        c1 = (w1 / (Rhead**3.0d0)) * fac
2682        c2 = (w2 / Rhead ** 6.0d0)
2683      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2684        ECL = c1 - c2
2685 c!       write (*,*) "w1 = ", w1
2686 c!       write (*,*) "w2 = ", w2
2687 c!       write (*,*) "om1 = ", om1
2688 c!       write (*,*) "om2 = ", om2
2689 c!       write (*,*) "om12 = ", om12
2690 c!       write (*,*) "fac = ", fac
2691 c!       write (*,*) "c1 = ", c1
2692 c!       write (*,*) "c2 = ", c2
2693 c!       write (*,*) "Ecl = ", Ecl
2694 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2695 c!       write (*,*) "c2_2 = ",
2696 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2697 c!-------------------------------------------------------------------
2698 c! dervative of ECL is GCL...
2699 c! dECL/dr
2700        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2701        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2702      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2703        dGCLdR = c1 - c2
2704 c! dECL/dom1
2705        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2706        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2707      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2708        dGCLdOM1 = c1 - c2
2709 c! dECL/dom2
2710        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2711        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2712      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2713        dGCLdOM2 = c1 - c2
2714 c! dECL/dom12
2715        c1 = w1 / (Rhead ** 3.0d0)
2716        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2717        dGCLdOM12 = c1 - c2
2718 c!-------------------------------------------------------------------
2719 c! Return the results
2720 c! (see comments in Eqq)
2721        DO k= 1, 3
2722         erhead(k) = Rhead_distance(k)/Rhead
2723        END DO
2724        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2725        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2726        facd1 = d1 * vbld_inv(i+nres)
2727        facd2 = d2 * vbld_inv(j+nres)
2728        DO k = 1, 3
2729
2730         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2731         gvdwx(k,i) = gvdwx(k,i)
2732      &             - dGCLdR * pom
2733         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2734         gvdwx(k,j) = gvdwx(k,j)
2735      &             + dGCLdR * pom
2736
2737         gvdwc(k,i) = gvdwc(k,i)
2738      &             - dGCLdR * erhead(k)
2739         gvdwc(k,j) = gvdwc(k,j)
2740      &             + dGCLdR * erhead(k)
2741        END DO
2742        RETURN
2743       END SUBROUTINE edd
2744
2745
2746 c!-------------------------------------------------------------------
2747
2748
2749       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2750        IMPLICIT NONE
2751 c! maxres
2752        INCLUDE 'DIMENSIONS'
2753        INCLUDE 'DIMENSIONS.ZSCOPT'
2754 c! itypi, itypj, i, j, k, l, chead,
2755        INCLUDE 'COMMON.CALC'
2756 c! c, nres, dc_norm
2757        INCLUDE 'COMMON.CHAIN'
2758 c! gradc, gradx
2759        INCLUDE 'COMMON.DERIV'
2760 c! electrostatic gradients-specific variables
2761        INCLUDE 'COMMON.EMP'
2762 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2763        INCLUDE 'COMMON.INTERACT'
2764 c! t_bath, Rb
2765 c       INCLUDE 'COMMON.MD'
2766 c! io for debug, disable it in final builds
2767        INCLUDE 'COMMON.IOUNITS'
2768        double precision Rb /1.987D-3/
2769 c!-------------------------------------------------------------------
2770 c! Variable Init
2771
2772 c! what amino acid is the aminoacid j'th?
2773        itypj = itype(j)
2774 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2775 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2776 c!       t_bath = 300
2777 c!       BetaT = 1.0d0 / (t_bath * Rb)
2778        BetaT = 1.0d0 / (298.0d0 * Rb)
2779 c! Gay-berne var's
2780        sig0ij = sigma( itypi,itypj )
2781        chi1   = chi( itypi, itypj )
2782        chi2   = chi( itypj, itypi )
2783        chi12  = chi1 * chi2
2784        chip1  = chipp( itypi, itypj )
2785        chip2  = chipp( itypj, itypi )
2786        chip12 = chip1 * chip2
2787 c! not used by momo potential, but needed by sc_angular which is shared
2788 c! by all energy_potential subroutines
2789        alf1   = 0.0d0
2790        alf2   = 0.0d0
2791        alf12  = 0.0d0
2792 c! location, location, location
2793        xj  = c( 1, nres+j ) - xi
2794        yj  = c( 2, nres+j ) - yi
2795        zj  = c( 3, nres+j ) - zi
2796        dxj = dc_norm( 1, nres+j )
2797        dyj = dc_norm( 2, nres+j )
2798        dzj = dc_norm( 3, nres+j )
2799 c! distance from center of chain(?) to polar/charged head
2800 c!       write (*,*) "istate = ", 1
2801 c!       write (*,*) "ii = ", 1
2802 c!       write (*,*) "jj = ", 1
2803        d1 = dhead(1, 1, itypi, itypj)
2804        d2 = dhead(2, 1, itypi, itypj)
2805 c! ai*aj from Fgb
2806        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2807 c!       a12sq = a12sq * a12sq
2808 c! charge of amino acid itypi is...
2809        Qi  = icharge(itypi)
2810        Qj  = icharge(itypj)
2811        Qij = Qi * Qj
2812 c! chis1,2,12
2813        chis1 = chis(itypi,itypj)
2814        chis2 = chis(itypj,itypi)
2815        chis12 = chis1 * chis2
2816        sig1 = sigmap1(itypi,itypj)
2817        sig2 = sigmap2(itypi,itypj)
2818 c!       write (*,*) "sig1 = ", sig1
2819 c!       write (*,*) "sig2 = ", sig2
2820 c! alpha factors from Fcav/Gcav
2821        b1 = alphasur(1,itypi,itypj)
2822        b2 = alphasur(2,itypi,itypj)
2823        b3 = alphasur(3,itypi,itypj)
2824        b4 = alphasur(4,itypi,itypj)
2825 c! used to determine whether we want to do quadrupole calculations
2826        wqd = wquad(itypi, itypj)
2827 c! used by Fgb
2828        eps_in = epsintab(itypi,itypj)
2829        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2830 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2831 c!-------------------------------------------------------------------
2832 c! tail location and distance calculations
2833        Rtail = 0.0d0
2834        DO k = 1, 3
2835         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2836         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2837        END DO
2838 c! tail distances will be themselves usefull elswhere
2839 c1 (in Gcav, for example)
2840        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2841        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2842        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2843        Rtail = dsqrt(
2844      &     (Rtail_distance(1)*Rtail_distance(1))
2845      &   + (Rtail_distance(2)*Rtail_distance(2))
2846      &   + (Rtail_distance(3)*Rtail_distance(3)))
2847 c!-------------------------------------------------------------------
2848 c! Calculate location and distance between polar heads
2849 c! distance between heads
2850 c! for each one of our three dimensional space...
2851        DO k = 1,3
2852 c! location of polar head is computed by taking hydrophobic centre
2853 c! and moving by a d1 * dc_norm vector
2854 c! see unres publications for very informative images
2855         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2856         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2857 c! distance
2858 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2859 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2860         Rhead_distance(k) = chead(k,2) - chead(k,1)
2861        END DO
2862 c! pitagoras (root of sum of squares)
2863        Rhead = dsqrt(
2864      &     (Rhead_distance(1)*Rhead_distance(1))
2865      &   + (Rhead_distance(2)*Rhead_distance(2))
2866      &   + (Rhead_distance(3)*Rhead_distance(3)))
2867 c!-------------------------------------------------------------------
2868 c! zero everything that should be zero'ed
2869        Egb = 0.0d0
2870        ECL = 0.0d0
2871        Elj = 0.0d0
2872        Equad = 0.0d0
2873        Epol = 0.0d0
2874        eheadtail = 0.0d0
2875        dGCLdOM1 = 0.0d0
2876        dGCLdOM2 = 0.0d0
2877        dGCLdOM12 = 0.0d0
2878        dPOLdOM1 = 0.0d0
2879        dPOLdOM2 = 0.0d0
2880        RETURN
2881       END SUBROUTINE elgrad_init
2882
2883
2884 C-----------------------------------------------------------------------------
2885       subroutine sc_angular
2886 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2887 C om12. Called by ebp, egb, and egbv.
2888       implicit none
2889       include 'COMMON.CALC'
2890       erij(1)=xj*rij
2891       erij(2)=yj*rij
2892       erij(3)=zj*rij
2893       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2894       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2895       om12=dxi*dxj+dyi*dyj+dzi*dzj
2896       chiom12=chi12*om12
2897 C Calculate eps1(om12) and its derivative in om12
2898       faceps1=1.0D0-om12*chiom12
2899       faceps1_inv=1.0D0/faceps1
2900       eps1=dsqrt(faceps1_inv)
2901 C Following variable is eps1*deps1/dom12
2902       eps1_om12=faceps1_inv*chiom12
2903 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2904 C and om12.
2905       om1om2=om1*om2
2906       chiom1=chi1*om1
2907       chiom2=chi2*om2
2908       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2909       sigsq=1.0D0-facsig*faceps1_inv
2910       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2911       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2912       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2913 C Calculate eps2 and its derivatives in om1, om2, and om12.
2914       chipom1=chip1*om1
2915       chipom2=chip2*om2
2916       chipom12=chip12*om12
2917       facp=1.0D0-om12*chipom12
2918       facp_inv=1.0D0/facp
2919       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2920 C Following variable is the square root of eps2
2921       eps2rt=1.0D0-facp1*facp_inv
2922 C Following three variables are the derivatives of the square root of eps
2923 C in om1, om2, and om12.
2924       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2925       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2926       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2927 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2928       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2929 C Calculate whole angle-dependent part of epsilon and contributions
2930 C to its derivatives
2931       return
2932       end
2933 C----------------------------------------------------------------------------
2934       subroutine sc_grad
2935       implicit real*8 (a-h,o-z)
2936       include 'DIMENSIONS'
2937       include 'DIMENSIONS.ZSCOPT'
2938       include 'COMMON.CHAIN'
2939       include 'COMMON.DERIV'
2940       include 'COMMON.CALC'
2941       double precision dcosom1(3),dcosom2(3)
2942       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2943       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2944       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2945      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2946       do k=1,3
2947         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2948         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2949       enddo
2950       do k=1,3
2951         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2952       enddo
2953       do k=1,3
2954         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2955      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2956      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2957         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2958      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2959      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2960       enddo
2961 C
2962 C Calculate the components of the gradient in DC and X
2963 C
2964       do k=i,j-1
2965         do l=1,3
2966           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2967         enddo
2968       enddo
2969       return
2970       end
2971 c------------------------------------------------------------------------------
2972       subroutine vec_and_deriv
2973       implicit real*8 (a-h,o-z)
2974       include 'DIMENSIONS'
2975       include 'DIMENSIONS.ZSCOPT'
2976       include 'COMMON.IOUNITS'
2977       include 'COMMON.GEO'
2978       include 'COMMON.VAR'
2979       include 'COMMON.LOCAL'
2980       include 'COMMON.CHAIN'
2981       include 'COMMON.VECTORS'
2982       include 'COMMON.DERIV'
2983       include 'COMMON.INTERACT'
2984       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2985 C Compute the local reference systems. For reference system (i), the
2986 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2987 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2988       do i=1,nres-1
2989 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2990           if (i.eq.nres-1) then
2991 C Case of the last full residue
2992 C Compute the Z-axis
2993             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2994             costh=dcos(pi-theta(nres))
2995             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2996             do k=1,3
2997               uz(k,i)=fac*uz(k,i)
2998             enddo
2999             if (calc_grad) then
3000 C Compute the derivatives of uz
3001             uzder(1,1,1)= 0.0d0
3002             uzder(2,1,1)=-dc_norm(3,i-1)
3003             uzder(3,1,1)= dc_norm(2,i-1)
3004             uzder(1,2,1)= dc_norm(3,i-1)
3005             uzder(2,2,1)= 0.0d0
3006             uzder(3,2,1)=-dc_norm(1,i-1)
3007             uzder(1,3,1)=-dc_norm(2,i-1)
3008             uzder(2,3,1)= dc_norm(1,i-1)
3009             uzder(3,3,1)= 0.0d0
3010             uzder(1,1,2)= 0.0d0
3011             uzder(2,1,2)= dc_norm(3,i)
3012             uzder(3,1,2)=-dc_norm(2,i)
3013             uzder(1,2,2)=-dc_norm(3,i)
3014             uzder(2,2,2)= 0.0d0
3015             uzder(3,2,2)= dc_norm(1,i)
3016             uzder(1,3,2)= dc_norm(2,i)
3017             uzder(2,3,2)=-dc_norm(1,i)
3018             uzder(3,3,2)= 0.0d0
3019             endif
3020 C Compute the Y-axis
3021             facy=fac
3022             do k=1,3
3023               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3024             enddo
3025             if (calc_grad) then
3026 C Compute the derivatives of uy
3027             do j=1,3
3028               do k=1,3
3029                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3030      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3031                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3032               enddo
3033               uyder(j,j,1)=uyder(j,j,1)-costh
3034               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3035             enddo
3036             do j=1,2
3037               do k=1,3
3038                 do l=1,3
3039                   uygrad(l,k,j,i)=uyder(l,k,j)
3040                   uzgrad(l,k,j,i)=uzder(l,k,j)
3041                 enddo
3042               enddo
3043             enddo
3044             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3045             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3046             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3047             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3048             endif
3049           else
3050 C Other residues
3051 C Compute the Z-axis
3052             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3053             costh=dcos(pi-theta(i+2))
3054             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3055             do k=1,3
3056               uz(k,i)=fac*uz(k,i)
3057             enddo
3058             if (calc_grad) then
3059 C Compute the derivatives of uz
3060             uzder(1,1,1)= 0.0d0
3061             uzder(2,1,1)=-dc_norm(3,i+1)
3062             uzder(3,1,1)= dc_norm(2,i+1)
3063             uzder(1,2,1)= dc_norm(3,i+1)
3064             uzder(2,2,1)= 0.0d0
3065             uzder(3,2,1)=-dc_norm(1,i+1)
3066             uzder(1,3,1)=-dc_norm(2,i+1)
3067             uzder(2,3,1)= dc_norm(1,i+1)
3068             uzder(3,3,1)= 0.0d0
3069             uzder(1,1,2)= 0.0d0
3070             uzder(2,1,2)= dc_norm(3,i)
3071             uzder(3,1,2)=-dc_norm(2,i)
3072             uzder(1,2,2)=-dc_norm(3,i)
3073             uzder(2,2,2)= 0.0d0
3074             uzder(3,2,2)= dc_norm(1,i)
3075             uzder(1,3,2)= dc_norm(2,i)
3076             uzder(2,3,2)=-dc_norm(1,i)
3077             uzder(3,3,2)= 0.0d0
3078             endif
3079 C Compute the Y-axis
3080             facy=fac
3081             do k=1,3
3082               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3083             enddo
3084             if (calc_grad) then
3085 C Compute the derivatives of uy
3086             do j=1,3
3087               do k=1,3
3088                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3089      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3090                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3091               enddo
3092               uyder(j,j,1)=uyder(j,j,1)-costh
3093               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3094             enddo
3095             do j=1,2
3096               do k=1,3
3097                 do l=1,3
3098                   uygrad(l,k,j,i)=uyder(l,k,j)
3099                   uzgrad(l,k,j,i)=uzder(l,k,j)
3100                 enddo
3101               enddo
3102             enddo
3103             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3104             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3105             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3106             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3107           endif
3108           endif
3109       enddo
3110       if (calc_grad) then
3111       do i=1,nres-1
3112         vbld_inv_temp(1)=vbld_inv(i+1)
3113         if (i.lt.nres-1) then
3114           vbld_inv_temp(2)=vbld_inv(i+2)
3115         else
3116           vbld_inv_temp(2)=vbld_inv(i)
3117         endif
3118         do j=1,2
3119           do k=1,3
3120             do l=1,3
3121               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3122               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3123             enddo
3124           enddo
3125         enddo
3126       enddo
3127       endif
3128       return
3129       end
3130 c------------------------------------------------------------------------------
3131       subroutine set_matrices
3132       implicit real*8 (a-h,o-z)
3133       include 'DIMENSIONS'
3134 #ifdef MPI
3135       include "mpif.h"
3136       integer IERR
3137       integer status(MPI_STATUS_SIZE)
3138 #endif
3139       include 'DIMENSIONS.ZSCOPT'
3140       include 'COMMON.IOUNITS'
3141       include 'COMMON.GEO'
3142       include 'COMMON.VAR'
3143       include 'COMMON.LOCAL'
3144       include 'COMMON.CHAIN'
3145       include 'COMMON.DERIV'
3146       include 'COMMON.INTERACT'
3147       include 'COMMON.CONTACTS'
3148       include 'COMMON.TORSION'
3149       include 'COMMON.VECTORS'
3150       include 'COMMON.FFIELD'
3151       double precision auxvec(2),auxmat(2,2)
3152 C
3153 C Compute the virtual-bond-torsional-angle dependent quantities needed
3154 C to calculate the el-loc multibody terms of various order.
3155 C
3156 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3157       do i=3,nres+1
3158         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3159           iti = itype2loc(itype(i-2))
3160         else
3161           iti=nloctyp
3162         endif
3163 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3164         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3165           iti1 = itype2loc(itype(i-1))
3166         else
3167           iti1=nloctyp
3168         endif
3169 #ifdef NEWCORR
3170         cost1=dcos(theta(i-1))
3171         sint1=dsin(theta(i-1))
3172         sint1sq=sint1*sint1
3173         sint1cub=sint1sq*sint1
3174         sint1cost1=2*sint1*cost1
3175 #ifdef DEBUG
3176         write (iout,*) "bnew1",i,iti
3177         write (iout,*) (bnew1(k,1,iti),k=1,3)
3178         write (iout,*) (bnew1(k,2,iti),k=1,3)
3179         write (iout,*) "bnew2",i,iti
3180         write (iout,*) (bnew2(k,1,iti),k=1,3)
3181         write (iout,*) (bnew2(k,2,iti),k=1,3)
3182 #endif
3183         do k=1,2
3184           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3185           b1(k,i-2)=sint1*b1k
3186           gtb1(k,i-2)=cost1*b1k-sint1sq*
3187      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3188           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3189           b2(k,i-2)=sint1*b2k
3190           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3191      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3192         enddo
3193         do k=1,2
3194           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3195           cc(1,k,i-2)=sint1sq*aux
3196           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3197      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3198           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3199           dd(1,k,i-2)=sint1sq*aux
3200           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3201      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3202         enddo
3203         cc(2,1,i-2)=cc(1,2,i-2)
3204         cc(2,2,i-2)=-cc(1,1,i-2)
3205         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3206         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3207         dd(2,1,i-2)=dd(1,2,i-2)
3208         dd(2,2,i-2)=-dd(1,1,i-2)
3209         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3210         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3211         do k=1,2
3212           do l=1,2
3213             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3214             EE(l,k,i-2)=sint1sq*aux
3215             if (calc_grad)
3216      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3217           enddo
3218         enddo
3219         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3220         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3221         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3222         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3223         if (calc_grad) then
3224         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3225         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3226         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3227         endif
3228 c        b1tilde(1,i-2)=b1(1,i-2)
3229 c        b1tilde(2,i-2)=-b1(2,i-2)
3230 c        b2tilde(1,i-2)=b2(1,i-2)
3231 c        b2tilde(2,i-2)=-b2(2,i-2)
3232 #ifdef DEBUG
3233         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3234         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3235         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3236         write (iout,*) 'theta=', theta(i-1)
3237 #endif
3238 #else
3239         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3240           iti = itype2loc(itype(i-2))
3241         else
3242           iti=nloctyp
3243         endif
3244 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3245         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3246           iti1 = itype2loc(itype(i-1))
3247         else
3248           iti1=nloctyp
3249         endif
3250         b1(1,i-2)=b(3,iti)
3251         b1(2,i-2)=b(5,iti)
3252         b2(1,i-2)=b(2,iti)
3253         b2(2,i-2)=b(4,iti)
3254         do k=1,2
3255           do l=1,2
3256            CC(k,l,i-2)=ccold(k,l,iti)
3257            DD(k,l,i-2)=ddold(k,l,iti)
3258            EE(k,l,i-2)=eeold(k,l,iti)
3259           enddo
3260         enddo
3261 #endif
3262         b1tilde(1,i-2)= b1(1,i-2)
3263         b1tilde(2,i-2)=-b1(2,i-2)
3264         b2tilde(1,i-2)= b2(1,i-2)
3265         b2tilde(2,i-2)=-b2(2,i-2)
3266 c
3267         Ctilde(1,1,i-2)= CC(1,1,i-2)
3268         Ctilde(1,2,i-2)= CC(1,2,i-2)
3269         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3270         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3271 c
3272         Dtilde(1,1,i-2)= DD(1,1,i-2)
3273         Dtilde(1,2,i-2)= DD(1,2,i-2)
3274         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3275         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3276 c        write(iout,*) "i",i," iti",iti
3277 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3278 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3279       enddo
3280       do i=3,nres+1
3281         if (i .lt. nres+1) then
3282           sin1=dsin(phi(i))
3283           cos1=dcos(phi(i))
3284           sintab(i-2)=sin1
3285           costab(i-2)=cos1
3286           obrot(1,i-2)=cos1
3287           obrot(2,i-2)=sin1
3288           sin2=dsin(2*phi(i))
3289           cos2=dcos(2*phi(i))
3290           sintab2(i-2)=sin2
3291           costab2(i-2)=cos2
3292           obrot2(1,i-2)=cos2
3293           obrot2(2,i-2)=sin2
3294           Ug(1,1,i-2)=-cos1
3295           Ug(1,2,i-2)=-sin1
3296           Ug(2,1,i-2)=-sin1
3297           Ug(2,2,i-2)= cos1
3298           Ug2(1,1,i-2)=-cos2
3299           Ug2(1,2,i-2)=-sin2
3300           Ug2(2,1,i-2)=-sin2
3301           Ug2(2,2,i-2)= cos2
3302         else
3303           costab(i-2)=1.0d0
3304           sintab(i-2)=0.0d0
3305           obrot(1,i-2)=1.0d0
3306           obrot(2,i-2)=0.0d0
3307           obrot2(1,i-2)=0.0d0
3308           obrot2(2,i-2)=0.0d0
3309           Ug(1,1,i-2)=1.0d0
3310           Ug(1,2,i-2)=0.0d0
3311           Ug(2,1,i-2)=0.0d0
3312           Ug(2,2,i-2)=1.0d0
3313           Ug2(1,1,i-2)=0.0d0
3314           Ug2(1,2,i-2)=0.0d0
3315           Ug2(2,1,i-2)=0.0d0
3316           Ug2(2,2,i-2)=0.0d0
3317         endif
3318         if (i .gt. 3 .and. i .lt. nres+1) then
3319           obrot_der(1,i-2)=-sin1
3320           obrot_der(2,i-2)= cos1
3321           Ugder(1,1,i-2)= sin1
3322           Ugder(1,2,i-2)=-cos1
3323           Ugder(2,1,i-2)=-cos1
3324           Ugder(2,2,i-2)=-sin1
3325           dwacos2=cos2+cos2
3326           dwasin2=sin2+sin2
3327           obrot2_der(1,i-2)=-dwasin2
3328           obrot2_der(2,i-2)= dwacos2
3329           Ug2der(1,1,i-2)= dwasin2
3330           Ug2der(1,2,i-2)=-dwacos2
3331           Ug2der(2,1,i-2)=-dwacos2
3332           Ug2der(2,2,i-2)=-dwasin2
3333         else
3334           obrot_der(1,i-2)=0.0d0
3335           obrot_der(2,i-2)=0.0d0
3336           Ugder(1,1,i-2)=0.0d0
3337           Ugder(1,2,i-2)=0.0d0
3338           Ugder(2,1,i-2)=0.0d0
3339           Ugder(2,2,i-2)=0.0d0
3340           obrot2_der(1,i-2)=0.0d0
3341           obrot2_der(2,i-2)=0.0d0
3342           Ug2der(1,1,i-2)=0.0d0
3343           Ug2der(1,2,i-2)=0.0d0
3344           Ug2der(2,1,i-2)=0.0d0
3345           Ug2der(2,2,i-2)=0.0d0
3346         endif
3347 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3348         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3349           iti = itype2loc(itype(i-2))
3350         else
3351           iti=nloctyp
3352         endif
3353 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3354         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3355           iti1 = itype2loc(itype(i-1))
3356         else
3357           iti1=nloctyp
3358         endif
3359 cd        write (iout,*) '*******i',i,' iti1',iti
3360 cd        write (iout,*) 'b1',b1(:,iti)
3361 cd        write (iout,*) 'b2',b2(:,iti)
3362 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3363 c        if (i .gt. iatel_s+2) then
3364         if (i .gt. nnt+2) then
3365           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3366 #ifdef NEWCORR
3367           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3368 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3369 #endif
3370 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3371 c     &    EE(1,2,iti),EE(2,2,i)
3372           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3373           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3374 c          write(iout,*) "Macierz EUG",
3375 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3376 c     &    eug(2,2,i-2)
3377           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3378      &    then
3379           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3380           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3381           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3382           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3383           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3384           endif
3385         else
3386           do k=1,2
3387             Ub2(k,i-2)=0.0d0
3388             Ctobr(k,i-2)=0.0d0
3389             Dtobr2(k,i-2)=0.0d0
3390             do l=1,2
3391               EUg(l,k,i-2)=0.0d0
3392               CUg(l,k,i-2)=0.0d0
3393               DUg(l,k,i-2)=0.0d0
3394               DtUg2(l,k,i-2)=0.0d0
3395             enddo
3396           enddo
3397         endif
3398         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3399         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3400         do k=1,2
3401           muder(k,i-2)=Ub2der(k,i-2)
3402         enddo
3403 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3404         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3405           if (itype(i-1).le.ntyp) then
3406             iti1 = itype2loc(itype(i-1))
3407           else
3408             iti1=nloctyp
3409           endif
3410         else
3411           iti1=nloctyp
3412         endif
3413         do k=1,2
3414           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3415         enddo
3416 #ifdef MUOUT
3417         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3418      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3419      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3420      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3421      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3422      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3423 #endif
3424 cd        write (iout,*) 'mu1',mu1(:,i-2)
3425 cd        write (iout,*) 'mu2',mu2(:,i-2)
3426         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3427      &  then
3428         if (calc_grad) then
3429         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3430         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3431         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3432         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3433         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3434         endif
3435 C Vectors and matrices dependent on a single virtual-bond dihedral.
3436         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3437         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3438         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3439         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3440         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3441         if (calc_grad) then
3442         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3443         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3444         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3445         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3446         endif
3447         endif
3448       enddo
3449 C Matrices dependent on two consecutive virtual-bond dihedrals.
3450 C The order of matrices is from left to right.
3451       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3452      &then
3453       do i=2,nres-1
3454         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3455         if (calc_grad) then
3456         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3457         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3458         endif
3459         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3460         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3461         if (calc_grad) then
3462         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3463         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3464         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3465         endif
3466       enddo
3467       endif
3468       return
3469       end
3470 C--------------------------------------------------------------------------
3471       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3472 C
3473 C This subroutine calculates the average interaction energy and its gradient
3474 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3475 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3476 C The potential depends both on the distance of peptide-group centers and on
3477 C the orientation of the CA-CA virtual bonds.
3478 C
3479       implicit real*8 (a-h,o-z)
3480 #ifdef MPI
3481       include 'mpif.h'
3482 #endif
3483       include 'DIMENSIONS'
3484       include 'DIMENSIONS.ZSCOPT'
3485       include 'COMMON.CONTROL'
3486       include 'COMMON.IOUNITS'
3487       include 'COMMON.GEO'
3488       include 'COMMON.VAR'
3489       include 'COMMON.LOCAL'
3490       include 'COMMON.CHAIN'
3491       include 'COMMON.DERIV'
3492       include 'COMMON.INTERACT'
3493       include 'COMMON.CONTACTS'
3494       include 'COMMON.TORSION'
3495       include 'COMMON.VECTORS'
3496       include 'COMMON.FFIELD'
3497       include 'COMMON.TIME1'
3498       include 'COMMON.SPLITELE'
3499       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3500      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3501       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3502      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3503       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3504      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3505      &    num_conti,j1,j2
3506 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3507 #ifdef MOMENT
3508       double precision scal_el /1.0d0/
3509 #else
3510       double precision scal_el /0.5d0/
3511 #endif
3512 C 12/13/98
3513 C 13-go grudnia roku pamietnego...
3514       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3515      &                   0.0d0,1.0d0,0.0d0,
3516      &                   0.0d0,0.0d0,1.0d0/
3517 cd      write(iout,*) 'In EELEC'
3518 cd      do i=1,nloctyp
3519 cd        write(iout,*) 'Type',i
3520 cd        write(iout,*) 'B1',B1(:,i)
3521 cd        write(iout,*) 'B2',B2(:,i)
3522 cd        write(iout,*) 'CC',CC(:,:,i)
3523 cd        write(iout,*) 'DD',DD(:,:,i)
3524 cd        write(iout,*) 'EE',EE(:,:,i)
3525 cd      enddo
3526 cd      call check_vecgrad
3527 cd      stop
3528       if (icheckgrad.eq.1) then
3529         do i=1,nres-1
3530           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3531           do k=1,3
3532             dc_norm(k,i)=dc(k,i)*fac
3533           enddo
3534 c          write (iout,*) 'i',i,' fac',fac
3535         enddo
3536       endif
3537       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3538      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3539      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3540 c        call vec_and_deriv
3541 #ifdef TIMING
3542         time01=MPI_Wtime()
3543 #endif
3544         call set_matrices
3545 #ifdef TIMING
3546         time_mat=time_mat+MPI_Wtime()-time01
3547 #endif
3548       endif
3549 cd      do i=1,nres-1
3550 cd        write (iout,*) 'i=',i
3551 cd        do k=1,3
3552 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3553 cd        enddo
3554 cd        do k=1,3
3555 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3556 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3557 cd        enddo
3558 cd      enddo
3559       t_eelecij=0.0d0
3560       ees=0.0D0
3561       evdw1=0.0D0
3562       eel_loc=0.0d0
3563       eello_turn3=0.0d0
3564       eello_turn4=0.0d0
3565       ind=0
3566       do i=1,nres
3567         num_cont_hb(i)=0
3568       enddo
3569 cd      print '(a)','Enter EELEC'
3570 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3571       do i=1,nres
3572         gel_loc_loc(i)=0.0d0
3573         gcorr_loc(i)=0.0d0
3574       enddo
3575 c
3576 c
3577 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3578 C
3579 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3580 C
3581 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3582       do i=iturn3_start,iturn3_end
3583 c        if (i.le.1) cycle
3584 C        write(iout,*) "tu jest i",i
3585         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3586 C changes suggested by Ana to avoid out of bounds
3587 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3588 c     & .or.((i+4).gt.nres)
3589 c     & .or.((i-1).le.0)
3590 C end of changes by Ana
3591 C dobra zmiana wycofana
3592      &  .or. itype(i+2).eq.ntyp1
3593      &  .or. itype(i+3).eq.ntyp1) cycle
3594 C Adam: Instructions below will switch off existing interactions
3595 c        if(i.gt.1)then
3596 c          if(itype(i-1).eq.ntyp1)cycle
3597 c        end if
3598 c        if(i.LT.nres-3)then
3599 c          if (itype(i+4).eq.ntyp1) cycle
3600 c        end if
3601         dxi=dc(1,i)
3602         dyi=dc(2,i)
3603         dzi=dc(3,i)
3604         dx_normi=dc_norm(1,i)
3605         dy_normi=dc_norm(2,i)
3606         dz_normi=dc_norm(3,i)
3607         xmedi=c(1,i)+0.5d0*dxi
3608         ymedi=c(2,i)+0.5d0*dyi
3609         zmedi=c(3,i)+0.5d0*dzi
3610           xmedi=mod(xmedi,boxxsize)
3611           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3612           ymedi=mod(ymedi,boxysize)
3613           if (ymedi.lt.0) ymedi=ymedi+boxysize
3614           zmedi=mod(zmedi,boxzsize)
3615           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3616         num_conti=0
3617         call eelecij(i,i+2,ees,evdw1,eel_loc)
3618         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3619         num_cont_hb(i)=num_conti
3620       enddo
3621       do i=iturn4_start,iturn4_end
3622         if (i.lt.1) cycle
3623         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3624 C changes suggested by Ana to avoid out of bounds
3625 c     & .or.((i+5).gt.nres)
3626 c     & .or.((i-1).le.0)
3627 C end of changes suggested by Ana
3628      &    .or. itype(i+3).eq.ntyp1
3629      &    .or. itype(i+4).eq.ntyp1
3630 c     &    .or. itype(i+5).eq.ntyp1
3631 c     &    .or. itype(i).eq.ntyp1
3632 c     &    .or. itype(i-1).eq.ntyp1
3633      &                             ) cycle
3634         dxi=dc(1,i)
3635         dyi=dc(2,i)
3636         dzi=dc(3,i)
3637         dx_normi=dc_norm(1,i)
3638         dy_normi=dc_norm(2,i)
3639         dz_normi=dc_norm(3,i)
3640         xmedi=c(1,i)+0.5d0*dxi
3641         ymedi=c(2,i)+0.5d0*dyi
3642         zmedi=c(3,i)+0.5d0*dzi
3643 C Return atom into box, boxxsize is size of box in x dimension
3644 c  194   continue
3645 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3646 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3647 C Condition for being inside the proper box
3648 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3649 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3650 c        go to 194
3651 c        endif
3652 c  195   continue
3653 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3654 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3655 C Condition for being inside the proper box
3656 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3657 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3658 c        go to 195
3659 c        endif
3660 c  196   continue
3661 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3662 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3663 C Condition for being inside the proper box
3664 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3665 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3666 c        go to 196
3667 c        endif
3668           xmedi=mod(xmedi,boxxsize)
3669           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3670           ymedi=mod(ymedi,boxysize)
3671           if (ymedi.lt.0) ymedi=ymedi+boxysize
3672           zmedi=mod(zmedi,boxzsize)
3673           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3674
3675         num_conti=num_cont_hb(i)
3676 c        write(iout,*) "JESTEM W PETLI"
3677         call eelecij(i,i+3,ees,evdw1,eel_loc)
3678         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3679      &   call eturn4(i,eello_turn4)
3680         num_cont_hb(i)=num_conti
3681       enddo   ! i
3682 C Loop over all neighbouring boxes
3683 C      do xshift=-1,1
3684 C      do yshift=-1,1
3685 C      do zshift=-1,1
3686 c
3687 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3688 c
3689 CTU KURWA
3690       do i=iatel_s,iatel_e
3691 C        do i=75,75
3692 c        if (i.le.1) cycle
3693         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3694 C changes suggested by Ana to avoid out of bounds
3695 c     & .or.((i+2).gt.nres)
3696 c     & .or.((i-1).le.0)
3697 C end of changes by Ana
3698 c     &  .or. itype(i+2).eq.ntyp1
3699 c     &  .or. itype(i-1).eq.ntyp1
3700      &                ) cycle
3701         dxi=dc(1,i)
3702         dyi=dc(2,i)
3703         dzi=dc(3,i)
3704         dx_normi=dc_norm(1,i)
3705         dy_normi=dc_norm(2,i)
3706         dz_normi=dc_norm(3,i)
3707         xmedi=c(1,i)+0.5d0*dxi
3708         ymedi=c(2,i)+0.5d0*dyi
3709         zmedi=c(3,i)+0.5d0*dzi
3710           xmedi=mod(xmedi,boxxsize)
3711           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3712           ymedi=mod(ymedi,boxysize)
3713           if (ymedi.lt.0) ymedi=ymedi+boxysize
3714           zmedi=mod(zmedi,boxzsize)
3715           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3716 C          xmedi=xmedi+xshift*boxxsize
3717 C          ymedi=ymedi+yshift*boxysize
3718 C          zmedi=zmedi+zshift*boxzsize
3719
3720 C Return tom into box, boxxsize is size of box in x dimension
3721 c  164   continue
3722 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3723 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3724 C Condition for being inside the proper box
3725 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3726 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3727 c        go to 164
3728 c        endif
3729 c  165   continue
3730 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3731 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3732 C Condition for being inside the proper box
3733 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3734 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3735 c        go to 165
3736 c        endif
3737 c  166   continue
3738 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3739 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3740 cC Condition for being inside the proper box
3741 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3742 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3743 c        go to 166
3744 c        endif
3745
3746 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3747         num_conti=num_cont_hb(i)
3748 C I TU KURWA
3749         do j=ielstart(i),ielend(i)
3750 C          do j=16,17
3751 C          write (iout,*) i,j
3752 C         if (j.le.1) cycle
3753           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3754 C changes suggested by Ana to avoid out of bounds
3755 c     & .or.((j+2).gt.nres)
3756 c     & .or.((j-1).le.0)
3757 C end of changes by Ana
3758 c     & .or.itype(j+2).eq.ntyp1
3759 c     & .or.itype(j-1).eq.ntyp1
3760      &) cycle
3761           call eelecij(i,j,ees,evdw1,eel_loc)
3762         enddo ! j
3763         num_cont_hb(i)=num_conti
3764       enddo   ! i
3765 C     enddo   ! zshift
3766 C      enddo   ! yshift
3767 C      enddo   ! xshift
3768
3769 c      write (iout,*) "Number of loop steps in EELEC:",ind
3770 cd      do i=1,nres
3771 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3772 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3773 cd      enddo
3774 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3775 ccc      eel_loc=eel_loc+eello_turn3
3776 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3777       return
3778       end
3779 C-------------------------------------------------------------------------------
3780       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3781       implicit real*8 (a-h,o-z)
3782       include 'DIMENSIONS'
3783       include 'DIMENSIONS.ZSCOPT'
3784 #ifdef MPI
3785       include "mpif.h"
3786 #endif
3787       include 'COMMON.CONTROL'
3788       include 'COMMON.IOUNITS'
3789       include 'COMMON.GEO'
3790       include 'COMMON.VAR'
3791       include 'COMMON.LOCAL'
3792       include 'COMMON.CHAIN'
3793       include 'COMMON.DERIV'
3794       include 'COMMON.INTERACT'
3795       include 'COMMON.CONTACTS'
3796       include 'COMMON.TORSION'
3797       include 'COMMON.VECTORS'
3798       include 'COMMON.FFIELD'
3799       include 'COMMON.TIME1'
3800       include 'COMMON.SPLITELE'
3801       include 'COMMON.SHIELD'
3802       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3803      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3804       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3805      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3806      &    gmuij2(4),gmuji2(4)
3807       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3808      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3809      &    num_conti,j1,j2
3810 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3811 #ifdef MOMENT
3812       double precision scal_el /1.0d0/
3813 #else
3814       double precision scal_el /0.5d0/
3815 #endif
3816 C 12/13/98
3817 C 13-go grudnia roku pamietnego...
3818       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3819      &                   0.0d0,1.0d0,0.0d0,
3820      &                   0.0d0,0.0d0,1.0d0/
3821        integer xshift,yshift,zshift
3822 c          time00=MPI_Wtime()
3823 cd      write (iout,*) "eelecij",i,j
3824 c          ind=ind+1
3825           iteli=itel(i)
3826           itelj=itel(j)
3827           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3828           aaa=app(iteli,itelj)
3829           bbb=bpp(iteli,itelj)
3830           ael6i=ael6(iteli,itelj)
3831           ael3i=ael3(iteli,itelj)
3832           dxj=dc(1,j)
3833           dyj=dc(2,j)
3834           dzj=dc(3,j)
3835           dx_normj=dc_norm(1,j)
3836           dy_normj=dc_norm(2,j)
3837           dz_normj=dc_norm(3,j)
3838 C          xj=c(1,j)+0.5D0*dxj-xmedi
3839 C          yj=c(2,j)+0.5D0*dyj-ymedi
3840 C          zj=c(3,j)+0.5D0*dzj-zmedi
3841           xj=c(1,j)+0.5D0*dxj
3842           yj=c(2,j)+0.5D0*dyj
3843           zj=c(3,j)+0.5D0*dzj
3844           xj=mod(xj,boxxsize)
3845           if (xj.lt.0) xj=xj+boxxsize
3846           yj=mod(yj,boxysize)
3847           if (yj.lt.0) yj=yj+boxysize
3848           zj=mod(zj,boxzsize)
3849           if (zj.lt.0) zj=zj+boxzsize
3850           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3851       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3852       xj_safe=xj
3853       yj_safe=yj
3854       zj_safe=zj
3855       isubchap=0
3856       do xshift=-1,1
3857       do yshift=-1,1
3858       do zshift=-1,1
3859           xj=xj_safe+xshift*boxxsize
3860           yj=yj_safe+yshift*boxysize
3861           zj=zj_safe+zshift*boxzsize
3862           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3863           if(dist_temp.lt.dist_init) then
3864             dist_init=dist_temp
3865             xj_temp=xj
3866             yj_temp=yj
3867             zj_temp=zj
3868             isubchap=1
3869           endif
3870        enddo
3871        enddo
3872        enddo
3873        if (isubchap.eq.1) then
3874           xj=xj_temp-xmedi
3875           yj=yj_temp-ymedi
3876           zj=zj_temp-zmedi
3877        else
3878           xj=xj_safe-xmedi
3879           yj=yj_safe-ymedi
3880           zj=zj_safe-zmedi
3881        endif
3882 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3883 c  174   continue
3884 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3885 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3886 C Condition for being inside the proper box
3887 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3888 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3889 c        go to 174
3890 c        endif
3891 c  175   continue
3892 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3893 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3894 C Condition for being inside the proper box
3895 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3896 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3897 c        go to 175
3898 c        endif
3899 c  176   continue
3900 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3901 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3902 C Condition for being inside the proper box
3903 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3904 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3905 c        go to 176
3906 c        endif
3907 C        endif !endPBC condintion
3908 C        xj=xj-xmedi
3909 C        yj=yj-ymedi
3910 C        zj=zj-zmedi
3911           rij=xj*xj+yj*yj+zj*zj
3912
3913             sss=sscale(sqrt(rij))
3914             sssgrad=sscagrad(sqrt(rij))
3915 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3916 c     &       " rlamb",rlamb," sss",sss
3917 c            if (sss.gt.0.0d0) then
3918           rrmij=1.0D0/rij
3919           rij=dsqrt(rij)
3920           rmij=1.0D0/rij
3921           r3ij=rrmij*rmij
3922           r6ij=r3ij*r3ij
3923           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3924           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3925           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3926           fac=cosa-3.0D0*cosb*cosg
3927           ev1=aaa*r6ij*r6ij
3928 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3929           if (j.eq.i+2) ev1=scal_el*ev1
3930           ev2=bbb*r6ij
3931           fac3=ael6i*r6ij
3932           fac4=ael3i*r3ij
3933           evdwij=(ev1+ev2)
3934           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3935           el2=fac4*fac
3936 C MARYSIA
3937 C          eesij=(el1+el2)
3938 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3939           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3940           if (shield_mode.gt.0) then
3941 C          fac_shield(i)=0.4
3942 C          fac_shield(j)=0.6
3943           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3944           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3945           eesij=(el1+el2)
3946           ees=ees+eesij
3947           else
3948           fac_shield(i)=1.0
3949           fac_shield(j)=1.0
3950           eesij=(el1+el2)
3951           ees=ees+eesij
3952           endif
3953           evdw1=evdw1+evdwij*sss
3954 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3955 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3956 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3957 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3958
3959           if (energy_dec) then
3960               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3961      &'evdw1',i,j,evdwij
3962      &,iteli,itelj,aaa,evdw1,sss
3963               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3964      &fac_shield(i),fac_shield(j)
3965           endif
3966
3967 C
3968 C Calculate contributions to the Cartesian gradient.
3969 C
3970 #ifdef SPLITELE
3971           facvdw=-6*rrmij*(ev1+evdwij)*sss
3972           facel=-3*rrmij*(el1+eesij)
3973           fac1=fac
3974           erij(1)=xj*rmij
3975           erij(2)=yj*rmij
3976           erij(3)=zj*rmij
3977
3978 *
3979 * Radial derivatives. First process both termini of the fragment (i,j)
3980 *
3981           if (calc_grad) then
3982           ggg(1)=facel*xj
3983           ggg(2)=facel*yj
3984           ggg(3)=facel*zj
3985           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3986      &  (shield_mode.gt.0)) then
3987 C          print *,i,j
3988           do ilist=1,ishield_list(i)
3989            iresshield=shield_list(ilist,i)
3990            do k=1,3
3991            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3992      &      *2.0
3993            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3994      &              rlocshield
3995      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3996             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3997 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3998 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3999 C             if (iresshield.gt.i) then
4000 C               do ishi=i+1,iresshield-1
4001 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4002 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4003 C
4004 C              enddo
4005 C             else
4006 C               do ishi=iresshield,i
4007 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4008 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4009 C
4010 C               enddo
4011 C              endif
4012            enddo
4013           enddo
4014           do ilist=1,ishield_list(j)
4015            iresshield=shield_list(ilist,j)
4016            do k=1,3
4017            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4018      &     *2.0
4019            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4020      &              rlocshield
4021      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4022            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4023
4024 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4025 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4026 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4027 C             if (iresshield.gt.j) then
4028 C               do ishi=j+1,iresshield-1
4029 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4030 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4031 C
4032 C               enddo
4033 C            else
4034 C               do ishi=iresshield,j
4035 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4036 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4037 C               enddo
4038 C              endif
4039            enddo
4040           enddo
4041
4042           do k=1,3
4043             gshieldc(k,i)=gshieldc(k,i)+
4044      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4045             gshieldc(k,j)=gshieldc(k,j)+
4046      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4047             gshieldc(k,i-1)=gshieldc(k,i-1)+
4048      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4049             gshieldc(k,j-1)=gshieldc(k,j-1)+
4050      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4051
4052            enddo
4053            endif
4054 c          do k=1,3
4055 c            ghalf=0.5D0*ggg(k)
4056 c            gelc(k,i)=gelc(k,i)+ghalf
4057 c            gelc(k,j)=gelc(k,j)+ghalf
4058 c          enddo
4059 c 9/28/08 AL Gradient compotents will be summed only at the end
4060 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4061           do k=1,3
4062             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4063 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4064             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4065 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4066 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4067 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4068 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4069 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4070           enddo
4071 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4072
4073 *
4074 * Loop over residues i+1 thru j-1.
4075 *
4076 cgrad          do k=i+1,j-1
4077 cgrad            do l=1,3
4078 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4079 cgrad            enddo
4080 cgrad          enddo
4081           if (sss.gt.0.0) then
4082           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4083           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4084           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4085           else
4086           ggg(1)=0.0
4087           ggg(2)=0.0
4088           ggg(3)=0.0
4089           endif
4090 c          do k=1,3
4091 c            ghalf=0.5D0*ggg(k)
4092 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4093 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4094 c          enddo
4095 c 9/28/08 AL Gradient compotents will be summed only at the end
4096           do k=1,3
4097             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4098             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4099           enddo
4100 *
4101 * Loop over residues i+1 thru j-1.
4102 *
4103 cgrad          do k=i+1,j-1
4104 cgrad            do l=1,3
4105 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4106 cgrad            enddo
4107 cgrad          enddo
4108           endif ! calc_grad
4109 #else
4110 C MARYSIA
4111           facvdw=(ev1+evdwij)*sss
4112           facel=(el1+eesij)
4113           fac1=fac
4114           fac=-3*rrmij*(facvdw+facvdw+facel)
4115           erij(1)=xj*rmij
4116           erij(2)=yj*rmij
4117           erij(3)=zj*rmij
4118 *
4119 * Radial derivatives. First process both termini of the fragment (i,j)
4120 *
4121           if (calc_grad) then
4122           ggg(1)=fac*xj
4123 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4124           ggg(2)=fac*yj
4125 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4126           ggg(3)=fac*zj
4127 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4128 c          do k=1,3
4129 c            ghalf=0.5D0*ggg(k)
4130 c            gelc(k,i)=gelc(k,i)+ghalf
4131 c            gelc(k,j)=gelc(k,j)+ghalf
4132 c          enddo
4133 c 9/28/08 AL Gradient compotents will be summed only at the end
4134           do k=1,3
4135             gelc_long(k,j)=gelc(k,j)+ggg(k)
4136             gelc_long(k,i)=gelc(k,i)-ggg(k)
4137           enddo
4138 *
4139 * Loop over residues i+1 thru j-1.
4140 *
4141 cgrad          do k=i+1,j-1
4142 cgrad            do l=1,3
4143 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4144 cgrad            enddo
4145 cgrad          enddo
4146 c 9/28/08 AL Gradient compotents will be summed only at the end
4147           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4148           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4149           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4150           do k=1,3
4151             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4152             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4153           enddo
4154           endif ! calc_grad
4155 #endif
4156 *
4157 * Angular part
4158 *
4159           if (calc_grad) then
4160           ecosa=2.0D0*fac3*fac1+fac4
4161           fac4=-3.0D0*fac4
4162           fac3=-6.0D0*fac3
4163           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4164           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4165           do k=1,3
4166             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4167             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4168           enddo
4169 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4170 cd   &          (dcosg(k),k=1,3)
4171           do k=1,3
4172             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4173      &      fac_shield(i)**2*fac_shield(j)**2
4174           enddo
4175 c          do k=1,3
4176 c            ghalf=0.5D0*ggg(k)
4177 c            gelc(k,i)=gelc(k,i)+ghalf
4178 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4179 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4180 c            gelc(k,j)=gelc(k,j)+ghalf
4181 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4182 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4183 c          enddo
4184 cgrad          do k=i+1,j-1
4185 cgrad            do l=1,3
4186 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4187 cgrad            enddo
4188 cgrad          enddo
4189 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4190           do k=1,3
4191             gelc(k,i)=gelc(k,i)
4192      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4193      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4194      &           *fac_shield(i)**2*fac_shield(j)**2
4195             gelc(k,j)=gelc(k,j)
4196      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4197      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4198      &           *fac_shield(i)**2*fac_shield(j)**2
4199             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4200             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4201           enddo
4202 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4203
4204 C MARYSIA
4205 c          endif !sscale
4206           endif ! calc_grad
4207           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4208      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4209      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4210 C
4211 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4212 C   energy of a peptide unit is assumed in the form of a second-order
4213 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4214 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4215 C   are computed for EVERY pair of non-contiguous peptide groups.
4216 C
4217
4218           if (j.lt.nres-1) then
4219             j1=j+1
4220             j2=j-1
4221           else
4222             j1=j-1
4223             j2=j-2
4224           endif
4225           kkk=0
4226           lll=0
4227           do k=1,2
4228             do l=1,2
4229               kkk=kkk+1
4230               muij(kkk)=mu(k,i)*mu(l,j)
4231 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4232 #ifdef NEWCORR
4233              if (calc_grad) then
4234              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4235 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4236              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4237              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4238 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4239              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4240              endif
4241 #endif
4242             enddo
4243           enddo
4244 #ifdef DEBUG
4245           write (iout,*) 'EELEC: i',i,' j',j
4246           write (iout,*) 'j',j,' j1',j1,' j2',j2
4247           write(iout,*) 'muij',muij
4248           write (iout,*) "uy",uy(:,i)
4249           write (iout,*) "uz",uz(:,j)
4250           write (iout,*) "erij",erij
4251 #endif
4252           ury=scalar(uy(1,i),erij)
4253           urz=scalar(uz(1,i),erij)
4254           vry=scalar(uy(1,j),erij)
4255           vrz=scalar(uz(1,j),erij)
4256           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4257           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4258           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4259           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4260           fac=dsqrt(-ael6i)*r3ij
4261           a22=a22*fac
4262           a23=a23*fac
4263           a32=a32*fac
4264           a33=a33*fac
4265 cd          write (iout,'(4i5,4f10.5)')
4266 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4267 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4268 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4269 cd     &      uy(:,j),uz(:,j)
4270 cd          write (iout,'(4f10.5)')
4271 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4272 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4273 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4274 cd           write (iout,'(9f10.5/)')
4275 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4276 C Derivatives of the elements of A in virtual-bond vectors
4277           if (calc_grad) then
4278           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4279           do k=1,3
4280             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4281             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4282             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4283             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4284             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4285             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4286             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4287             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4288             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4289             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4290             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4291             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4292           enddo
4293 C Compute radial contributions to the gradient
4294           facr=-3.0d0*rrmij
4295           a22der=a22*facr
4296           a23der=a23*facr
4297           a32der=a32*facr
4298           a33der=a33*facr
4299           agg(1,1)=a22der*xj
4300           agg(2,1)=a22der*yj
4301           agg(3,1)=a22der*zj
4302           agg(1,2)=a23der*xj
4303           agg(2,2)=a23der*yj
4304           agg(3,2)=a23der*zj
4305           agg(1,3)=a32der*xj
4306           agg(2,3)=a32der*yj
4307           agg(3,3)=a32der*zj
4308           agg(1,4)=a33der*xj
4309           agg(2,4)=a33der*yj
4310           agg(3,4)=a33der*zj
4311 C Add the contributions coming from er
4312           fac3=-3.0d0*fac
4313           do k=1,3
4314             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4315             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4316             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4317             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4318           enddo
4319           do k=1,3
4320 C Derivatives in DC(i)
4321 cgrad            ghalf1=0.5d0*agg(k,1)
4322 cgrad            ghalf2=0.5d0*agg(k,2)
4323 cgrad            ghalf3=0.5d0*agg(k,3)
4324 cgrad            ghalf4=0.5d0*agg(k,4)
4325             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4326      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4327             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4328      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4329             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4330      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4331             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4332      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4333 C Derivatives in DC(i+1)
4334             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4335      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4336             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4337      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4338             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4339      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4340             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4341      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4342 C Derivatives in DC(j)
4343             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4344      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4345             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4346      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4347             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4348      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4349             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4350      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4351 C Derivatives in DC(j+1) or DC(nres-1)
4352             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4353      &      -3.0d0*vryg(k,3)*ury)
4354             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4355      &      -3.0d0*vrzg(k,3)*ury)
4356             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4357      &      -3.0d0*vryg(k,3)*urz)
4358             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4359      &      -3.0d0*vrzg(k,3)*urz)
4360 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4361 cgrad              do l=1,4
4362 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4363 cgrad              enddo
4364 cgrad            endif
4365           enddo
4366           endif ! calc_grad
4367           acipa(1,1)=a22
4368           acipa(1,2)=a23
4369           acipa(2,1)=a32
4370           acipa(2,2)=a33
4371           a22=-a22
4372           a23=-a23
4373           if (calc_grad) then
4374           do l=1,2
4375             do k=1,3
4376               agg(k,l)=-agg(k,l)
4377               aggi(k,l)=-aggi(k,l)
4378               aggi1(k,l)=-aggi1(k,l)
4379               aggj(k,l)=-aggj(k,l)
4380               aggj1(k,l)=-aggj1(k,l)
4381             enddo
4382           enddo
4383           endif ! calc_grad
4384           if (j.lt.nres-1) then
4385             a22=-a22
4386             a32=-a32
4387             do l=1,3,2
4388               do k=1,3
4389                 agg(k,l)=-agg(k,l)
4390                 aggi(k,l)=-aggi(k,l)
4391                 aggi1(k,l)=-aggi1(k,l)
4392                 aggj(k,l)=-aggj(k,l)
4393                 aggj1(k,l)=-aggj1(k,l)
4394               enddo
4395             enddo
4396           else
4397             a22=-a22
4398             a23=-a23
4399             a32=-a32
4400             a33=-a33
4401             do l=1,4
4402               do k=1,3
4403                 agg(k,l)=-agg(k,l)
4404                 aggi(k,l)=-aggi(k,l)
4405                 aggi1(k,l)=-aggi1(k,l)
4406                 aggj(k,l)=-aggj(k,l)
4407                 aggj1(k,l)=-aggj1(k,l)
4408               enddo
4409             enddo
4410           endif
4411           ENDIF ! WCORR
4412           IF (wel_loc.gt.0.0d0) THEN
4413 C Contribution to the local-electrostatic energy coming from the i-j pair
4414           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4415      &     +a33*muij(4)
4416 #ifdef DEBUG
4417           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4418      &     " a33",a33
4419           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4420      &     " wel_loc",wel_loc
4421 #endif
4422           if (shield_mode.eq.0) then
4423            fac_shield(i)=1.0
4424            fac_shield(j)=1.0
4425 C          else
4426 C           fac_shield(i)=0.4
4427 C           fac_shield(j)=0.6
4428           endif
4429           eel_loc_ij=eel_loc_ij
4430      &    *fac_shield(i)*fac_shield(j)
4431           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4432      &            'eelloc',i,j,eel_loc_ij
4433 c           if (eel_loc_ij.ne.0)
4434 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4435 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4436
4437           eel_loc=eel_loc+eel_loc_ij
4438 C Now derivative over eel_loc
4439           if (calc_grad) then
4440           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4441      &  (shield_mode.gt.0)) then
4442 C          print *,i,j
4443
4444           do ilist=1,ishield_list(i)
4445            iresshield=shield_list(ilist,i)
4446            do k=1,3
4447            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4448      &                                          /fac_shield(i)
4449 C     &      *2.0
4450            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4451      &              rlocshield
4452      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4453             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4454      &      +rlocshield
4455            enddo
4456           enddo
4457           do ilist=1,ishield_list(j)
4458            iresshield=shield_list(ilist,j)
4459            do k=1,3
4460            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4461      &                                       /fac_shield(j)
4462 C     &     *2.0
4463            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4464      &              rlocshield
4465      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4466            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4467      &             +rlocshield
4468
4469            enddo
4470           enddo
4471
4472           do k=1,3
4473             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4474      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4475             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4476      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4477             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4478      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4479             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4480      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4481            enddo
4482            endif
4483
4484
4485 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4486 c     &                     ' eel_loc_ij',eel_loc_ij
4487 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4488 C Calculate patrial derivative for theta angle
4489 #ifdef NEWCORR
4490          geel_loc_ij=(a22*gmuij1(1)
4491      &     +a23*gmuij1(2)
4492      &     +a32*gmuij1(3)
4493      &     +a33*gmuij1(4))
4494      &    *fac_shield(i)*fac_shield(j)
4495 c         write(iout,*) "derivative over thatai"
4496 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4497 c     &   a33*gmuij1(4)
4498          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4499      &      geel_loc_ij*wel_loc
4500 c         write(iout,*) "derivative over thatai-1"
4501 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4502 c     &   a33*gmuij2(4)
4503          geel_loc_ij=
4504      &     a22*gmuij2(1)
4505      &     +a23*gmuij2(2)
4506      &     +a32*gmuij2(3)
4507      &     +a33*gmuij2(4)
4508          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4509      &      geel_loc_ij*wel_loc
4510      &    *fac_shield(i)*fac_shield(j)
4511
4512 c  Derivative over j residue
4513          geel_loc_ji=a22*gmuji1(1)
4514      &     +a23*gmuji1(2)
4515      &     +a32*gmuji1(3)
4516      &     +a33*gmuji1(4)
4517 c         write(iout,*) "derivative over thataj"
4518 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4519 c     &   a33*gmuji1(4)
4520
4521         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4522      &      geel_loc_ji*wel_loc
4523      &    *fac_shield(i)*fac_shield(j)
4524
4525          geel_loc_ji=
4526      &     +a22*gmuji2(1)
4527      &     +a23*gmuji2(2)
4528      &     +a32*gmuji2(3)
4529      &     +a33*gmuji2(4)
4530 c         write(iout,*) "derivative over thataj-1"
4531 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4532 c     &   a33*gmuji2(4)
4533          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4534      &      geel_loc_ji*wel_loc
4535      &    *fac_shield(i)*fac_shield(j)
4536 #endif
4537 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4538
4539 C Partial derivatives in virtual-bond dihedral angles gamma
4540           if (i.gt.1)
4541      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4542      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4543      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4544      &    *fac_shield(i)*fac_shield(j)
4545
4546           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4547      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4548      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4549      &    *fac_shield(i)*fac_shield(j)
4550 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4551           do l=1,3
4552             ggg(l)=(agg(l,1)*muij(1)+
4553      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4554      &    *fac_shield(i)*fac_shield(j)
4555             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4556             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4557 cgrad            ghalf=0.5d0*ggg(l)
4558 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4559 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4560           enddo
4561 cgrad          do k=i+1,j2
4562 cgrad            do l=1,3
4563 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4564 cgrad            enddo
4565 cgrad          enddo
4566 C Remaining derivatives of eello
4567           do l=1,3
4568             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4569      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4570      &    *fac_shield(i)*fac_shield(j)
4571
4572             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4573      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4574      &    *fac_shield(i)*fac_shield(j)
4575
4576             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4577      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4578      &    *fac_shield(i)*fac_shield(j)
4579
4580             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4581      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4582      &    *fac_shield(i)*fac_shield(j)
4583
4584           enddo
4585           endif ! calc_grad
4586           ENDIF
4587
4588
4589 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4590 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4591           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4592      &       .and. num_conti.le.maxconts) then
4593 c            write (iout,*) i,j," entered corr"
4594 C
4595 C Calculate the contact function. The ith column of the array JCONT will
4596 C contain the numbers of atoms that make contacts with the atom I (of numbers
4597 C greater than I). The arrays FACONT and GACONT will contain the values of
4598 C the contact function and its derivative.
4599 c           r0ij=1.02D0*rpp(iteli,itelj)
4600 c           r0ij=1.11D0*rpp(iteli,itelj)
4601             r0ij=2.20D0*rpp(iteli,itelj)
4602 c           r0ij=1.55D0*rpp(iteli,itelj)
4603             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4604             if (fcont.gt.0.0D0) then
4605               num_conti=num_conti+1
4606               if (num_conti.gt.maxconts) then
4607                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4608      &                         ' will skip next contacts for this conf.'
4609               else
4610                 jcont_hb(num_conti,i)=j
4611 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4612 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4613                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4614      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4615 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4616 C  terms.
4617                 d_cont(num_conti,i)=rij
4618 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4619 C     --- Electrostatic-interaction matrix ---
4620                 a_chuj(1,1,num_conti,i)=a22
4621                 a_chuj(1,2,num_conti,i)=a23
4622                 a_chuj(2,1,num_conti,i)=a32
4623                 a_chuj(2,2,num_conti,i)=a33
4624 C     --- Gradient of rij
4625                 if (calc_grad) then
4626                 do kkk=1,3
4627                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4628                 enddo
4629                 kkll=0
4630                 do k=1,2
4631                   do l=1,2
4632                     kkll=kkll+1
4633                     do m=1,3
4634                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4635                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4636                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4637                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4638                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4639                     enddo
4640                   enddo
4641                 enddo
4642                 endif ! calc_grad
4643                 ENDIF
4644                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4645 C Calculate contact energies
4646                 cosa4=4.0D0*cosa
4647                 wij=cosa-3.0D0*cosb*cosg
4648                 cosbg1=cosb+cosg
4649                 cosbg2=cosb-cosg
4650 c               fac3=dsqrt(-ael6i)/r0ij**3
4651                 fac3=dsqrt(-ael6i)*r3ij
4652 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4653                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4654                 if (ees0tmp.gt.0) then
4655                   ees0pij=dsqrt(ees0tmp)
4656                 else
4657                   ees0pij=0
4658                 endif
4659 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4660                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4661                 if (ees0tmp.gt.0) then
4662                   ees0mij=dsqrt(ees0tmp)
4663                 else
4664                   ees0mij=0
4665                 endif
4666 c               ees0mij=0.0D0
4667                 if (shield_mode.eq.0) then
4668                 fac_shield(i)=1.0d0
4669                 fac_shield(j)=1.0d0
4670                 else
4671                 ees0plist(num_conti,i)=j
4672 C                fac_shield(i)=0.4d0
4673 C                fac_shield(j)=0.6d0
4674                 endif
4675                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4676      &          *fac_shield(i)*fac_shield(j)
4677                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4678      &          *fac_shield(i)*fac_shield(j)
4679 C Diagnostics. Comment out or remove after debugging!
4680 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4681 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4682 c               ees0m(num_conti,i)=0.0D0
4683 C End diagnostics.
4684 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4685 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4686 C Angular derivatives of the contact function
4687
4688                 ees0pij1=fac3/ees0pij
4689                 ees0mij1=fac3/ees0mij
4690                 fac3p=-3.0D0*fac3*rrmij
4691                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4692                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4693 c               ees0mij1=0.0D0
4694                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4695                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4696                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4697                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4698                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4699                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4700                 ecosap=ecosa1+ecosa2
4701                 ecosbp=ecosb1+ecosb2
4702                 ecosgp=ecosg1+ecosg2
4703                 ecosam=ecosa1-ecosa2
4704                 ecosbm=ecosb1-ecosb2
4705                 ecosgm=ecosg1-ecosg2
4706 C Diagnostics
4707 c               ecosap=ecosa1
4708 c               ecosbp=ecosb1
4709 c               ecosgp=ecosg1
4710 c               ecosam=0.0D0
4711 c               ecosbm=0.0D0
4712 c               ecosgm=0.0D0
4713 C End diagnostics
4714                 facont_hb(num_conti,i)=fcont
4715
4716                 if (calc_grad) then
4717                 fprimcont=fprimcont/rij
4718 cd              facont_hb(num_conti,i)=1.0D0
4719 C Following line is for diagnostics.
4720 cd              fprimcont=0.0D0
4721                 do k=1,3
4722                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4723                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4724                 enddo
4725                 do k=1,3
4726                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4727                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4728                 enddo
4729                 gggp(1)=gggp(1)+ees0pijp*xj
4730                 gggp(2)=gggp(2)+ees0pijp*yj
4731                 gggp(3)=gggp(3)+ees0pijp*zj
4732                 gggm(1)=gggm(1)+ees0mijp*xj
4733                 gggm(2)=gggm(2)+ees0mijp*yj
4734                 gggm(3)=gggm(3)+ees0mijp*zj
4735 C Derivatives due to the contact function
4736                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4737                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4738                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4739                 do k=1,3
4740 c
4741 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4742 c          following the change of gradient-summation algorithm.
4743 c
4744 cgrad                  ghalfp=0.5D0*gggp(k)
4745 cgrad                  ghalfm=0.5D0*gggm(k)
4746                   gacontp_hb1(k,num_conti,i)=!ghalfp
4747      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4748      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4749      &          *fac_shield(i)*fac_shield(j)
4750
4751                   gacontp_hb2(k,num_conti,i)=!ghalfp
4752      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4753      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4754      &          *fac_shield(i)*fac_shield(j)
4755
4756                   gacontp_hb3(k,num_conti,i)=gggp(k)
4757      &          *fac_shield(i)*fac_shield(j)
4758
4759                   gacontm_hb1(k,num_conti,i)=!ghalfm
4760      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4761      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4762      &          *fac_shield(i)*fac_shield(j)
4763
4764                   gacontm_hb2(k,num_conti,i)=!ghalfm
4765      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4766      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4767      &          *fac_shield(i)*fac_shield(j)
4768
4769                   gacontm_hb3(k,num_conti,i)=gggm(k)
4770      &          *fac_shield(i)*fac_shield(j)
4771
4772                 enddo
4773 C Diagnostics. Comment out or remove after debugging!
4774 cdiag           do k=1,3
4775 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4776 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4777 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4778 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4779 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4780 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4781 cdiag           enddo
4782
4783                  endif ! calc_grad
4784
4785               ENDIF ! wcorr
4786               endif  ! num_conti.le.maxconts
4787             endif  ! fcont.gt.0
4788           endif    ! j.gt.i+1
4789           if (calc_grad) then
4790           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4791             do k=1,4
4792               do l=1,3
4793                 ghalf=0.5d0*agg(l,k)
4794                 aggi(l,k)=aggi(l,k)+ghalf
4795                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4796                 aggj(l,k)=aggj(l,k)+ghalf
4797               enddo
4798             enddo
4799             if (j.eq.nres-1 .and. i.lt.j-2) then
4800               do k=1,4
4801                 do l=1,3
4802                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4803                 enddo
4804               enddo
4805             endif
4806           endif
4807           endif ! calc_grad
4808 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4809       return
4810       end
4811 C-----------------------------------------------------------------------------
4812       subroutine eturn3(i,eello_turn3)
4813 C Third- and fourth-order contributions from turns
4814       implicit real*8 (a-h,o-z)
4815       include 'DIMENSIONS'
4816       include 'DIMENSIONS.ZSCOPT'
4817       include 'COMMON.IOUNITS'
4818       include 'COMMON.GEO'
4819       include 'COMMON.VAR'
4820       include 'COMMON.LOCAL'
4821       include 'COMMON.CHAIN'
4822       include 'COMMON.DERIV'
4823       include 'COMMON.INTERACT'
4824       include 'COMMON.CONTACTS'
4825       include 'COMMON.TORSION'
4826       include 'COMMON.VECTORS'
4827       include 'COMMON.FFIELD'
4828       include 'COMMON.CONTROL'
4829       include 'COMMON.SHIELD'
4830       dimension ggg(3)
4831       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4832      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4833      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4834      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4835      &  auxgmat2(2,2),auxgmatt2(2,2)
4836       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4837      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4838       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4839      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4840      &    num_conti,j1,j2
4841       j=i+2
4842 c      write (iout,*) "eturn3",i,j,j1,j2
4843       a_temp(1,1)=a22
4844       a_temp(1,2)=a23
4845       a_temp(2,1)=a32
4846       a_temp(2,2)=a33
4847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4848 C
4849 C               Third-order contributions
4850 C
4851 C                 (i+2)o----(i+3)
4852 C                      | |
4853 C                      | |
4854 C                 (i+1)o----i
4855 C
4856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4857 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4858         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4859 c auxalary matices for theta gradient
4860 c auxalary matrix for i+1 and constant i+2
4861         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4862 c auxalary matrix for i+2 and constant i+1
4863         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4864         call transpose2(auxmat(1,1),auxmat1(1,1))
4865         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4866         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4867         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4868         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4869         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4870         if (shield_mode.eq.0) then
4871         fac_shield(i)=1.0
4872         fac_shield(j)=1.0
4873 C        else
4874 C        fac_shield(i)=0.4
4875 C        fac_shield(j)=0.6
4876         endif
4877         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4878      &  *fac_shield(i)*fac_shield(j)
4879         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4880      &  *fac_shield(i)*fac_shield(j)
4881         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4882      &    eello_t3
4883         if (calc_grad) then
4884 C#ifdef NEWCORR
4885 C Derivatives in theta
4886         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4887      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4888      &   *fac_shield(i)*fac_shield(j)
4889         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4890      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4891      &   *fac_shield(i)*fac_shield(j)
4892 C#endif
4893
4894 C Derivatives in shield mode
4895           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4896      &  (shield_mode.gt.0)) then
4897 C          print *,i,j
4898
4899           do ilist=1,ishield_list(i)
4900            iresshield=shield_list(ilist,i)
4901            do k=1,3
4902            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4903 C     &      *2.0
4904            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4905      &              rlocshield
4906      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4907             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4908      &      +rlocshield
4909            enddo
4910           enddo
4911           do ilist=1,ishield_list(j)
4912            iresshield=shield_list(ilist,j)
4913            do k=1,3
4914            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4915 C     &     *2.0
4916            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4917      &              rlocshield
4918      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4919            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4920      &             +rlocshield
4921
4922            enddo
4923           enddo
4924
4925           do k=1,3
4926             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4927      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4928             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4929      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4930             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4931      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4932             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4933      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4934            enddo
4935            endif
4936
4937 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4938 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4939 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4940 cd     &    ' eello_turn3_num',4*eello_turn3_num
4941 C Derivatives in gamma(i)
4942         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4943         call transpose2(auxmat2(1,1),auxmat3(1,1))
4944         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4945         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4946      &   *fac_shield(i)*fac_shield(j)
4947 C Derivatives in gamma(i+1)
4948         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4949         call transpose2(auxmat2(1,1),auxmat3(1,1))
4950         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4951         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4952      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4953      &   *fac_shield(i)*fac_shield(j)
4954 C Cartesian derivatives
4955         do l=1,3
4956 c            ghalf1=0.5d0*agg(l,1)
4957 c            ghalf2=0.5d0*agg(l,2)
4958 c            ghalf3=0.5d0*agg(l,3)
4959 c            ghalf4=0.5d0*agg(l,4)
4960           a_temp(1,1)=aggi(l,1)!+ghalf1
4961           a_temp(1,2)=aggi(l,2)!+ghalf2
4962           a_temp(2,1)=aggi(l,3)!+ghalf3
4963           a_temp(2,2)=aggi(l,4)!+ghalf4
4964           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4965           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4966      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4967      &   *fac_shield(i)*fac_shield(j)
4968
4969           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4970           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4971           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4972           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4973           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4974           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4975      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4976      &   *fac_shield(i)*fac_shield(j)
4977           a_temp(1,1)=aggj(l,1)!+ghalf1
4978           a_temp(1,2)=aggj(l,2)!+ghalf2
4979           a_temp(2,1)=aggj(l,3)!+ghalf3
4980           a_temp(2,2)=aggj(l,4)!+ghalf4
4981           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4982           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4983      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4984      &   *fac_shield(i)*fac_shield(j)
4985           a_temp(1,1)=aggj1(l,1)
4986           a_temp(1,2)=aggj1(l,2)
4987           a_temp(2,1)=aggj1(l,3)
4988           a_temp(2,2)=aggj1(l,4)
4989           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4990           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4991      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4992      &   *fac_shield(i)*fac_shield(j)
4993         enddo
4994
4995         endif ! calc_grad
4996
4997       return
4998       end
4999 C-------------------------------------------------------------------------------
5000       subroutine eturn4(i,eello_turn4)
5001 C Third- and fourth-order contributions from turns
5002       implicit real*8 (a-h,o-z)
5003       include 'DIMENSIONS'
5004       include 'DIMENSIONS.ZSCOPT'
5005       include 'COMMON.IOUNITS'
5006       include 'COMMON.GEO'
5007       include 'COMMON.VAR'
5008       include 'COMMON.LOCAL'
5009       include 'COMMON.CHAIN'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.INTERACT'
5012       include 'COMMON.CONTACTS'
5013       include 'COMMON.TORSION'
5014       include 'COMMON.VECTORS'
5015       include 'COMMON.FFIELD'
5016       include 'COMMON.CONTROL'
5017       include 'COMMON.SHIELD'
5018       dimension ggg(3)
5019       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5020      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5021      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5022      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5023      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5024      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5025      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5026       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5027      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5028       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5029      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5030      &    num_conti,j1,j2
5031       j=i+3
5032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5033 C
5034 C               Fourth-order contributions
5035 C
5036 C                 (i+3)o----(i+4)
5037 C                     /  |
5038 C               (i+2)o   |
5039 C                     \  |
5040 C                 (i+1)o----i
5041 C
5042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5043 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5044 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5045 c        write(iout,*)"WCHODZE W PROGRAM"
5046         a_temp(1,1)=a22
5047         a_temp(1,2)=a23
5048         a_temp(2,1)=a32
5049         a_temp(2,2)=a33
5050         iti1=itype2loc(itype(i+1))
5051         iti2=itype2loc(itype(i+2))
5052         iti3=itype2loc(itype(i+3))
5053 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5054         call transpose2(EUg(1,1,i+1),e1t(1,1))
5055         call transpose2(Eug(1,1,i+2),e2t(1,1))
5056         call transpose2(Eug(1,1,i+3),e3t(1,1))
5057 C Ematrix derivative in theta
5058         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5059         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5060         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5061         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5062 c       eta1 in derivative theta
5063         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5064         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5065 c       auxgvec is derivative of Ub2 so i+3 theta
5066         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5067 c       auxalary matrix of E i+1
5068         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5069 c        s1=0.0
5070 c        gs1=0.0
5071         s1=scalar2(b1(1,i+2),auxvec(1))
5072 c derivative of theta i+2 with constant i+3
5073         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5074 c derivative of theta i+2 with constant i+2
5075         gs32=scalar2(b1(1,i+2),auxgvec(1))
5076 c derivative of E matix in theta of i+1
5077         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5078
5079         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5080 c       ea31 in derivative theta
5081         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5082         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5083 c auxilary matrix auxgvec of Ub2 with constant E matirx
5084         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5085 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5086         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5087
5088 c        s2=0.0
5089 c        gs2=0.0
5090         s2=scalar2(b1(1,i+1),auxvec(1))
5091 c derivative of theta i+1 with constant i+3
5092         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5093 c derivative of theta i+2 with constant i+1
5094         gs21=scalar2(b1(1,i+1),auxgvec(1))
5095 c derivative of theta i+3 with constant i+1
5096         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5097 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5098 c     &  gtb1(1,i+1)
5099         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5100 c two derivatives over diffetent matrices
5101 c gtae3e2 is derivative over i+3
5102         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5103 c ae3gte2 is derivative over i+2
5104         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5105         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5106 c three possible derivative over theta E matices
5107 c i+1
5108         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5109 c i+2
5110         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5111 c i+3
5112         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5113         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5114
5115         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5116         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5117         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5118         if (shield_mode.eq.0) then
5119         fac_shield(i)=1.0
5120         fac_shield(j)=1.0
5121 C        else
5122 C        fac_shield(i)=0.6
5123 C        fac_shield(j)=0.4
5124         endif
5125         eello_turn4=eello_turn4-(s1+s2+s3)
5126      &  *fac_shield(i)*fac_shield(j)
5127         eello_t4=-(s1+s2+s3)
5128      &  *fac_shield(i)*fac_shield(j)
5129 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5130         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5131      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5132 C Now derivative over shield:
5133           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5134      &  (shield_mode.gt.0)) then
5135 C          print *,i,j
5136
5137           do ilist=1,ishield_list(i)
5138            iresshield=shield_list(ilist,i)
5139            do k=1,3
5140            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5141 C     &      *2.0
5142            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5143      &              rlocshield
5144      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5145             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5146      &      +rlocshield
5147            enddo
5148           enddo
5149           do ilist=1,ishield_list(j)
5150            iresshield=shield_list(ilist,j)
5151            do k=1,3
5152            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5153 C     &     *2.0
5154            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5155      &              rlocshield
5156      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5157            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5158      &             +rlocshield
5159
5160            enddo
5161           enddo
5162
5163           do k=1,3
5164             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5165      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5166             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5167      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5168             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5169      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5170             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5171      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5172            enddo
5173            endif
5174 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5175 cd     &    ' eello_turn4_num',8*eello_turn4_num
5176 #ifdef NEWCORR
5177         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5178      &                  -(gs13+gsE13+gsEE1)*wturn4
5179      &  *fac_shield(i)*fac_shield(j)
5180         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5181      &                    -(gs23+gs21+gsEE2)*wturn4
5182      &  *fac_shield(i)*fac_shield(j)
5183
5184         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5185      &                    -(gs32+gsE31+gsEE3)*wturn4
5186      &  *fac_shield(i)*fac_shield(j)
5187
5188 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5189 c     &   gs2
5190 #endif
5191         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5192      &      'eturn4',i,j,-(s1+s2+s3)
5193 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5194 c     &    ' eello_turn4_num',8*eello_turn4_num
5195 C Derivatives in gamma(i)
5196         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5197         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5198         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5199         s1=scalar2(b1(1,i+2),auxvec(1))
5200         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5201         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5202         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5203      &  *fac_shield(i)*fac_shield(j)
5204 C Derivatives in gamma(i+1)
5205         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5206         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5207         s2=scalar2(b1(1,i+1),auxvec(1))
5208         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5209         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5210         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5211         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5212      &  *fac_shield(i)*fac_shield(j)
5213 C Derivatives in gamma(i+2)
5214         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5215         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5216         s1=scalar2(b1(1,i+2),auxvec(1))
5217         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5218         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5219         s2=scalar2(b1(1,i+1),auxvec(1))
5220         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5221         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5222         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5223         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5224      &  *fac_shield(i)*fac_shield(j)
5225         if (calc_grad) then
5226 C Cartesian derivatives
5227 C Derivatives of this turn contributions in DC(i+2)
5228         if (j.lt.nres-1) then
5229           do l=1,3
5230             a_temp(1,1)=agg(l,1)
5231             a_temp(1,2)=agg(l,2)
5232             a_temp(2,1)=agg(l,3)
5233             a_temp(2,2)=agg(l,4)
5234             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5235             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5236             s1=scalar2(b1(1,i+2),auxvec(1))
5237             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5238             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5239             s2=scalar2(b1(1,i+1),auxvec(1))
5240             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5241             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5242             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5243             ggg(l)=-(s1+s2+s3)
5244             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5245      &  *fac_shield(i)*fac_shield(j)
5246           enddo
5247         endif
5248 C Remaining derivatives of this turn contribution
5249         do l=1,3
5250           a_temp(1,1)=aggi(l,1)
5251           a_temp(1,2)=aggi(l,2)
5252           a_temp(2,1)=aggi(l,3)
5253           a_temp(2,2)=aggi(l,4)
5254           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5255           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5256           s1=scalar2(b1(1,i+2),auxvec(1))
5257           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5258           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5259           s2=scalar2(b1(1,i+1),auxvec(1))
5260           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5261           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5262           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5263           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5264      &  *fac_shield(i)*fac_shield(j)
5265           a_temp(1,1)=aggi1(l,1)
5266           a_temp(1,2)=aggi1(l,2)
5267           a_temp(2,1)=aggi1(l,3)
5268           a_temp(2,2)=aggi1(l,4)
5269           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5270           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5271           s1=scalar2(b1(1,i+2),auxvec(1))
5272           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5273           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5274           s2=scalar2(b1(1,i+1),auxvec(1))
5275           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5276           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5277           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5278           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5279      &  *fac_shield(i)*fac_shield(j)
5280           a_temp(1,1)=aggj(l,1)
5281           a_temp(1,2)=aggj(l,2)
5282           a_temp(2,1)=aggj(l,3)
5283           a_temp(2,2)=aggj(l,4)
5284           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5285           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5286           s1=scalar2(b1(1,i+2),auxvec(1))
5287           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5288           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5289           s2=scalar2(b1(1,i+1),auxvec(1))
5290           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5291           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5292           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5293           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5294      &  *fac_shield(i)*fac_shield(j)
5295           a_temp(1,1)=aggj1(l,1)
5296           a_temp(1,2)=aggj1(l,2)
5297           a_temp(2,1)=aggj1(l,3)
5298           a_temp(2,2)=aggj1(l,4)
5299           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5300           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5301           s1=scalar2(b1(1,i+2),auxvec(1))
5302           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5303           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5304           s2=scalar2(b1(1,i+1),auxvec(1))
5305           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5306           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5307           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5308 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5309           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5310      &  *fac_shield(i)*fac_shield(j)
5311         enddo
5312
5313         endif ! calc_grad
5314
5315       return
5316       end
5317 C-----------------------------------------------------------------------------
5318       subroutine vecpr(u,v,w)
5319       implicit real*8(a-h,o-z)
5320       dimension u(3),v(3),w(3)
5321       w(1)=u(2)*v(3)-u(3)*v(2)
5322       w(2)=-u(1)*v(3)+u(3)*v(1)
5323       w(3)=u(1)*v(2)-u(2)*v(1)
5324       return
5325       end
5326 C-----------------------------------------------------------------------------
5327       subroutine unormderiv(u,ugrad,unorm,ungrad)
5328 C This subroutine computes the derivatives of a normalized vector u, given
5329 C the derivatives computed without normalization conditions, ugrad. Returns
5330 C ungrad.
5331       implicit none
5332       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5333       double precision vec(3)
5334       double precision scalar
5335       integer i,j
5336 c      write (2,*) 'ugrad',ugrad
5337 c      write (2,*) 'u',u
5338       do i=1,3
5339         vec(i)=scalar(ugrad(1,i),u(1))
5340       enddo
5341 c      write (2,*) 'vec',vec
5342       do i=1,3
5343         do j=1,3
5344           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5345         enddo
5346       enddo
5347 c      write (2,*) 'ungrad',ungrad
5348       return
5349       end
5350 C-----------------------------------------------------------------------------
5351       subroutine escp(evdw2,evdw2_14)
5352 C
5353 C This subroutine calculates the excluded-volume interaction energy between
5354 C peptide-group centers and side chains and its gradient in virtual-bond and
5355 C side-chain vectors.
5356 C
5357       implicit real*8 (a-h,o-z)
5358       include 'DIMENSIONS'
5359       include 'DIMENSIONS.ZSCOPT'
5360       include 'COMMON.GEO'
5361       include 'COMMON.VAR'
5362       include 'COMMON.LOCAL'
5363       include 'COMMON.CHAIN'
5364       include 'COMMON.DERIV'
5365       include 'COMMON.INTERACT'
5366       include 'COMMON.FFIELD'
5367       include 'COMMON.IOUNITS'
5368       dimension ggg(3)
5369       evdw2=0.0D0
5370       evdw2_14=0.0d0
5371 cd    print '(a)','Enter ESCP'
5372 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5373 c     &  ' scal14',scal14
5374       do i=iatscp_s,iatscp_e
5375         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5376         iteli=itel(i)
5377 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5378 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5379         if (iteli.eq.0) goto 1225
5380         xi=0.5D0*(c(1,i)+c(1,i+1))
5381         yi=0.5D0*(c(2,i)+c(2,i+1))
5382         zi=0.5D0*(c(3,i)+c(3,i+1))
5383 C Returning the ith atom to box
5384           xi=mod(xi,boxxsize)
5385           if (xi.lt.0) xi=xi+boxxsize
5386           yi=mod(yi,boxysize)
5387           if (yi.lt.0) yi=yi+boxysize
5388           zi=mod(zi,boxzsize)
5389           if (zi.lt.0) zi=zi+boxzsize
5390         do iint=1,nscp_gr(i)
5391
5392         do j=iscpstart(i,iint),iscpend(i,iint)
5393           itypj=iabs(itype(j))
5394           if (itypj.eq.ntyp1) cycle
5395 C Uncomment following three lines for SC-p interactions
5396 c         xj=c(1,nres+j)-xi
5397 c         yj=c(2,nres+j)-yi
5398 c         zj=c(3,nres+j)-zi
5399 C Uncomment following three lines for Ca-p interactions
5400           xj=c(1,j)
5401           yj=c(2,j)
5402           zj=c(3,j)
5403 C returning the jth atom to box
5404           xj=mod(xj,boxxsize)
5405           if (xj.lt.0) xj=xj+boxxsize
5406           yj=mod(yj,boxysize)
5407           if (yj.lt.0) yj=yj+boxysize
5408           zj=mod(zj,boxzsize)
5409           if (zj.lt.0) zj=zj+boxzsize
5410       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5411       xj_safe=xj
5412       yj_safe=yj
5413       zj_safe=zj
5414       subchap=0
5415 C Finding the closest jth atom
5416       do xshift=-1,1
5417       do yshift=-1,1
5418       do zshift=-1,1
5419           xj=xj_safe+xshift*boxxsize
5420           yj=yj_safe+yshift*boxysize
5421           zj=zj_safe+zshift*boxzsize
5422           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5423           if(dist_temp.lt.dist_init) then
5424             dist_init=dist_temp
5425             xj_temp=xj
5426             yj_temp=yj
5427             zj_temp=zj
5428             subchap=1
5429           endif
5430        enddo
5431        enddo
5432        enddo
5433        if (subchap.eq.1) then
5434           xj=xj_temp-xi
5435           yj=yj_temp-yi
5436           zj=zj_temp-zi
5437        else
5438           xj=xj_safe-xi
5439           yj=yj_safe-yi
5440           zj=zj_safe-zi
5441        endif
5442           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5443 C sss is scaling function for smoothing the cutoff gradient otherwise
5444 C the gradient would not be continuouse
5445           sss=sscale(1.0d0/(dsqrt(rrij)))
5446           if (sss.le.0.0d0) cycle
5447           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5448           fac=rrij**expon2
5449           e1=fac*fac*aad(itypj,iteli)
5450           e2=fac*bad(itypj,iteli)
5451           if (iabs(j-i) .le. 2) then
5452             e1=scal14*e1
5453             e2=scal14*e2
5454             evdw2_14=evdw2_14+(e1+e2)*sss
5455           endif
5456           evdwij=e1+e2
5457 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5458 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5459 c     &       bad(itypj,iteli)
5460           evdw2=evdw2+evdwij*sss
5461           if (calc_grad) then
5462 C
5463 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5464 C
5465           fac=-(evdwij+e1)*rrij*sss
5466           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5467           ggg(1)=xj*fac
5468           ggg(2)=yj*fac
5469           ggg(3)=zj*fac
5470           if (j.lt.i) then
5471 cd          write (iout,*) 'j<i'
5472 C Uncomment following three lines for SC-p interactions
5473 c           do k=1,3
5474 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5475 c           enddo
5476           else
5477 cd          write (iout,*) 'j>i'
5478             do k=1,3
5479               ggg(k)=-ggg(k)
5480 C Uncomment following line for SC-p interactions
5481 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5482             enddo
5483           endif
5484           do k=1,3
5485             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5486           enddo
5487           kstart=min0(i+1,j)
5488           kend=max0(i-1,j-1)
5489 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5490 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5491           do k=kstart,kend
5492             do l=1,3
5493               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5494             enddo
5495           enddo
5496           endif ! calc_grad
5497         enddo
5498         enddo ! iint
5499  1225   continue
5500       enddo ! i
5501       do i=1,nct
5502         do j=1,3
5503           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5504           gradx_scp(j,i)=expon*gradx_scp(j,i)
5505         enddo
5506       enddo
5507 C******************************************************************************
5508 C
5509 C                              N O T E !!!
5510 C
5511 C To save time the factor EXPON has been extracted from ALL components
5512 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5513 C use!
5514 C
5515 C******************************************************************************
5516       return
5517       end
5518 C--------------------------------------------------------------------------
5519       subroutine edis(ehpb)
5520 C
5521 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5522 C
5523       implicit real*8 (a-h,o-z)
5524       include 'DIMENSIONS'
5525       include 'DIMENSIONS.ZSCOPT'
5526       include 'COMMON.SBRIDGE'
5527       include 'COMMON.CHAIN'
5528       include 'COMMON.DERIV'
5529       include 'COMMON.VAR'
5530       include 'COMMON.INTERACT'
5531       include 'COMMON.CONTROL'
5532       include 'COMMON.IOUNITS'
5533       dimension ggg(3)
5534       ehpb=0.0D0
5535 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5536 cd    print *,'link_start=',link_start,' link_end=',link_end
5537 C      write(iout,*) link_end, "link_end"
5538       if (link_end.eq.0) return
5539       do i=link_start,link_end
5540 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5541 C CA-CA distance used in regularization of structure.
5542         ii=ihpb(i)
5543         jj=jhpb(i)
5544 C iii and jjj point to the residues for which the distance is assigned.
5545         if (ii.gt.nres) then
5546           iii=ii-nres
5547           jjj=jj-nres
5548         else
5549           iii=ii
5550           jjj=jj
5551         endif
5552 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5553 C    distance and angle dependent SS bond potential.
5554 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5555 C     & iabs(itype(jjj)).eq.1) then
5556 C       write(iout,*) constr_dist,"const"
5557        if (.not.dyn_ss .and. i.le.nss) then
5558          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5559      & iabs(itype(jjj)).eq.1) then
5560           call ssbond_ene(iii,jjj,eij)
5561           ehpb=ehpb+2*eij
5562            endif !ii.gt.neres
5563         else if (ii.gt.nres .and. jj.gt.nres) then
5564 c Restraints from contact prediction
5565           dd=dist(ii,jj)
5566           if (constr_dist.eq.11) then
5567 C            ehpb=ehpb+fordepth(i)**4.0d0
5568 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5569             ehpb=ehpb+fordepth(i)**4.0d0
5570      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5571             fac=fordepth(i)**4.0d0
5572      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5573 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5574 C     &    ehpb,fordepth(i),dd
5575 C            write(iout,*) ehpb,"atu?"
5576 C            ehpb,"tu?"
5577 C            fac=fordepth(i)**4.0d0
5578 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5579            else
5580           if (dhpb1(i).gt.0.0d0) then
5581             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5582             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5583 c            write (iout,*) "beta nmr",
5584 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5585           else
5586             dd=dist(ii,jj)
5587             rdis=dd-dhpb(i)
5588 C Get the force constant corresponding to this distance.
5589             waga=forcon(i)
5590 C Calculate the contribution to energy.
5591             ehpb=ehpb+waga*rdis*rdis
5592 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5593 C
5594 C Evaluate gradient.
5595 C
5596             fac=waga*rdis/dd
5597           endif !end dhpb1(i).gt.0
5598           endif !end const_dist=11
5599           do j=1,3
5600             ggg(j)=fac*(c(j,jj)-c(j,ii))
5601           enddo
5602           do j=1,3
5603             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5604             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5605           enddo
5606           do k=1,3
5607             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5608             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5609           enddo
5610         else !ii.gt.nres
5611 C          write(iout,*) "before"
5612           dd=dist(ii,jj)
5613 C          write(iout,*) "after",dd
5614           if (constr_dist.eq.11) then
5615             ehpb=ehpb+fordepth(i)**4.0d0
5616      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5617             fac=fordepth(i)**4.0d0
5618      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5619 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5620 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5621 C            print *,ehpb,"tu?"
5622 C            write(iout,*) ehpb,"btu?",
5623 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5624 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5625 C     &    ehpb,fordepth(i),dd
5626            else
5627           if (dhpb1(i).gt.0.0d0) then
5628             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5629             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5630 c            write (iout,*) "alph nmr",
5631 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5632           else
5633             rdis=dd-dhpb(i)
5634 C Get the force constant corresponding to this distance.
5635             waga=forcon(i)
5636 C Calculate the contribution to energy.
5637             ehpb=ehpb+waga*rdis*rdis
5638 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5639 C
5640 C Evaluate gradient.
5641 C
5642             fac=waga*rdis/dd
5643           endif
5644           endif
5645
5646         do j=1,3
5647           ggg(j)=fac*(c(j,jj)-c(j,ii))
5648         enddo
5649 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5650 C If this is a SC-SC distance, we need to calculate the contributions to the
5651 C Cartesian gradient in the SC vectors (ghpbx).
5652         if (iii.lt.ii) then
5653           do j=1,3
5654             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5655             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5656           enddo
5657         endif
5658         do j=iii,jjj-1
5659           do k=1,3
5660             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5661           enddo
5662         enddo
5663         endif
5664       enddo
5665       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5666       return
5667       end
5668 C--------------------------------------------------------------------------
5669       subroutine ssbond_ene(i,j,eij)
5670 C
5671 C Calculate the distance and angle dependent SS-bond potential energy
5672 C using a free-energy function derived based on RHF/6-31G** ab initio
5673 C calculations of diethyl disulfide.
5674 C
5675 C A. Liwo and U. Kozlowska, 11/24/03
5676 C
5677       implicit real*8 (a-h,o-z)
5678       include 'DIMENSIONS'
5679       include 'DIMENSIONS.ZSCOPT'
5680       include 'COMMON.SBRIDGE'
5681       include 'COMMON.CHAIN'
5682       include 'COMMON.DERIV'
5683       include 'COMMON.LOCAL'
5684       include 'COMMON.INTERACT'
5685       include 'COMMON.VAR'
5686       include 'COMMON.IOUNITS'
5687       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5688       itypi=iabs(itype(i))
5689       xi=c(1,nres+i)
5690       yi=c(2,nres+i)
5691       zi=c(3,nres+i)
5692       dxi=dc_norm(1,nres+i)
5693       dyi=dc_norm(2,nres+i)
5694       dzi=dc_norm(3,nres+i)
5695       dsci_inv=dsc_inv(itypi)
5696       itypj=iabs(itype(j))
5697       dscj_inv=dsc_inv(itypj)
5698       xj=c(1,nres+j)-xi
5699       yj=c(2,nres+j)-yi
5700       zj=c(3,nres+j)-zi
5701       dxj=dc_norm(1,nres+j)
5702       dyj=dc_norm(2,nres+j)
5703       dzj=dc_norm(3,nres+j)
5704       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5705       rij=dsqrt(rrij)
5706       erij(1)=xj*rij
5707       erij(2)=yj*rij
5708       erij(3)=zj*rij
5709       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5710       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5711       om12=dxi*dxj+dyi*dyj+dzi*dzj
5712       do k=1,3
5713         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5714         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5715       enddo
5716       rij=1.0d0/rij
5717       deltad=rij-d0cm
5718       deltat1=1.0d0-om1
5719       deltat2=1.0d0+om2
5720       deltat12=om2-om1+2.0d0
5721       cosphi=om12-om1*om2
5722       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5723      &  +akct*deltad*deltat12
5724      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5725 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5726 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5727 c     &  " deltat12",deltat12," eij",eij
5728       ed=2*akcm*deltad+akct*deltat12
5729       pom1=akct*deltad
5730       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5731       eom1=-2*akth*deltat1-pom1-om2*pom2
5732       eom2= 2*akth*deltat2+pom1-om1*pom2
5733       eom12=pom2
5734       do k=1,3
5735         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5736       enddo
5737       do k=1,3
5738         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5739      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5740         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5741      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5742       enddo
5743 C
5744 C Calculate the components of the gradient in DC and X
5745 C
5746       do k=i,j-1
5747         do l=1,3
5748           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5749         enddo
5750       enddo
5751       return
5752       end
5753 C--------------------------------------------------------------------------
5754       subroutine ebond(estr)
5755 c
5756 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5757 c
5758       implicit real*8 (a-h,o-z)
5759       include 'DIMENSIONS'
5760       include 'DIMENSIONS.ZSCOPT'
5761       include 'COMMON.LOCAL'
5762       include 'COMMON.GEO'
5763       include 'COMMON.INTERACT'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.VAR'
5766       include 'COMMON.CHAIN'
5767       include 'COMMON.IOUNITS'
5768       include 'COMMON.NAMES'
5769       include 'COMMON.FFIELD'
5770       include 'COMMON.CONTROL'
5771       double precision u(3),ud(3)
5772       estr=0.0d0
5773       estr1=0.0d0
5774 c      write (iout,*) "distchainmax",distchainmax
5775       do i=nnt+1,nct
5776         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5777 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5778 C          do j=1,3
5779 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5780 C     &      *dc(j,i-1)/vbld(i)
5781 C          enddo
5782 C          if (energy_dec) write(iout,*)
5783 C     &       "estr1",i,vbld(i),distchainmax,
5784 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5785 C        else
5786          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5787         diff = vbld(i)-vbldpDUM
5788          write(iout,*) "dumm_bond",i,diff
5789          else
5790           diff = vbld(i)-vbldp0
5791 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5792          endif
5793         write (iout,'(a7,i5,4f7.3)')
5794      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5795           estr=estr+diff*diff
5796           do j=1,3
5797             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5798           enddo
5799 C        endif
5800       enddo
5801       estr=0.5d0*AKP*estr+estr1
5802 c
5803 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5804 c
5805       do i=nnt,nct
5806         iti=iabs(itype(i))
5807         if (iti.ne.10 .and. iti.ne.ntyp1) then
5808           nbi=nbondterm(iti)
5809           if (nbi.eq.1) then
5810             diff=vbld(i+nres)-vbldsc0(1,iti)
5811             write (iout,*)
5812      &        "estr_sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5813      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5814             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5815             do j=1,3
5816               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5817             enddo
5818           else
5819             do j=1,nbi
5820               diff=vbld(i+nres)-vbldsc0(j,iti)
5821               ud(j)=aksc(j,iti)*diff
5822               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5823             enddo
5824             uprod=u(1)
5825             do j=2,nbi
5826               uprod=uprod*u(j)
5827             enddo
5828             usum=0.0d0
5829             usumsqder=0.0d0
5830             do j=1,nbi
5831               uprod1=1.0d0
5832               uprod2=1.0d0
5833               do k=1,nbi
5834                 if (k.ne.j) then
5835                   uprod1=uprod1*u(k)
5836                   uprod2=uprod2*u(k)*u(k)
5837                 endif
5838               enddo
5839               usum=usum+uprod1
5840               usumsqder=usumsqder+ud(j)*uprod2
5841             enddo
5842 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5843 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5844             estr=estr+uprod/usum
5845             do j=1,3
5846              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5847             enddo
5848           endif
5849         endif
5850       enddo
5851       return
5852       end
5853 #ifdef CRYST_THETA
5854 C--------------------------------------------------------------------------
5855       subroutine ebend(etheta,ethetacnstr)
5856 C
5857 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5858 C angles gamma and its derivatives in consecutive thetas and gammas.
5859 C
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'DIMENSIONS.ZSCOPT'
5863       include 'COMMON.LOCAL'
5864       include 'COMMON.GEO'
5865       include 'COMMON.INTERACT'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.VAR'
5868       include 'COMMON.CHAIN'
5869       include 'COMMON.IOUNITS'
5870       include 'COMMON.NAMES'
5871       include 'COMMON.FFIELD'
5872       include 'COMMON.TORCNSTR'
5873       common /calcthet/ term1,term2,termm,diffak,ratak,
5874      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5875      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5876       double precision y(2),z(2)
5877       delta=0.02d0*pi
5878 c      time11=dexp(-2*time)
5879 c      time12=1.0d0
5880       etheta=0.0D0
5881 c      write (iout,*) "nres",nres
5882 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5883 c      write (iout,*) ithet_start,ithet_end
5884       do i=ithet_start,ithet_end
5885 C        if (itype(i-1).eq.ntyp1) cycle
5886         if (i.le.2) cycle
5887         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5888      &  .or.itype(i).eq.ntyp1) cycle
5889 C Zero the energy function and its derivative at 0 or pi.
5890         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5891         it=itype(i-1)
5892         ichir1=isign(1,itype(i-2))
5893         ichir2=isign(1,itype(i))
5894          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5895          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5896          if (itype(i-1).eq.10) then
5897           itype1=isign(10,itype(i-2))
5898           ichir11=isign(1,itype(i-2))
5899           ichir12=isign(1,itype(i-2))
5900           itype2=isign(10,itype(i))
5901           ichir21=isign(1,itype(i))
5902           ichir22=isign(1,itype(i))
5903          endif
5904          if (i.eq.3) then
5905           y(1)=0.0D0
5906           y(2)=0.0D0
5907           else
5908
5909         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5910 #ifdef OSF
5911           phii=phi(i)
5912 c          icrc=0
5913 c          call proc_proc(phii,icrc)
5914           if (icrc.eq.1) phii=150.0
5915 #else
5916           phii=phi(i)
5917 #endif
5918           y(1)=dcos(phii)
5919           y(2)=dsin(phii)
5920         else
5921           y(1)=0.0D0
5922           y(2)=0.0D0
5923         endif
5924         endif
5925         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5926 #ifdef OSF
5927           phii1=phi(i+1)
5928 c          icrc=0
5929 c          call proc_proc(phii1,icrc)
5930           if (icrc.eq.1) phii1=150.0
5931           phii1=pinorm(phii1)
5932           z(1)=cos(phii1)
5933 #else
5934           phii1=phi(i+1)
5935           z(1)=dcos(phii1)
5936 #endif
5937           z(2)=dsin(phii1)
5938         else
5939           z(1)=0.0D0
5940           z(2)=0.0D0
5941         endif
5942 C Calculate the "mean" value of theta from the part of the distribution
5943 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5944 C In following comments this theta will be referred to as t_c.
5945         thet_pred_mean=0.0d0
5946         do k=1,2
5947             athetk=athet(k,it,ichir1,ichir2)
5948             bthetk=bthet(k,it,ichir1,ichir2)
5949           if (it.eq.10) then
5950              athetk=athet(k,itype1,ichir11,ichir12)
5951              bthetk=bthet(k,itype2,ichir21,ichir22)
5952           endif
5953           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5954         enddo
5955 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5956         dthett=thet_pred_mean*ssd
5957         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5958 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5959 C Derivatives of the "mean" values in gamma1 and gamma2.
5960         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5961      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5962          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5963      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5964          if (it.eq.10) then
5965       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5966      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5967         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5968      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5969          endif
5970         if (theta(i).gt.pi-delta) then
5971           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5972      &         E_tc0)
5973           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5974           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5975           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5976      &        E_theta)
5977           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5978      &        E_tc)
5979         else if (theta(i).lt.delta) then
5980           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5981           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5982           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5983      &        E_theta)
5984           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5985           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5986      &        E_tc)
5987         else
5988           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5989      &        E_theta,E_tc)
5990         endif
5991         etheta=etheta+ethetai
5992 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5993 c     &      'ebend',i,ethetai,theta(i),itype(i)
5994 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5995 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5996         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5997         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5998         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5999 c 1215   continue
6000       enddo
6001       ethetacnstr=0.0d0
6002 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6003       do i=1,ntheta_constr
6004         itheta=itheta_constr(i)
6005         thetiii=theta(itheta)
6006         difi=pinorm(thetiii-theta_constr0(i))
6007         if (difi.gt.theta_drange(i)) then
6008           difi=difi-theta_drange(i)
6009           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6010           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6011      &    +for_thet_constr(i)*difi**3
6012         else if (difi.lt.-drange(i)) then
6013           difi=difi+drange(i)
6014           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6015           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6016      &    +for_thet_constr(i)*difi**3
6017         else
6018           difi=0.0
6019         endif
6020 C       if (energy_dec) then
6021 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6022 C     &    i,itheta,rad2deg*thetiii,
6023 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6024 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6025 C     &    gloc(itheta+nphi-2,icg)
6026 C        endif
6027       enddo
6028 C Ufff.... We've done all this!!!
6029       return
6030       end
6031 C---------------------------------------------------------------------------
6032       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6033      &     E_tc)
6034       implicit real*8 (a-h,o-z)
6035       include 'DIMENSIONS'
6036       include 'COMMON.LOCAL'
6037       include 'COMMON.IOUNITS'
6038       common /calcthet/ term1,term2,termm,diffak,ratak,
6039      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6040      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6041 C Calculate the contributions to both Gaussian lobes.
6042 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6043 C The "polynomial part" of the "standard deviation" of this part of
6044 C the distribution.
6045         sig=polthet(3,it)
6046         do j=2,0,-1
6047           sig=sig*thet_pred_mean+polthet(j,it)
6048         enddo
6049 C Derivative of the "interior part" of the "standard deviation of the"
6050 C gamma-dependent Gaussian lobe in t_c.
6051         sigtc=3*polthet(3,it)
6052         do j=2,1,-1
6053           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6054         enddo
6055         sigtc=sig*sigtc
6056 C Set the parameters of both Gaussian lobes of the distribution.
6057 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6058         fac=sig*sig+sigc0(it)
6059         sigcsq=fac+fac
6060         sigc=1.0D0/sigcsq
6061 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6062         sigsqtc=-4.0D0*sigcsq*sigtc
6063 c       print *,i,sig,sigtc,sigsqtc
6064 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6065         sigtc=-sigtc/(fac*fac)
6066 C Following variable is sigma(t_c)**(-2)
6067         sigcsq=sigcsq*sigcsq
6068         sig0i=sig0(it)
6069         sig0inv=1.0D0/sig0i**2
6070         delthec=thetai-thet_pred_mean
6071         delthe0=thetai-theta0i
6072         term1=-0.5D0*sigcsq*delthec*delthec
6073         term2=-0.5D0*sig0inv*delthe0*delthe0
6074 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6075 C NaNs in taking the logarithm. We extract the largest exponent which is added
6076 C to the energy (this being the log of the distribution) at the end of energy
6077 C term evaluation for this virtual-bond angle.
6078         if (term1.gt.term2) then
6079           termm=term1
6080           term2=dexp(term2-termm)
6081           term1=1.0d0
6082         else
6083           termm=term2
6084           term1=dexp(term1-termm)
6085           term2=1.0d0
6086         endif
6087 C The ratio between the gamma-independent and gamma-dependent lobes of
6088 C the distribution is a Gaussian function of thet_pred_mean too.
6089         diffak=gthet(2,it)-thet_pred_mean
6090         ratak=diffak/gthet(3,it)**2
6091         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6092 C Let's differentiate it in thet_pred_mean NOW.
6093         aktc=ak*ratak
6094 C Now put together the distribution terms to make complete distribution.
6095         termexp=term1+ak*term2
6096         termpre=sigc+ak*sig0i
6097 C Contribution of the bending energy from this theta is just the -log of
6098 C the sum of the contributions from the two lobes and the pre-exponential
6099 C factor. Simple enough, isn't it?
6100         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6101 C NOW the derivatives!!!
6102 C 6/6/97 Take into account the deformation.
6103         E_theta=(delthec*sigcsq*term1
6104      &       +ak*delthe0*sig0inv*term2)/termexp
6105         E_tc=((sigtc+aktc*sig0i)/termpre
6106      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6107      &       aktc*term2)/termexp)
6108       return
6109       end
6110 c-----------------------------------------------------------------------------
6111       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6112       implicit real*8 (a-h,o-z)
6113       include 'DIMENSIONS'
6114       include 'COMMON.LOCAL'
6115       include 'COMMON.IOUNITS'
6116       common /calcthet/ term1,term2,termm,diffak,ratak,
6117      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6118      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6119       delthec=thetai-thet_pred_mean
6120       delthe0=thetai-theta0i
6121 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6122       t3 = thetai-thet_pred_mean
6123       t6 = t3**2
6124       t9 = term1
6125       t12 = t3*sigcsq
6126       t14 = t12+t6*sigsqtc
6127       t16 = 1.0d0
6128       t21 = thetai-theta0i
6129       t23 = t21**2
6130       t26 = term2
6131       t27 = t21*t26
6132       t32 = termexp
6133       t40 = t32**2
6134       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6135      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6136      & *(-t12*t9-ak*sig0inv*t27)
6137       return
6138       end
6139 #else
6140 C--------------------------------------------------------------------------
6141       subroutine ebend(etheta)
6142 C
6143 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6144 C angles gamma and its derivatives in consecutive thetas and gammas.
6145 C ab initio-derived potentials from
6146 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6147 C
6148       implicit real*8 (a-h,o-z)
6149       include 'DIMENSIONS'
6150       include 'DIMENSIONS.ZSCOPT'
6151       include 'COMMON.LOCAL'
6152       include 'COMMON.GEO'
6153       include 'COMMON.INTERACT'
6154       include 'COMMON.DERIV'
6155       include 'COMMON.VAR'
6156       include 'COMMON.CHAIN'
6157       include 'COMMON.IOUNITS'
6158       include 'COMMON.NAMES'
6159       include 'COMMON.FFIELD'
6160       include 'COMMON.CONTROL'
6161       include 'COMMON.TORCNSTR'
6162       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6163      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6164      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6165      & sinph1ph2(maxdouble,maxdouble)
6166       logical lprn /.false./, lprn1 /.false./
6167       etheta=0.0D0
6168 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6169       do i=ithet_start,ithet_end
6170 C         if (i.eq.2) cycle
6171 C        if (itype(i-1).eq.ntyp1) cycle
6172         if (i.le.2) cycle
6173         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6174      &  .or.itype(i).eq.ntyp1) cycle
6175         if (iabs(itype(i+1)).eq.20) iblock=2
6176         if (iabs(itype(i+1)).ne.20) iblock=1
6177         dethetai=0.0d0
6178         dephii=0.0d0
6179         dephii1=0.0d0
6180         theti2=0.5d0*theta(i)
6181         ityp2=ithetyp((itype(i-1)))
6182         do k=1,nntheterm
6183           coskt(k)=dcos(k*theti2)
6184           sinkt(k)=dsin(k*theti2)
6185         enddo
6186         if (i.eq.3) then
6187           phii=0.0d0
6188           ityp1=nthetyp+1
6189           do k=1,nsingle
6190             cosph1(k)=0.0d0
6191             sinph1(k)=0.0d0
6192           enddo
6193         else
6194         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6195 #ifdef OSF
6196           phii=phi(i)
6197           if (phii.ne.phii) phii=150.0
6198 #else
6199           phii=phi(i)
6200 #endif
6201           ityp1=ithetyp((itype(i-2)))
6202           do k=1,nsingle
6203             cosph1(k)=dcos(k*phii)
6204             sinph1(k)=dsin(k*phii)
6205           enddo
6206         else
6207           phii=0.0d0
6208 c          ityp1=nthetyp+1
6209           do k=1,nsingle
6210             ityp1=ithetyp((itype(i-2)))
6211             cosph1(k)=0.0d0
6212             sinph1(k)=0.0d0
6213           enddo
6214         endif
6215         endif
6216         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6217 #ifdef OSF
6218           phii1=phi(i+1)
6219           if (phii1.ne.phii1) phii1=150.0
6220           phii1=pinorm(phii1)
6221 #else
6222           phii1=phi(i+1)
6223 #endif
6224           ityp3=ithetyp((itype(i)))
6225           do k=1,nsingle
6226             cosph2(k)=dcos(k*phii1)
6227             sinph2(k)=dsin(k*phii1)
6228           enddo
6229         else
6230           phii1=0.0d0
6231 c          ityp3=nthetyp+1
6232           ityp3=ithetyp((itype(i)))
6233           do k=1,nsingle
6234             cosph2(k)=0.0d0
6235             sinph2(k)=0.0d0
6236           enddo
6237         endif
6238 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6239 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6240 c        call flush(iout)
6241         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6242         do k=1,ndouble
6243           do l=1,k-1
6244             ccl=cosph1(l)*cosph2(k-l)
6245             ssl=sinph1(l)*sinph2(k-l)
6246             scl=sinph1(l)*cosph2(k-l)
6247             csl=cosph1(l)*sinph2(k-l)
6248             cosph1ph2(l,k)=ccl-ssl
6249             cosph1ph2(k,l)=ccl+ssl
6250             sinph1ph2(l,k)=scl+csl
6251             sinph1ph2(k,l)=scl-csl
6252           enddo
6253         enddo
6254         if (lprn) then
6255         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6256      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6257         write (iout,*) "coskt and sinkt"
6258         do k=1,nntheterm
6259           write (iout,*) k,coskt(k),sinkt(k)
6260         enddo
6261         endif
6262         do k=1,ntheterm
6263           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6264           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6265      &      *coskt(k)
6266           if (lprn)
6267      &    write (iout,*) "k",k,"
6268      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6269      &     " ethetai",ethetai
6270         enddo
6271         if (lprn) then
6272         write (iout,*) "cosph and sinph"
6273         do k=1,nsingle
6274           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6275         enddo
6276         write (iout,*) "cosph1ph2 and sinph2ph2"
6277         do k=2,ndouble
6278           do l=1,k-1
6279             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6280      &         sinph1ph2(l,k),sinph1ph2(k,l)
6281           enddo
6282         enddo
6283         write(iout,*) "ethetai",ethetai
6284         endif
6285         do m=1,ntheterm2
6286           do k=1,nsingle
6287             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6288      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6289      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6290      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6291             ethetai=ethetai+sinkt(m)*aux
6292             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6293             dephii=dephii+k*sinkt(m)*(
6294      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6295      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6296             dephii1=dephii1+k*sinkt(m)*(
6297      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6298      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6299             if (lprn)
6300      &      write (iout,*) "m",m," k",k," bbthet",
6301      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6302      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6303      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6304      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6305           enddo
6306         enddo
6307         if (lprn)
6308      &  write(iout,*) "ethetai",ethetai
6309         do m=1,ntheterm3
6310           do k=2,ndouble
6311             do l=1,k-1
6312               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6313      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6314      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6315      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6316               ethetai=ethetai+sinkt(m)*aux
6317               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6318               dephii=dephii+l*sinkt(m)*(
6319      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6320      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6321      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6322      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6323               dephii1=dephii1+(k-l)*sinkt(m)*(
6324      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6325      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6326      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6327      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6328               if (lprn) then
6329               write (iout,*) "m",m," k",k," l",l," ffthet",
6330      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6331      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6332      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6333      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6334      &            " ethetai",ethetai
6335               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6336      &            cosph1ph2(k,l)*sinkt(m),
6337      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6338               endif
6339             enddo
6340           enddo
6341         enddo
6342 10      continue
6343         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6344      &   i,theta(i)*rad2deg,phii*rad2deg,
6345      &   phii1*rad2deg,ethetai
6346         etheta=etheta+ethetai
6347         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6348         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6349 c        gloc(nphi+i-2,icg)=wang*dethetai
6350         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6351       enddo
6352       return
6353       end
6354 #endif
6355 #ifdef CRYST_SC
6356 c-----------------------------------------------------------------------------
6357       subroutine esc(escloc)
6358 C Calculate the local energy of a side chain and its derivatives in the
6359 C corresponding virtual-bond valence angles THETA and the spherical angles
6360 C ALPHA and OMEGA.
6361       implicit real*8 (a-h,o-z)
6362       include 'DIMENSIONS'
6363       include 'DIMENSIONS.ZSCOPT'
6364       include 'COMMON.GEO'
6365       include 'COMMON.LOCAL'
6366       include 'COMMON.VAR'
6367       include 'COMMON.INTERACT'
6368       include 'COMMON.DERIV'
6369       include 'COMMON.CHAIN'
6370       include 'COMMON.IOUNITS'
6371       include 'COMMON.NAMES'
6372       include 'COMMON.FFIELD'
6373       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6374      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6375       common /sccalc/ time11,time12,time112,theti,it,nlobit
6376       delta=0.02d0*pi
6377       escloc=0.0D0
6378 C      write (iout,*) 'ESC'
6379       do i=loc_start,loc_end
6380         it=itype(i)
6381         if (it.eq.ntyp1) cycle
6382         if (it.eq.10) goto 1
6383         nlobit=nlob(iabs(it))
6384 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6385 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6386         theti=theta(i+1)-pipol
6387         x(1)=dtan(theti)
6388         x(2)=alph(i)
6389         x(3)=omeg(i)
6390 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6391
6392         if (x(2).gt.pi-delta) then
6393           xtemp(1)=x(1)
6394           xtemp(2)=pi-delta
6395           xtemp(3)=x(3)
6396           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6397           xtemp(2)=pi
6398           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6399           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6400      &        escloci,dersc(2))
6401           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6402      &        ddersc0(1),dersc(1))
6403           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6404      &        ddersc0(3),dersc(3))
6405           xtemp(2)=pi-delta
6406           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6407           xtemp(2)=pi
6408           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6409           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6410      &            dersc0(2),esclocbi,dersc02)
6411           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6412      &            dersc12,dersc01)
6413           call splinthet(x(2),0.5d0*delta,ss,ssd)
6414           dersc0(1)=dersc01
6415           dersc0(2)=dersc02
6416           dersc0(3)=0.0d0
6417           do k=1,3
6418             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6419           enddo
6420           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6421           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6422      &             esclocbi,ss,ssd
6423           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6424 c         escloci=esclocbi
6425 c         write (iout,*) escloci
6426         else if (x(2).lt.delta) then
6427           xtemp(1)=x(1)
6428           xtemp(2)=delta
6429           xtemp(3)=x(3)
6430           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6431           xtemp(2)=0.0d0
6432           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6433           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6434      &        escloci,dersc(2))
6435           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6436      &        ddersc0(1),dersc(1))
6437           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6438      &        ddersc0(3),dersc(3))
6439           xtemp(2)=delta
6440           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6441           xtemp(2)=0.0d0
6442           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6443           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6444      &            dersc0(2),esclocbi,dersc02)
6445           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6446      &            dersc12,dersc01)
6447           dersc0(1)=dersc01
6448           dersc0(2)=dersc02
6449           dersc0(3)=0.0d0
6450           call splinthet(x(2),0.5d0*delta,ss,ssd)
6451           do k=1,3
6452             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6453           enddo
6454           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6455 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6456 c     &             esclocbi,ss,ssd
6457           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6458 C         write (iout,*) 'i=',i, escloci
6459         else
6460           call enesc(x,escloci,dersc,ddummy,.false.)
6461         endif
6462
6463         escloc=escloc+escloci
6464 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6465             write (iout,'(a6,i5,0pf7.3)')
6466      &     'escloc',i,escloci
6467
6468         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6469      &   wscloc*dersc(1)
6470         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6471         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6472     1   continue
6473       enddo
6474       return
6475       end
6476 C---------------------------------------------------------------------------
6477       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6478       implicit real*8 (a-h,o-z)
6479       include 'DIMENSIONS'
6480       include 'COMMON.GEO'
6481       include 'COMMON.LOCAL'
6482       include 'COMMON.IOUNITS'
6483       common /sccalc/ time11,time12,time112,theti,it,nlobit
6484       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6485       double precision contr(maxlob,-1:1)
6486       logical mixed
6487 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6488         escloc_i=0.0D0
6489         do j=1,3
6490           dersc(j)=0.0D0
6491           if (mixed) ddersc(j)=0.0d0
6492         enddo
6493         x3=x(3)
6494
6495 C Because of periodicity of the dependence of the SC energy in omega we have
6496 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6497 C To avoid underflows, first compute & store the exponents.
6498
6499         do iii=-1,1
6500
6501           x(3)=x3+iii*dwapi
6502
6503           do j=1,nlobit
6504             do k=1,3
6505               z(k)=x(k)-censc(k,j,it)
6506             enddo
6507             do k=1,3
6508               Axk=0.0D0
6509               do l=1,3
6510                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6511               enddo
6512               Ax(k,j,iii)=Axk
6513             enddo
6514             expfac=0.0D0
6515             do k=1,3
6516               expfac=expfac+Ax(k,j,iii)*z(k)
6517             enddo
6518             contr(j,iii)=expfac
6519           enddo ! j
6520
6521         enddo ! iii
6522
6523         x(3)=x3
6524 C As in the case of ebend, we want to avoid underflows in exponentiation and
6525 C subsequent NaNs and INFs in energy calculation.
6526 C Find the largest exponent
6527         emin=contr(1,-1)
6528         do iii=-1,1
6529           do j=1,nlobit
6530             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6531           enddo
6532         enddo
6533         emin=0.5D0*emin
6534 cd      print *,'it=',it,' emin=',emin
6535
6536 C Compute the contribution to SC energy and derivatives
6537         do iii=-1,1
6538
6539           do j=1,nlobit
6540             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6541 cd          print *,'j=',j,' expfac=',expfac
6542             escloc_i=escloc_i+expfac
6543             do k=1,3
6544               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6545             enddo
6546             if (mixed) then
6547               do k=1,3,2
6548                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6549      &            +gaussc(k,2,j,it))*expfac
6550               enddo
6551             endif
6552           enddo
6553
6554         enddo ! iii
6555
6556         dersc(1)=dersc(1)/cos(theti)**2
6557         ddersc(1)=ddersc(1)/cos(theti)**2
6558         ddersc(3)=ddersc(3)
6559
6560         escloci=-(dlog(escloc_i)-emin)
6561         do j=1,3
6562           dersc(j)=dersc(j)/escloc_i
6563         enddo
6564         if (mixed) then
6565           do j=1,3,2
6566             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6567           enddo
6568         endif
6569       return
6570       end
6571 C------------------------------------------------------------------------------
6572       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6573       implicit real*8 (a-h,o-z)
6574       include 'DIMENSIONS'
6575       include 'COMMON.GEO'
6576       include 'COMMON.LOCAL'
6577       include 'COMMON.IOUNITS'
6578       common /sccalc/ time11,time12,time112,theti,it,nlobit
6579       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6580       double precision contr(maxlob)
6581       logical mixed
6582
6583       escloc_i=0.0D0
6584
6585       do j=1,3
6586         dersc(j)=0.0D0
6587       enddo
6588
6589       do j=1,nlobit
6590         do k=1,2
6591           z(k)=x(k)-censc(k,j,it)
6592         enddo
6593         z(3)=dwapi
6594         do k=1,3
6595           Axk=0.0D0
6596           do l=1,3
6597             Axk=Axk+gaussc(l,k,j,it)*z(l)
6598           enddo
6599           Ax(k,j)=Axk
6600         enddo
6601         expfac=0.0D0
6602         do k=1,3
6603           expfac=expfac+Ax(k,j)*z(k)
6604         enddo
6605         contr(j)=expfac
6606       enddo ! j
6607
6608 C As in the case of ebend, we want to avoid underflows in exponentiation and
6609 C subsequent NaNs and INFs in energy calculation.
6610 C Find the largest exponent
6611       emin=contr(1)
6612       do j=1,nlobit
6613         if (emin.gt.contr(j)) emin=contr(j)
6614       enddo
6615       emin=0.5D0*emin
6616
6617 C Compute the contribution to SC energy and derivatives
6618
6619       dersc12=0.0d0
6620       do j=1,nlobit
6621         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6622         escloc_i=escloc_i+expfac
6623         do k=1,2
6624           dersc(k)=dersc(k)+Ax(k,j)*expfac
6625         enddo
6626         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6627      &            +gaussc(1,2,j,it))*expfac
6628         dersc(3)=0.0d0
6629       enddo
6630
6631       dersc(1)=dersc(1)/cos(theti)**2
6632       dersc12=dersc12/cos(theti)**2
6633       escloci=-(dlog(escloc_i)-emin)
6634       do j=1,2
6635         dersc(j)=dersc(j)/escloc_i
6636       enddo
6637       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6638       return
6639       end
6640 #else
6641 c----------------------------------------------------------------------------------
6642       subroutine esc(escloc)
6643 C Calculate the local energy of a side chain and its derivatives in the
6644 C corresponding virtual-bond valence angles THETA and the spherical angles
6645 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6646 C added by Urszula Kozlowska. 07/11/2007
6647 C
6648       implicit real*8 (a-h,o-z)
6649       include 'DIMENSIONS'
6650       include 'DIMENSIONS.ZSCOPT'
6651       include 'COMMON.GEO'
6652       include 'COMMON.LOCAL'
6653       include 'COMMON.VAR'
6654       include 'COMMON.SCROT'
6655       include 'COMMON.INTERACT'
6656       include 'COMMON.DERIV'
6657       include 'COMMON.CHAIN'
6658       include 'COMMON.IOUNITS'
6659       include 'COMMON.NAMES'
6660       include 'COMMON.FFIELD'
6661       include 'COMMON.CONTROL'
6662       include 'COMMON.VECTORS'
6663       double precision x_prime(3),y_prime(3),z_prime(3)
6664      &    , sumene,dsc_i,dp2_i,x(65),
6665      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6666      &    de_dxx,de_dyy,de_dzz,de_dt
6667       double precision s1_t,s1_6_t,s2_t,s2_6_t
6668       double precision
6669      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6670      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6671      & dt_dCi(3),dt_dCi1(3)
6672       common /sccalc/ time11,time12,time112,theti,it,nlobit
6673       delta=0.02d0*pi
6674       escloc=0.0D0
6675       do i=loc_start,loc_end
6676         if (itype(i).eq.ntyp1) cycle
6677         costtab(i+1) =dcos(theta(i+1))
6678         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6679         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6680         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6681         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6682         cosfac=dsqrt(cosfac2)
6683         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6684         sinfac=dsqrt(sinfac2)
6685         it=iabs(itype(i))
6686         if (it.eq.10) goto 1
6687 c
6688 C  Compute the axes of tghe local cartesian coordinates system; store in
6689 c   x_prime, y_prime and z_prime
6690 c
6691         do j=1,3
6692           x_prime(j) = 0.00
6693           y_prime(j) = 0.00
6694           z_prime(j) = 0.00
6695         enddo
6696 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6697 C     &   dc_norm(3,i+nres)
6698         do j = 1,3
6699           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6700           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6701         enddo
6702         do j = 1,3
6703           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6704         enddo
6705 c       write (2,*) "i",i
6706 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6707 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6708 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6709 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6710 c      & " xy",scalar(x_prime(1),y_prime(1)),
6711 c      & " xz",scalar(x_prime(1),z_prime(1)),
6712 c      & " yy",scalar(y_prime(1),y_prime(1)),
6713 c      & " yz",scalar(y_prime(1),z_prime(1)),
6714 c      & " zz",scalar(z_prime(1),z_prime(1))
6715 c
6716 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6717 C to local coordinate system. Store in xx, yy, zz.
6718 c
6719         xx=0.0d0
6720         yy=0.0d0
6721         zz=0.0d0
6722         do j = 1,3
6723           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6724           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6725           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6726         enddo
6727
6728         xxtab(i)=xx
6729         yytab(i)=yy
6730         zztab(i)=zz
6731 C
6732 C Compute the energy of the ith side cbain
6733 C
6734 c        write (2,*) "xx",xx," yy",yy," zz",zz
6735         it=iabs(itype(i))
6736         do j = 1,65
6737           x(j) = sc_parmin(j,it)
6738         enddo
6739 #ifdef CHECK_COORD
6740 Cc diagnostics - remove later
6741         xx1 = dcos(alph(2))
6742         yy1 = dsin(alph(2))*dcos(omeg(2))
6743         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6744         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6745      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6746      &    xx1,yy1,zz1
6747 C,"  --- ", xx_w,yy_w,zz_w
6748 c end diagnostics
6749 #endif
6750         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6751      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6752      &   + x(10)*yy*zz
6753         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6754      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6755      & + x(20)*yy*zz
6756         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6757      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6758      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6759      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6760      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6761      &  +x(40)*xx*yy*zz
6762         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6763      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6764      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6765      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6766      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6767      &  +x(60)*xx*yy*zz
6768         dsc_i   = 0.743d0+x(61)
6769         dp2_i   = 1.9d0+x(62)
6770         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6771      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6772         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6773      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6774         s1=(1+x(63))/(0.1d0 + dscp1)
6775         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6776         s2=(1+x(65))/(0.1d0 + dscp2)
6777         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6778         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6779      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6780 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6781 c     &   sumene4,
6782 c     &   dscp1,dscp2,sumene
6783 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6784         escloc = escloc + sumene
6785 c        write (2,*) "escloc",escloc
6786 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6787 c     &  zz,xx,yy
6788         if (.not. calc_grad) goto 1
6789 #ifdef DEBUG
6790 C
6791 C This section to check the numerical derivatives of the energy of ith side
6792 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6793 C #define DEBUG in the code to turn it on.
6794 C
6795         write (2,*) "sumene               =",sumene
6796         aincr=1.0d-7
6797         xxsave=xx
6798         xx=xx+aincr
6799         write (2,*) xx,yy,zz
6800         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6801         de_dxx_num=(sumenep-sumene)/aincr
6802         xx=xxsave
6803         write (2,*) "xx+ sumene from enesc=",sumenep
6804         yysave=yy
6805         yy=yy+aincr
6806         write (2,*) xx,yy,zz
6807         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6808         de_dyy_num=(sumenep-sumene)/aincr
6809         yy=yysave
6810         write (2,*) "yy+ sumene from enesc=",sumenep
6811         zzsave=zz
6812         zz=zz+aincr
6813         write (2,*) xx,yy,zz
6814         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6815         de_dzz_num=(sumenep-sumene)/aincr
6816         zz=zzsave
6817         write (2,*) "zz+ sumene from enesc=",sumenep
6818         costsave=cost2tab(i+1)
6819         sintsave=sint2tab(i+1)
6820         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6821         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6822         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6823         de_dt_num=(sumenep-sumene)/aincr
6824         write (2,*) " t+ sumene from enesc=",sumenep
6825         cost2tab(i+1)=costsave
6826         sint2tab(i+1)=sintsave
6827 C End of diagnostics section.
6828 #endif
6829 C
6830 C Compute the gradient of esc
6831 C
6832         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6833         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6834         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6835         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6836         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6837         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6838         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6839         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6840         pom1=(sumene3*sint2tab(i+1)+sumene1)
6841      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6842         pom2=(sumene4*cost2tab(i+1)+sumene2)
6843      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6844         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6845         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6846      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6847      &  +x(40)*yy*zz
6848         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6849         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6850      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6851      &  +x(60)*yy*zz
6852         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6853      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6854      &        +(pom1+pom2)*pom_dx
6855 #ifdef DEBUG
6856         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6857 #endif
6858 C
6859         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6860         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6861      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6862      &  +x(40)*xx*zz
6863         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6864         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6865      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6866      &  +x(59)*zz**2 +x(60)*xx*zz
6867         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6868      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6869      &        +(pom1-pom2)*pom_dy
6870 #ifdef DEBUG
6871         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6872 #endif
6873 C
6874         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6875      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6876      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6877      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6878      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6879      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6880      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6881      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6882 #ifdef DEBUG
6883         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6884 #endif
6885 C
6886         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6887      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6888      &  +pom1*pom_dt1+pom2*pom_dt2
6889 #ifdef DEBUG
6890         write(2,*), "de_dt = ", de_dt,de_dt_num
6891 #endif
6892 c
6893 C
6894        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6895        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6896        cosfac2xx=cosfac2*xx
6897        sinfac2yy=sinfac2*yy
6898        do k = 1,3
6899          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6900      &      vbld_inv(i+1)
6901          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6902      &      vbld_inv(i)
6903          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6904          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6905 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6906 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6907 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6908 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6909          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6910          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6911          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6912          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6913          dZZ_Ci1(k)=0.0d0
6914          dZZ_Ci(k)=0.0d0
6915          do j=1,3
6916            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6917      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6918            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6919      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6920          enddo
6921
6922          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6923          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6924          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6925 c
6926          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6927          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6928        enddo
6929
6930        do k=1,3
6931          dXX_Ctab(k,i)=dXX_Ci(k)
6932          dXX_C1tab(k,i)=dXX_Ci1(k)
6933          dYY_Ctab(k,i)=dYY_Ci(k)
6934          dYY_C1tab(k,i)=dYY_Ci1(k)
6935          dZZ_Ctab(k,i)=dZZ_Ci(k)
6936          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6937          dXX_XYZtab(k,i)=dXX_XYZ(k)
6938          dYY_XYZtab(k,i)=dYY_XYZ(k)
6939          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6940        enddo
6941
6942        do k = 1,3
6943 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6944 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6945 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6946 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6947 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6948 c     &    dt_dci(k)
6949 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6950 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6951          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6952      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6953          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6954      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6955          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6956      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6957        enddo
6958 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6959 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6960
6961 C to check gradient call subroutine check_grad
6962
6963     1 continue
6964       enddo
6965       return
6966       end
6967 #endif
6968 c------------------------------------------------------------------------------
6969       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6970 C
6971 C This procedure calculates two-body contact function g(rij) and its derivative:
6972 C
6973 C           eps0ij                                     !       x < -1
6974 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6975 C            0                                         !       x > 1
6976 C
6977 C where x=(rij-r0ij)/delta
6978 C
6979 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6980 C
6981       implicit none
6982       double precision rij,r0ij,eps0ij,fcont,fprimcont
6983       double precision x,x2,x4,delta
6984 c     delta=0.02D0*r0ij
6985 c      delta=0.2D0*r0ij
6986       x=(rij-r0ij)/delta
6987       if (x.lt.-1.0D0) then
6988         fcont=eps0ij
6989         fprimcont=0.0D0
6990       else if (x.le.1.0D0) then
6991         x2=x*x
6992         x4=x2*x2
6993         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6994         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6995       else
6996         fcont=0.0D0
6997         fprimcont=0.0D0
6998       endif
6999       return
7000       end
7001 c------------------------------------------------------------------------------
7002       subroutine splinthet(theti,delta,ss,ssder)
7003       implicit real*8 (a-h,o-z)
7004       include 'DIMENSIONS'
7005       include 'DIMENSIONS.ZSCOPT'
7006       include 'COMMON.VAR'
7007       include 'COMMON.GEO'
7008       thetup=pi-delta
7009       thetlow=delta
7010       if (theti.gt.pipol) then
7011         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7012       else
7013         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7014         ssder=-ssder
7015       endif
7016       return
7017       end
7018 c------------------------------------------------------------------------------
7019       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7020       implicit none
7021       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7022       double precision ksi,ksi2,ksi3,a1,a2,a3
7023       a1=fprim0*delta/(f1-f0)
7024       a2=3.0d0-2.0d0*a1
7025       a3=a1-2.0d0
7026       ksi=(x-x0)/delta
7027       ksi2=ksi*ksi
7028       ksi3=ksi2*ksi
7029       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7030       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7031       return
7032       end
7033 c------------------------------------------------------------------------------
7034       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7035       implicit none
7036       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7037       double precision ksi,ksi2,ksi3,a1,a2,a3
7038       ksi=(x-x0)/delta
7039       ksi2=ksi*ksi
7040       ksi3=ksi2*ksi
7041       a1=fprim0x*delta
7042       a2=3*(f1x-f0x)-2*fprim0x*delta
7043       a3=fprim0x*delta-2*(f1x-f0x)
7044       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7045       return
7046       end
7047 C-----------------------------------------------------------------------------
7048 #ifdef CRYST_TOR
7049 C-----------------------------------------------------------------------------
7050       subroutine etor(etors)
7051       implicit real*8 (a-h,o-z)
7052       include 'DIMENSIONS'
7053       include 'DIMENSIONS.ZSCOPT'
7054       include 'COMMON.VAR'
7055       include 'COMMON.GEO'
7056       include 'COMMON.LOCAL'
7057       include 'COMMON.TORSION'
7058       include 'COMMON.INTERACT'
7059       include 'COMMON.DERIV'
7060       include 'COMMON.CHAIN'
7061       include 'COMMON.NAMES'
7062       include 'COMMON.IOUNITS'
7063       include 'COMMON.FFIELD'
7064       include 'COMMON.TORCNSTR'
7065       logical lprn
7066 C Set lprn=.true. for debugging
7067       lprn=.false.
7068 c      lprn=.true.
7069       etors=0.0D0
7070       do i=iphi_start,iphi_end
7071         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7072      &      .or. itype(i).eq.ntyp1) cycle
7073         itori=itortyp(itype(i-2))
7074         itori1=itortyp(itype(i-1))
7075         phii=phi(i)
7076         gloci=0.0D0
7077 C Proline-Proline pair is a special case...
7078         if (itori.eq.3 .and. itori1.eq.3) then
7079           if (phii.gt.-dwapi3) then
7080             cosphi=dcos(3*phii)
7081             fac=1.0D0/(1.0D0-cosphi)
7082             etorsi=v1(1,3,3)*fac
7083             etorsi=etorsi+etorsi
7084             etors=etors+etorsi-v1(1,3,3)
7085             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7086           endif
7087           do j=1,3
7088             v1ij=v1(j+1,itori,itori1)
7089             v2ij=v2(j+1,itori,itori1)
7090             cosphi=dcos(j*phii)
7091             sinphi=dsin(j*phii)
7092             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7093             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7094           enddo
7095         else
7096           do j=1,nterm_old
7097             v1ij=v1(j,itori,itori1)
7098             v2ij=v2(j,itori,itori1)
7099             cosphi=dcos(j*phii)
7100             sinphi=dsin(j*phii)
7101             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7102             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7103           enddo
7104         endif
7105         if (lprn)
7106      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7107      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7108      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7109         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7110 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7111       enddo
7112       return
7113       end
7114 c------------------------------------------------------------------------------
7115 #else
7116       subroutine etor(etors)
7117       implicit real*8 (a-h,o-z)
7118       include 'DIMENSIONS'
7119       include 'DIMENSIONS.ZSCOPT'
7120       include 'COMMON.VAR'
7121       include 'COMMON.GEO'
7122       include 'COMMON.LOCAL'
7123       include 'COMMON.TORSION'
7124       include 'COMMON.INTERACT'
7125       include 'COMMON.DERIV'
7126       include 'COMMON.CHAIN'
7127       include 'COMMON.NAMES'
7128       include 'COMMON.IOUNITS'
7129       include 'COMMON.FFIELD'
7130       include 'COMMON.TORCNSTR'
7131       include 'COMMON.WEIGHTS'
7132       include 'COMMON.WEIGHTDER'
7133       logical lprn
7134 C Set lprn=.true. for debugging
7135       lprn=.false.
7136 c      lprn=.true.
7137       etors=0.0D0
7138       do iblock=1,2
7139       do i=-ntyp+1,ntyp-1
7140         do j=-ntyp+1,ntyp-1
7141           do k=0,3
7142             do l=0,2*maxterm
7143               etor_temp(l,k,j,i,iblock)=0.0d0
7144             enddo
7145           enddo
7146         enddo
7147       enddo
7148       enddo
7149       do i=iphi_start,iphi_end
7150         if (i.le.2) cycle
7151         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7152      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7153         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7154         if (iabs(itype(i)).eq.20) then
7155           iblock=2
7156         else
7157           iblock=1
7158         endif
7159         itori=itortyp(itype(i-2))
7160         itori1=itortyp(itype(i-1))
7161         weitori=weitor(0,itori,itori1,iblock)
7162         phii=phi(i)
7163         gloci=0.0D0
7164         etori=0.0d0
7165 C Regular cosine and sine terms
7166         do j=1,nterm(itori,itori1,iblock)
7167           v1ij=v1(j,itori,itori1,iblock)
7168           v2ij=v2(j,itori,itori1,iblock)
7169           cosphi=dcos(j*phii)
7170           sinphi=dsin(j*phii)
7171           etori=etori+v1ij*cosphi+v2ij*sinphi
7172           etor_temp(j,0,itori,itori1,iblock)=
7173      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7174           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7175      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7176      &      sinphi*ww(13)
7177           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7178         enddo
7179 C Lorentz terms
7180 C                         v1
7181 C  E = SUM ----------------------------------- - v1
7182 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7183 C
7184         cosphi=dcos(0.5d0*phii)
7185         sinphi=dsin(0.5d0*phii)
7186         do j=1,nlor(itori,itori1,iblock)
7187           vl1ij=vlor1(j,itori,itori1)
7188           vl2ij=vlor2(j,itori,itori1)
7189           vl3ij=vlor3(j,itori,itori1)
7190           pom=vl2ij*cosphi+vl3ij*sinphi
7191           pom1=1.0d0/(pom*pom+1.0d0)
7192           etori=etori+vl1ij*pom1
7193           pom=-pom*pom1*pom1
7194           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7195         enddo
7196 C Subtract the constant term
7197         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7198         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7199      &    (etori-v0(itori,itori1,iblock))*ww(13)
7200
7201         if (lprn) then
7202         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7203      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7204      &  weitori,v0(itori,itori1,iblock)*weitori,
7205      &  (v1(j,itori,itori1,iblock)*weitori,
7206      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7207         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7208      &    iloctyp(itori1)," etor_temp",
7209      &    etor_temp(0,0,itori,itori1,1)
7210         call flush(iout)
7211         endif
7212         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7213 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7214  1215   continue
7215       enddo
7216       return
7217       end
7218 c----------------------------------------------------------------------------
7219       subroutine etor_d(etors_d)
7220 C 6/23/01 Compute double torsional energy
7221       implicit real*8 (a-h,o-z)
7222       include 'DIMENSIONS'
7223       include 'DIMENSIONS.ZSCOPT'
7224       include 'COMMON.VAR'
7225       include 'COMMON.GEO'
7226       include 'COMMON.LOCAL'
7227       include 'COMMON.TORSION'
7228       include 'COMMON.INTERACT'
7229       include 'COMMON.DERIV'
7230       include 'COMMON.CHAIN'
7231       include 'COMMON.NAMES'
7232       include 'COMMON.IOUNITS'
7233       include 'COMMON.FFIELD'
7234       include 'COMMON.TORCNSTR'
7235       logical lprn
7236 C Set lprn=.true. for debugging
7237       lprn=.false.
7238 c     lprn=.true.
7239       etors_d=0.0D0
7240       do i=iphi_start,iphi_end-1
7241         if (i.le.3) cycle
7242 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7243 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7244          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7245      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7246      &  (itype(i+1).eq.ntyp1)) cycle
7247         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7248      &     goto 1215
7249         itori=itortyp(itype(i-2))
7250         itori1=itortyp(itype(i-1))
7251         itori2=itortyp(itype(i))
7252         phii=phi(i)
7253         phii1=phi(i+1)
7254         gloci1=0.0D0
7255         gloci2=0.0D0
7256         iblock=1
7257         if (iabs(itype(i+1)).eq.20) iblock=2
7258 C Regular cosine and sine terms
7259         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7260           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7261           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7262           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7263           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7264           cosphi1=dcos(j*phii)
7265           sinphi1=dsin(j*phii)
7266           cosphi2=dcos(j*phii1)
7267           sinphi2=dsin(j*phii1)
7268           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7269      &     v2cij*cosphi2+v2sij*sinphi2
7270           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7271           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7272         enddo
7273         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7274           do l=1,k-1
7275             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7276             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7277             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7278             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7279             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7280             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7281             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7282             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7283             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7284      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7285             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7286      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7287             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7288      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7289           enddo
7290         enddo
7291         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7292         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7293  1215   continue
7294       enddo
7295       return
7296       end
7297 #endif
7298 c---------------------------------------------------------------------------
7299 C The rigorous attempt to derive energy function
7300       subroutine etor_kcc(etors)
7301       implicit real*8 (a-h,o-z)
7302       include 'DIMENSIONS'
7303       include 'DIMENSIONS.ZSCOPT'
7304       include 'COMMON.VAR'
7305       include 'COMMON.GEO'
7306       include 'COMMON.LOCAL'
7307       include 'COMMON.TORSION'
7308       include 'COMMON.INTERACT'
7309       include 'COMMON.DERIV'
7310       include 'COMMON.CHAIN'
7311       include 'COMMON.NAMES'
7312       include 'COMMON.IOUNITS'
7313       include 'COMMON.FFIELD'
7314       include 'COMMON.TORCNSTR'
7315       include 'COMMON.CONTROL'
7316       include 'COMMON.WEIGHTS'
7317       include 'COMMON.WEIGHTDER'
7318       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7319       logical lprn
7320 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7321 C Set lprn=.true. for debugging
7322       lprn=energy_dec
7323 c      lprn=.true.
7324       if (lprn) write (iout,*)"ETOR_KCC"
7325       do iblock=1,2
7326       do i=-ntyp+1,ntyp-1
7327         do j=-ntyp+1,ntyp-1
7328           do k=0,3
7329             do l=0,2*maxterm
7330               etor_temp(l,k,j,i,iblock)=0.0d0
7331             enddo
7332           enddo
7333         enddo
7334       enddo
7335       enddo
7336       do i=-ntyp+1,ntyp-1
7337         do j=-ntyp+1,ntyp-1
7338           do k=0,2*maxtor_kcc
7339             do l=1,maxval_kcc
7340               do ll=1,maxval_kcc
7341                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7342               enddo
7343             enddo
7344           enddo
7345         enddo
7346       enddo
7347       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7348       etors=0.0D0
7349       do i=iphi_start,iphi_end
7350 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7351 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7352 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7353 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7354         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7355      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7356         itori=itortyp(itype(i-2))
7357         itori1=itortyp(itype(i-1))
7358         weitori=weitor(0,itori,itori1,1)
7359         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7360         phii=phi(i)
7361         glocig=0.0D0
7362         glocit1=0.0d0
7363         glocit2=0.0d0
7364 C to avoid multiple devision by 2
7365 c        theti22=0.5d0*theta(i)
7366 C theta 12 is the theta_1 /2
7367 C theta 22 is theta_2 /2
7368 c        theti12=0.5d0*theta(i-1)
7369 C and appropriate sinus function
7370         sinthet1=dsin(theta(i-1))
7371         sinthet2=dsin(theta(i))
7372         costhet1=dcos(theta(i-1))
7373         costhet2=dcos(theta(i))
7374 C to speed up lets store its mutliplication
7375         sint1t2=sinthet2*sinthet1
7376         sint1t2n=1.0d0
7377 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7378 C +d_n*sin(n*gamma)) *
7379 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7380 C we have two sum 1) Non-Chebyshev which is with n and gamma
7381         nval=nterm_kcc_Tb(itori,itori1)
7382         c1(0)=0.0d0
7383         c2(0)=0.0d0
7384         c1(1)=1.0d0
7385         c2(1)=1.0d0
7386         do j=2,nval
7387           c1(j)=c1(j-1)*costhet1
7388           c2(j)=c2(j-1)*costhet2
7389         enddo
7390         etori=0.0d0
7391         do j=1,nterm_kcc(itori,itori1)
7392           cosphi=dcos(j*phii)
7393           sinphi=dsin(j*phii)
7394           sint1t2n1=sint1t2n
7395           sint1t2n=sint1t2n*sint1t2
7396           sumvalc=0.0d0
7397           gradvalct1=0.0d0
7398           gradvalct2=0.0d0
7399           do k=1,nval
7400             do l=1,nval
7401               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7402               etor_temp_kcc(l,k,j,itori,itori1)=
7403      &           etor_temp_kcc(l,k,j,itori,itori1)+
7404      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7405               gradvalct1=gradvalct1+
7406      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7407               gradvalct2=gradvalct2+
7408      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7409             enddo
7410           enddo
7411           gradvalct1=-gradvalct1*sinthet1
7412           gradvalct2=-gradvalct2*sinthet2
7413           sumvals=0.0d0
7414           gradvalst1=0.0d0
7415           gradvalst2=0.0d0
7416           do k=1,nval
7417             do l=1,nval
7418               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7419               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7420      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7421      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7422               gradvalst1=gradvalst1+
7423      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7424               gradvalst2=gradvalst2+
7425      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7426             enddo
7427           enddo
7428           gradvalst1=-gradvalst1*sinthet1
7429           gradvalst2=-gradvalst2*sinthet2
7430           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7431           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7432      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7433 C glocig is the gradient local i site in gamma
7434           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7435 C now gradient over theta_1
7436           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7437      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7438           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7439      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7440         enddo ! j
7441         etors=etors+etori*weitori
7442 C derivative over gamma
7443         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7444 C derivative over theta1
7445         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7446 C now derivative over theta2
7447         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7448         if (lprn)
7449      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7450      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7451       enddo
7452       return
7453       end
7454 c---------------------------------------------------------------------------------------------
7455       subroutine etor_constr(edihcnstr)
7456       implicit real*8 (a-h,o-z)
7457       include 'DIMENSIONS'
7458       include 'DIMENSIONS.ZSCOPT'
7459       include 'COMMON.VAR'
7460       include 'COMMON.GEO'
7461       include 'COMMON.LOCAL'
7462       include 'COMMON.TORSION'
7463       include 'COMMON.INTERACT'
7464       include 'COMMON.DERIV'
7465       include 'COMMON.CHAIN'
7466       include 'COMMON.NAMES'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.FFIELD'
7469       include 'COMMON.TORCNSTR'
7470       include 'COMMON.CONTROL'
7471 ! 6/20/98 - dihedral angle constraints
7472       edihcnstr=0.0d0
7473 c      do i=1,ndih_constr
7474 c      write (iout,*) "idihconstr_start",idihconstr_start,
7475 c     &  " idihconstr_end",idihconstr_end
7476       do i=idihconstr_start,idihconstr_end
7477         itori=idih_constr(i)
7478         phii=phi(itori)
7479         difi=pinorm(phii-phi0(i))
7480         if (difi.gt.drange(i)) then
7481           difi=difi-drange(i)
7482           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7483           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7484         else if (difi.lt.-drange(i)) then
7485           difi=difi+drange(i)
7486           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7487           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7488         else
7489           difi=0.0
7490         endif
7491       enddo
7492       return
7493       end
7494 c----------------------------------------------------------------------------
7495 C The rigorous attempt to derive energy function
7496       subroutine ebend_kcc(etheta)
7497
7498       implicit real*8 (a-h,o-z)
7499       include 'DIMENSIONS'
7500       include 'DIMENSIONS.ZSCOPT'
7501       include 'COMMON.VAR'
7502       include 'COMMON.GEO'
7503       include 'COMMON.LOCAL'
7504       include 'COMMON.TORSION'
7505       include 'COMMON.INTERACT'
7506       include 'COMMON.DERIV'
7507       include 'COMMON.CHAIN'
7508       include 'COMMON.NAMES'
7509       include 'COMMON.IOUNITS'
7510       include 'COMMON.FFIELD'
7511       include 'COMMON.TORCNSTR'
7512       include 'COMMON.CONTROL'
7513       include 'COMMON.WEIGHTDER'
7514       logical lprn
7515       double precision thybt1(maxang_kcc)
7516 C Set lprn=.true. for debugging
7517       lprn=energy_dec
7518 c     lprn=.true.
7519 C      print *,"wchodze kcc"
7520       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7521       do i=0,ntyp
7522         do j=1,maxang_kcc
7523           ebend_temp_kcc(j,i)=0.0d0
7524         enddo
7525       enddo
7526       etheta=0.0D0
7527       do i=ithet_start,ithet_end
7528 c        print *,i,itype(i-1),itype(i),itype(i-2)
7529         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7530      &  .or.itype(i).eq.ntyp1) cycle
7531         iti=iabs(itortyp(itype(i-1)))
7532         sinthet=dsin(theta(i))
7533         costhet=dcos(theta(i))
7534         do j=1,nbend_kcc_Tb(iti)
7535           thybt1(j)=v1bend_chyb(j,iti)
7536           ebend_temp_kcc(j,iabs(iti))=
7537      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7538         enddo
7539         sumth1thyb=v1bend_chyb(0,iti)+
7540      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7541         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7542      &    sumth1thyb
7543         ihelp=nbend_kcc_Tb(iti)-1
7544         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7545         etheta=etheta+sumth1thyb
7546 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7547         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7548       enddo
7549       return
7550       end
7551 c-------------------------------------------------------------------------------------
7552       subroutine etheta_constr(ethetacnstr)
7553
7554       implicit real*8 (a-h,o-z)
7555       include 'DIMENSIONS'
7556       include 'DIMENSIONS.ZSCOPT'
7557       include 'COMMON.VAR'
7558       include 'COMMON.GEO'
7559       include 'COMMON.LOCAL'
7560       include 'COMMON.TORSION'
7561       include 'COMMON.INTERACT'
7562       include 'COMMON.DERIV'
7563       include 'COMMON.CHAIN'
7564       include 'COMMON.NAMES'
7565       include 'COMMON.IOUNITS'
7566       include 'COMMON.FFIELD'
7567       include 'COMMON.TORCNSTR'
7568       include 'COMMON.CONTROL'
7569       ethetacnstr=0.0d0
7570 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7571       do i=ithetaconstr_start,ithetaconstr_end
7572         itheta=itheta_constr(i)
7573         thetiii=theta(itheta)
7574         difi=pinorm(thetiii-theta_constr0(i))
7575         if (difi.gt.theta_drange(i)) then
7576           difi=difi-theta_drange(i)
7577           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7578           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7579      &    +for_thet_constr(i)*difi**3
7580         else if (difi.lt.-drange(i)) then
7581           difi=difi+drange(i)
7582           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7583           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7584      &    +for_thet_constr(i)*difi**3
7585         else
7586           difi=0.0
7587         endif
7588        if (energy_dec) then
7589         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7590      &    i,itheta,rad2deg*thetiii,
7591      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7592      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7593      &    gloc(itheta+nphi-2,icg)
7594         endif
7595       enddo
7596       return
7597       end
7598 c------------------------------------------------------------------------------
7599       subroutine eback_sc_corr(esccor)
7600 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7601 c        conformational states; temporarily implemented as differences
7602 c        between UNRES torsional potentials (dependent on three types of
7603 c        residues) and the torsional potentials dependent on all 20 types
7604 c        of residues computed from AM1 energy surfaces of terminally-blocked
7605 c        amino-acid residues.
7606       implicit real*8 (a-h,o-z)
7607       include 'DIMENSIONS'
7608       include 'DIMENSIONS.ZSCOPT'
7609       include 'COMMON.VAR'
7610       include 'COMMON.GEO'
7611       include 'COMMON.LOCAL'
7612       include 'COMMON.TORSION'
7613       include 'COMMON.SCCOR'
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.CONTROL'
7621       logical lprn
7622 C Set lprn=.true. for debugging
7623       lprn=.false.
7624 c      lprn=.true.
7625 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7626       esccor=0.0D0
7627       do i=itau_start,itau_end
7628         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7629         esccor_ii=0.0D0
7630         isccori=isccortyp(itype(i-2))
7631         isccori1=isccortyp(itype(i-1))
7632         phii=phi(i)
7633         do intertyp=1,3 !intertyp
7634 cc Added 09 May 2012 (Adasko)
7635 cc  Intertyp means interaction type of backbone mainchain correlation:
7636 c   1 = SC...Ca...Ca...Ca
7637 c   2 = Ca...Ca...Ca...SC
7638 c   3 = SC...Ca...Ca...SCi
7639         gloci=0.0D0
7640         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7641      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7642      &      (itype(i-1).eq.ntyp1)))
7643      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7644      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7645      &     .or.(itype(i).eq.ntyp1)))
7646      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7647      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7648      &      (itype(i-3).eq.ntyp1)))) cycle
7649         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7650         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7651      & cycle
7652        do j=1,nterm_sccor(isccori,isccori1)
7653           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7654           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7655           cosphi=dcos(j*tauangle(intertyp,i))
7656           sinphi=dsin(j*tauangle(intertyp,i))
7657            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7658            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7659          enddo
7660 C      write (iout,*)"EBACK_SC_COR",esccor,i
7661 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7662 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7663 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7664         if (lprn)
7665      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7666      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7667      &  (v1sccor(j,1,itori,itori1),j=1,6)
7668      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7669 c        gsccor_loc(i-3)=gloci
7670        enddo !intertyp
7671       enddo
7672       return
7673       end
7674 c------------------------------------------------------------------------------
7675       subroutine multibody(ecorr)
7676 C This subroutine calculates multi-body contributions to energy following
7677 C the idea of Skolnick et al. If side chains I and J make a contact and
7678 C at the same time side chains I+1 and J+1 make a contact, an extra
7679 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7680       implicit real*8 (a-h,o-z)
7681       include 'DIMENSIONS'
7682       include 'DIMENSIONS.ZSCOPT'
7683       include 'COMMON.IOUNITS'
7684       include 'COMMON.DERIV'
7685       include 'COMMON.INTERACT'
7686       include 'COMMON.CONTACTS'
7687       double precision gx(3),gx1(3)
7688       logical lprn
7689
7690 C Set lprn=.true. for debugging
7691       lprn=.false.
7692
7693       if (lprn) then
7694         write (iout,'(a)') 'Contact function values:'
7695         do i=nnt,nct-2
7696           write (iout,'(i2,20(1x,i2,f10.5))')
7697      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7698         enddo
7699       endif
7700       ecorr=0.0D0
7701       do i=nnt,nct
7702         do j=1,3
7703           gradcorr(j,i)=0.0D0
7704           gradxorr(j,i)=0.0D0
7705         enddo
7706       enddo
7707       do i=nnt,nct-2
7708
7709         DO ISHIFT = 3,4
7710
7711         i1=i+ishift
7712         num_conti=num_cont(i)
7713         num_conti1=num_cont(i1)
7714         do jj=1,num_conti
7715           j=jcont(jj,i)
7716           do kk=1,num_conti1
7717             j1=jcont(kk,i1)
7718             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7719 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7720 cd   &                   ' ishift=',ishift
7721 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7722 C The system gains extra energy.
7723               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7724             endif   ! j1==j+-ishift
7725           enddo     ! kk
7726         enddo       ! jj
7727
7728         ENDDO ! ISHIFT
7729
7730       enddo         ! i
7731       return
7732       end
7733 c------------------------------------------------------------------------------
7734       double precision function esccorr(i,j,k,l,jj,kk)
7735       implicit real*8 (a-h,o-z)
7736       include 'DIMENSIONS'
7737       include 'DIMENSIONS.ZSCOPT'
7738       include 'COMMON.IOUNITS'
7739       include 'COMMON.DERIV'
7740       include 'COMMON.INTERACT'
7741       include 'COMMON.CONTACTS'
7742       double precision gx(3),gx1(3)
7743       logical lprn
7744       lprn=.false.
7745       eij=facont(jj,i)
7746       ekl=facont(kk,k)
7747 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7748 C Calculate the multi-body contribution to energy.
7749 C Calculate multi-body contributions to the gradient.
7750 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7751 cd   & k,l,(gacont(m,kk,k),m=1,3)
7752       do m=1,3
7753         gx(m) =ekl*gacont(m,jj,i)
7754         gx1(m)=eij*gacont(m,kk,k)
7755         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7756         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7757         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7758         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7759       enddo
7760       do m=i,j-1
7761         do ll=1,3
7762           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7763         enddo
7764       enddo
7765       do m=k,l-1
7766         do ll=1,3
7767           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7768         enddo
7769       enddo
7770       esccorr=-eij*ekl
7771       return
7772       end
7773 c------------------------------------------------------------------------------
7774       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7775 C This subroutine calculates multi-body contributions to hydrogen-bonding
7776       implicit real*8 (a-h,o-z)
7777       include 'DIMENSIONS'
7778       include 'DIMENSIONS.ZSCOPT'
7779       include 'COMMON.IOUNITS'
7780       include 'COMMON.FFIELD'
7781       include 'COMMON.DERIV'
7782       include 'COMMON.INTERACT'
7783       include 'COMMON.CONTACTS'
7784       double precision gx(3),gx1(3)
7785       logical lprn,ldone
7786
7787 C Set lprn=.true. for debugging
7788       lprn=.false.
7789       if (lprn) then
7790         write (iout,'(a)') 'Contact function values:'
7791         do i=nnt,nct-2
7792           write (iout,'(2i3,50(1x,i2,f5.2))')
7793      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7794      &    j=1,num_cont_hb(i))
7795         enddo
7796       endif
7797       ecorr=0.0D0
7798 C Remove the loop below after debugging !!!
7799       do i=nnt,nct
7800         do j=1,3
7801           gradcorr(j,i)=0.0D0
7802           gradxorr(j,i)=0.0D0
7803         enddo
7804       enddo
7805 C Calculate the local-electrostatic correlation terms
7806       do i=iatel_s,iatel_e+1
7807         i1=i+1
7808         num_conti=num_cont_hb(i)
7809         num_conti1=num_cont_hb(i+1)
7810         do jj=1,num_conti
7811           j=jcont_hb(jj,i)
7812           do kk=1,num_conti1
7813             j1=jcont_hb(kk,i1)
7814 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7815 c     &         ' jj=',jj,' kk=',kk
7816             if (j1.eq.j+1 .or. j1.eq.j-1) then
7817 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7818 C The system gains extra energy.
7819               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7820               n_corr=n_corr+1
7821             else if (j1.eq.j) then
7822 C Contacts I-J and I-(J+1) occur simultaneously.
7823 C The system loses extra energy.
7824 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7825             endif
7826           enddo ! kk
7827           do kk=1,num_conti
7828             j1=jcont_hb(kk,i)
7829 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7830 c    &         ' jj=',jj,' kk=',kk
7831             if (j1.eq.j+1) then
7832 C Contacts I-J and (I+1)-J occur simultaneously.
7833 C The system loses extra energy.
7834 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7835             endif ! j1==j+1
7836           enddo ! kk
7837         enddo ! jj
7838       enddo ! i
7839       return
7840       end
7841 c------------------------------------------------------------------------------
7842       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7843      &  n_corr1)
7844 C This subroutine calculates multi-body contributions to hydrogen-bonding
7845       implicit real*8 (a-h,o-z)
7846       include 'DIMENSIONS'
7847       include 'DIMENSIONS.ZSCOPT'
7848       include 'COMMON.IOUNITS'
7849 #ifdef MPI
7850       include "mpif.h"
7851 #endif
7852       include 'COMMON.FFIELD'
7853       include 'COMMON.DERIV'
7854       include 'COMMON.LOCAL'
7855       include 'COMMON.INTERACT'
7856       include 'COMMON.CONTACTS'
7857       include 'COMMON.CHAIN'
7858       include 'COMMON.CONTROL'
7859       include 'COMMON.SHIELD'
7860       double precision gx(3),gx1(3)
7861       integer num_cont_hb_old(maxres)
7862       logical lprn,ldone
7863       double precision eello4,eello5,eelo6,eello_turn6
7864       external eello4,eello5,eello6,eello_turn6
7865 C Set lprn=.true. for debugging
7866       lprn=.false.
7867       eturn6=0.0d0
7868       if (lprn) then
7869         write (iout,'(a)') 'Contact function values:'
7870         do i=nnt,nct-2
7871           write (iout,'(2i3,50(1x,i2,5f6.3))')
7872      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7873      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7874         enddo
7875       endif
7876       ecorr=0.0D0
7877       ecorr5=0.0d0
7878       ecorr6=0.0d0
7879 C Remove the loop below after debugging !!!
7880       do i=nnt,nct
7881         do j=1,3
7882           gradcorr(j,i)=0.0D0
7883           gradxorr(j,i)=0.0D0
7884         enddo
7885       enddo
7886 C Calculate the dipole-dipole interaction energies
7887       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7888       do i=iatel_s,iatel_e+1
7889         num_conti=num_cont_hb(i)
7890         do jj=1,num_conti
7891           j=jcont_hb(jj,i)
7892 #ifdef MOMENT
7893           call dipole(i,j,jj)
7894 #endif
7895         enddo
7896       enddo
7897       endif
7898 C Calculate the local-electrostatic correlation terms
7899 c                write (iout,*) "gradcorr5 in eello5 before loop"
7900 c                do iii=1,nres
7901 c                  write (iout,'(i5,3f10.5)')
7902 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7903 c                enddo
7904       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7905 c        write (iout,*) "corr loop i",i
7906         i1=i+1
7907         num_conti=num_cont_hb(i)
7908         num_conti1=num_cont_hb(i+1)
7909         do jj=1,num_conti
7910           j=jcont_hb(jj,i)
7911           jp=iabs(j)
7912           do kk=1,num_conti1
7913             j1=jcont_hb(kk,i1)
7914             jp1=iabs(j1)
7915 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7916 c     &         ' jj=',jj,' kk=',kk
7917 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7918             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7919      &          .or. j.lt.0 .and. j1.gt.0) .and.
7920      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7921 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7922 C The system gains extra energy.
7923               n_corr=n_corr+1
7924               sqd1=dsqrt(d_cont(jj,i))
7925               sqd2=dsqrt(d_cont(kk,i1))
7926               sred_geom = sqd1*sqd2
7927               IF (sred_geom.lt.cutoff_corr) THEN
7928                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7929      &            ekont,fprimcont)
7930 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7931 cd     &         ' jj=',jj,' kk=',kk
7932                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7933                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7934                 do l=1,3
7935                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7936                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7937                 enddo
7938                 n_corr1=n_corr1+1
7939 cd               write (iout,*) 'sred_geom=',sred_geom,
7940 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7941 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7942 cd               write (iout,*) "g_contij",g_contij
7943 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7944 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7945                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7946                 if (wcorr4.gt.0.0d0)
7947      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7948 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7949                   if (energy_dec.and.wcorr4.gt.0.0d0)
7950      1                 write (iout,'(a6,4i5,0pf7.3)')
7951      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7952 c                write (iout,*) "gradcorr5 before eello5"
7953 c                do iii=1,nres
7954 c                  write (iout,'(i5,3f10.5)')
7955 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7956 c                enddo
7957                 if (wcorr5.gt.0.0d0)
7958      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7959 c                write (iout,*) "gradcorr5 after eello5"
7960 c                do iii=1,nres
7961 c                  write (iout,'(i5,3f10.5)')
7962 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7963 c                enddo
7964                   if (energy_dec.and.wcorr5.gt.0.0d0)
7965      1                 write (iout,'(a6,4i5,0pf7.3)')
7966      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7967 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7968 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7969                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7970      &               .or. wturn6.eq.0.0d0))then
7971 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7972                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7973                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7974      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7975 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7976 cd     &            'ecorr6=',ecorr6
7977 cd                write (iout,'(4e15.5)') sred_geom,
7978 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7979 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7980 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7981                 else if (wturn6.gt.0.0d0
7982      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7983 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7984                   eturn6=eturn6+eello_turn6(i,jj,kk)
7985                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7986      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7987 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7988                 endif
7989               ENDIF
7990 1111          continue
7991             endif
7992           enddo ! kk
7993         enddo ! jj
7994       enddo ! i
7995       do i=1,nres
7996         num_cont_hb(i)=num_cont_hb_old(i)
7997       enddo
7998 c                write (iout,*) "gradcorr5 in eello5"
7999 c                do iii=1,nres
8000 c                  write (iout,'(i5,3f10.5)')
8001 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8002 c                enddo
8003       return
8004       end
8005 c------------------------------------------------------------------------------
8006       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8007       implicit real*8 (a-h,o-z)
8008       include 'DIMENSIONS'
8009       include 'DIMENSIONS.ZSCOPT'
8010       include 'COMMON.IOUNITS'
8011       include 'COMMON.DERIV'
8012       include 'COMMON.INTERACT'
8013       include 'COMMON.CONTACTS'
8014       include 'COMMON.SHIELD'
8015       include 'COMMON.CONTROL'
8016       double precision gx(3),gx1(3)
8017       logical lprn
8018       lprn=.false.
8019 C      print *,"wchodze",fac_shield(i),shield_mode
8020       eij=facont_hb(jj,i)
8021       ekl=facont_hb(kk,k)
8022       ees0pij=ees0p(jj,i)
8023       ees0pkl=ees0p(kk,k)
8024       ees0mij=ees0m(jj,i)
8025       ees0mkl=ees0m(kk,k)
8026       ekont=eij*ekl
8027       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8028 C*
8029 C     & fac_shield(i)**2*fac_shield(j)**2
8030 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8031 C Following 4 lines for diagnostics.
8032 cd    ees0pkl=0.0D0
8033 cd    ees0pij=1.0D0
8034 cd    ees0mkl=0.0D0
8035 cd    ees0mij=1.0D0
8036 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8037 c     & 'Contacts ',i,j,
8038 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8039 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8040 c     & 'gradcorr_long'
8041 C Calculate the multi-body contribution to energy.
8042 C      ecorr=ecorr+ekont*ees
8043 C Calculate multi-body contributions to the gradient.
8044       coeffpees0pij=coeffp*ees0pij
8045       coeffmees0mij=coeffm*ees0mij
8046       coeffpees0pkl=coeffp*ees0pkl
8047       coeffmees0mkl=coeffm*ees0mkl
8048       do ll=1,3
8049 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8050         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8051      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8052      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8053         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8054      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8055      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8056 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8057         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8058      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8059      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8060         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8061      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8062      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8063         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8064      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8065      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8066         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8067         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8068         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8069      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8070      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8071         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8072         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8073 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8074       enddo
8075 c      write (iout,*)
8076 cgrad      do m=i+1,j-1
8077 cgrad        do ll=1,3
8078 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8079 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8080 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8081 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8082 cgrad        enddo
8083 cgrad      enddo
8084 cgrad      do m=k+1,l-1
8085 cgrad        do ll=1,3
8086 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8087 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8088 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8089 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8090 cgrad        enddo
8091 cgrad      enddo
8092 c      write (iout,*) "ehbcorr",ekont*ees
8093 C      print *,ekont,ees,i,k
8094       ehbcorr=ekont*ees
8095 C now gradient over shielding
8096 C      return
8097       if (shield_mode.gt.0) then
8098        j=ees0plist(jj,i)
8099        l=ees0plist(kk,k)
8100 C        print *,i,j,fac_shield(i),fac_shield(j),
8101 C     &fac_shield(k),fac_shield(l)
8102         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8103      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8104           do ilist=1,ishield_list(i)
8105            iresshield=shield_list(ilist,i)
8106            do m=1,3
8107            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8108 C     &      *2.0
8109            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8110      &              rlocshield
8111      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8112             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8113      &+rlocshield
8114            enddo
8115           enddo
8116           do ilist=1,ishield_list(j)
8117            iresshield=shield_list(ilist,j)
8118            do m=1,3
8119            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8120 C     &     *2.0
8121            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8122      &              rlocshield
8123      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8124            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8125      &     +rlocshield
8126            enddo
8127           enddo
8128
8129           do ilist=1,ishield_list(k)
8130            iresshield=shield_list(ilist,k)
8131            do m=1,3
8132            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8133 C     &     *2.0
8134            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8135      &              rlocshield
8136      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8137            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8138      &     +rlocshield
8139            enddo
8140           enddo
8141           do ilist=1,ishield_list(l)
8142            iresshield=shield_list(ilist,l)
8143            do m=1,3
8144            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8145 C     &     *2.0
8146            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8147      &              rlocshield
8148      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8149            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8150      &     +rlocshield
8151            enddo
8152           enddo
8153 C          print *,gshieldx(m,iresshield)
8154           do m=1,3
8155             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8156      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8157             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8158      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8159             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8160      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8161             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8162      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8163
8164             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8165      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8166             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8167      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8168             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8169      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8170             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8171      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8172
8173            enddo
8174       endif
8175       endif
8176       return
8177       end
8178 #ifdef MOMENT
8179 C---------------------------------------------------------------------------
8180       subroutine dipole(i,j,jj)
8181       implicit real*8 (a-h,o-z)
8182       include 'DIMENSIONS'
8183       include 'DIMENSIONS.ZSCOPT'
8184       include 'COMMON.IOUNITS'
8185       include 'COMMON.CHAIN'
8186       include 'COMMON.FFIELD'
8187       include 'COMMON.DERIV'
8188       include 'COMMON.INTERACT'
8189       include 'COMMON.CONTACTS'
8190       include 'COMMON.TORSION'
8191       include 'COMMON.VAR'
8192       include 'COMMON.GEO'
8193       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8194      &  auxmat(2,2)
8195       iti1 = itortyp(itype(i+1))
8196       if (j.lt.nres-1) then
8197         itj1 = itype2loc(itype(j+1))
8198       else
8199         itj1=nloctyp
8200       endif
8201       do iii=1,2
8202         dipi(iii,1)=Ub2(iii,i)
8203         dipderi(iii)=Ub2der(iii,i)
8204         dipi(iii,2)=b1(iii,i+1)
8205         dipj(iii,1)=Ub2(iii,j)
8206         dipderj(iii)=Ub2der(iii,j)
8207         dipj(iii,2)=b1(iii,j+1)
8208       enddo
8209       kkk=0
8210       do iii=1,2
8211         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8212         do jjj=1,2
8213           kkk=kkk+1
8214           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8215         enddo
8216       enddo
8217       do kkk=1,5
8218         do lll=1,3
8219           mmm=0
8220           do iii=1,2
8221             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8222      &        auxvec(1))
8223             do jjj=1,2
8224               mmm=mmm+1
8225               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8226             enddo
8227           enddo
8228         enddo
8229       enddo
8230       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8231       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8232       do iii=1,2
8233         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8234       enddo
8235       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8236       do iii=1,2
8237         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8238       enddo
8239       return
8240       end
8241 #endif
8242 C---------------------------------------------------------------------------
8243       subroutine calc_eello(i,j,k,l,jj,kk)
8244 C
8245 C This subroutine computes matrices and vectors needed to calculate
8246 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8247 C
8248       implicit real*8 (a-h,o-z)
8249       include 'DIMENSIONS'
8250       include 'DIMENSIONS.ZSCOPT'
8251       include 'COMMON.IOUNITS'
8252       include 'COMMON.CHAIN'
8253       include 'COMMON.DERIV'
8254       include 'COMMON.INTERACT'
8255       include 'COMMON.CONTACTS'
8256       include 'COMMON.TORSION'
8257       include 'COMMON.VAR'
8258       include 'COMMON.GEO'
8259       include 'COMMON.FFIELD'
8260       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8261      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8262       logical lprn
8263       common /kutas/ lprn
8264 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8265 cd     & ' jj=',jj,' kk=',kk
8266 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8267 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8268 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8269       do iii=1,2
8270         do jjj=1,2
8271           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8272           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8273         enddo
8274       enddo
8275       call transpose2(aa1(1,1),aa1t(1,1))
8276       call transpose2(aa2(1,1),aa2t(1,1))
8277       do kkk=1,5
8278         do lll=1,3
8279           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8280      &      aa1tder(1,1,lll,kkk))
8281           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8282      &      aa2tder(1,1,lll,kkk))
8283         enddo
8284       enddo
8285       if (l.eq.j+1) then
8286 C parallel orientation of the two CA-CA-CA frames.
8287         if (i.gt.1) then
8288           iti=itype2loc(itype(i))
8289         else
8290           iti=nloctyp
8291         endif
8292         itk1=itype2loc(itype(k+1))
8293         itj=itype2loc(itype(j))
8294         if (l.lt.nres-1) then
8295           itl1=itype2loc(itype(l+1))
8296         else
8297           itl1=nloctyp
8298         endif
8299 C A1 kernel(j+1) A2T
8300 cd        do iii=1,2
8301 cd          write (iout,'(3f10.5,5x,3f10.5)')
8302 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8303 cd        enddo
8304         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8305      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8306      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8307 C Following matrices are needed only for 6-th order cumulants
8308         IF (wcorr6.gt.0.0d0) THEN
8309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8310      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8311      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8312         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8313      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8314      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8315      &   ADtEAderx(1,1,1,1,1,1))
8316         lprn=.false.
8317         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8318      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8319      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8320      &   ADtEA1derx(1,1,1,1,1,1))
8321         ENDIF
8322 C End 6-th order cumulants
8323 cd        lprn=.false.
8324 cd        if (lprn) then
8325 cd        write (2,*) 'In calc_eello6'
8326 cd        do iii=1,2
8327 cd          write (2,*) 'iii=',iii
8328 cd          do kkk=1,5
8329 cd            write (2,*) 'kkk=',kkk
8330 cd            do jjj=1,2
8331 cd              write (2,'(3(2f10.5),5x)')
8332 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8333 cd            enddo
8334 cd          enddo
8335 cd        enddo
8336 cd        endif
8337         call transpose2(EUgder(1,1,k),auxmat(1,1))
8338         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8339         call transpose2(EUg(1,1,k),auxmat(1,1))
8340         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8341         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8342         do iii=1,2
8343           do kkk=1,5
8344             do lll=1,3
8345               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8346      &          EAEAderx(1,1,lll,kkk,iii,1))
8347             enddo
8348           enddo
8349         enddo
8350 C A1T kernel(i+1) A2
8351         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8352      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8353      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8354 C Following matrices are needed only for 6-th order cumulants
8355         IF (wcorr6.gt.0.0d0) THEN
8356         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8357      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8358      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8359         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8360      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8361      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8362      &   ADtEAderx(1,1,1,1,1,2))
8363         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8364      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8365      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8366      &   ADtEA1derx(1,1,1,1,1,2))
8367         ENDIF
8368 C End 6-th order cumulants
8369         call transpose2(EUgder(1,1,l),auxmat(1,1))
8370         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8371         call transpose2(EUg(1,1,l),auxmat(1,1))
8372         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8373         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8374         do iii=1,2
8375           do kkk=1,5
8376             do lll=1,3
8377               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8378      &          EAEAderx(1,1,lll,kkk,iii,2))
8379             enddo
8380           enddo
8381         enddo
8382 C AEAb1 and AEAb2
8383 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8384 C They are needed only when the fifth- or the sixth-order cumulants are
8385 C indluded.
8386         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8387         call transpose2(AEA(1,1,1),auxmat(1,1))
8388         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8389         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8390         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8391         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8392         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8393         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8394         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8395         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8396         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8397         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8398         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8399         call transpose2(AEA(1,1,2),auxmat(1,1))
8400         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8401         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8402         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8403         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8404         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8405         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8406         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8407         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8408         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8409         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8410         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8411 C Calculate the Cartesian derivatives of the vectors.
8412         do iii=1,2
8413           do kkk=1,5
8414             do lll=1,3
8415               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8416               call matvec2(auxmat(1,1),b1(1,i),
8417      &          AEAb1derx(1,lll,kkk,iii,1,1))
8418               call matvec2(auxmat(1,1),Ub2(1,i),
8419      &          AEAb2derx(1,lll,kkk,iii,1,1))
8420               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8421      &          AEAb1derx(1,lll,kkk,iii,2,1))
8422               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8423      &          AEAb2derx(1,lll,kkk,iii,2,1))
8424               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8425               call matvec2(auxmat(1,1),b1(1,j),
8426      &          AEAb1derx(1,lll,kkk,iii,1,2))
8427               call matvec2(auxmat(1,1),Ub2(1,j),
8428      &          AEAb2derx(1,lll,kkk,iii,1,2))
8429               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8430      &          AEAb1derx(1,lll,kkk,iii,2,2))
8431               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8432      &          AEAb2derx(1,lll,kkk,iii,2,2))
8433             enddo
8434           enddo
8435         enddo
8436         ENDIF
8437 C End vectors
8438       else
8439 C Antiparallel orientation of the two CA-CA-CA frames.
8440         if (i.gt.1) then
8441           iti=itype2loc(itype(i))
8442         else
8443           iti=nloctyp
8444         endif
8445         itk1=itype2loc(itype(k+1))
8446         itl=itype2loc(itype(l))
8447         itj=itype2loc(itype(j))
8448         if (j.lt.nres-1) then
8449           itj1=itype2loc(itype(j+1))
8450         else
8451           itj1=nloctyp
8452         endif
8453 C A2 kernel(j-1)T A1T
8454         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8455      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8456      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8457 C Following matrices are needed only for 6-th order cumulants
8458         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8459      &     j.eq.i+4 .and. l.eq.i+3)) 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,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8462      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8463         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8464      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8465      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8466      &   ADtEAderx(1,1,1,1,1,1))
8467         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8468      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8469      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8470      &   ADtEA1derx(1,1,1,1,1,1))
8471         ENDIF
8472 C End 6-th order cumulants
8473         call transpose2(EUgder(1,1,k),auxmat(1,1))
8474         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8475         call transpose2(EUg(1,1,k),auxmat(1,1))
8476         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8477         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8478         do iii=1,2
8479           do kkk=1,5
8480             do lll=1,3
8481               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8482      &          EAEAderx(1,1,lll,kkk,iii,1))
8483             enddo
8484           enddo
8485         enddo
8486 C A2T kernel(i+1)T A1
8487         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8488      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8489      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8490 C Following matrices are needed only for 6-th order cumulants
8491         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8492      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8493         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8494      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8495      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8496         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8497      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8498      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8499      &   ADtEAderx(1,1,1,1,1,2))
8500         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8501      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8502      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8503      &   ADtEA1derx(1,1,1,1,1,2))
8504         ENDIF
8505 C End 6-th order cumulants
8506         call transpose2(EUgder(1,1,j),auxmat(1,1))
8507         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8508         call transpose2(EUg(1,1,j),auxmat(1,1))
8509         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8510         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8511         do iii=1,2
8512           do kkk=1,5
8513             do lll=1,3
8514               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8515      &          EAEAderx(1,1,lll,kkk,iii,2))
8516             enddo
8517           enddo
8518         enddo
8519 C AEAb1 and AEAb2
8520 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8521 C They are needed only when the fifth- or the sixth-order cumulants are
8522 C indluded.
8523         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8524      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8525         call transpose2(AEA(1,1,1),auxmat(1,1))
8526         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8527         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8528         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8529         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8530         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8531         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8532         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8533         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8534         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8535         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8536         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8537         call transpose2(AEA(1,1,2),auxmat(1,1))
8538         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8539         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8540         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8541         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8542         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8543         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8544         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8545         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8546         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8547         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8548         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8549 C Calculate the Cartesian derivatives of the vectors.
8550         do iii=1,2
8551           do kkk=1,5
8552             do lll=1,3
8553               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8554               call matvec2(auxmat(1,1),b1(1,i),
8555      &          AEAb1derx(1,lll,kkk,iii,1,1))
8556               call matvec2(auxmat(1,1),Ub2(1,i),
8557      &          AEAb2derx(1,lll,kkk,iii,1,1))
8558               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8559      &          AEAb1derx(1,lll,kkk,iii,2,1))
8560               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8561      &          AEAb2derx(1,lll,kkk,iii,2,1))
8562               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8563               call matvec2(auxmat(1,1),b1(1,l),
8564      &          AEAb1derx(1,lll,kkk,iii,1,2))
8565               call matvec2(auxmat(1,1),Ub2(1,l),
8566      &          AEAb2derx(1,lll,kkk,iii,1,2))
8567               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8568      &          AEAb1derx(1,lll,kkk,iii,2,2))
8569               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8570      &          AEAb2derx(1,lll,kkk,iii,2,2))
8571             enddo
8572           enddo
8573         enddo
8574         ENDIF
8575 C End vectors
8576       endif
8577       return
8578       end
8579 C---------------------------------------------------------------------------
8580       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8581      &  KK,KKderg,AKA,AKAderg,AKAderx)
8582       implicit none
8583       integer nderg
8584       logical transp
8585       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8586      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8587      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8588       integer iii,kkk,lll
8589       integer jjj,mmm
8590       logical lprn
8591       common /kutas/ lprn
8592       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8593       do iii=1,nderg
8594         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8595      &    AKAderg(1,1,iii))
8596       enddo
8597 cd      if (lprn) write (2,*) 'In kernel'
8598       do kkk=1,5
8599 cd        if (lprn) write (2,*) 'kkk=',kkk
8600         do lll=1,3
8601           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8602      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8603 cd          if (lprn) then
8604 cd            write (2,*) 'lll=',lll
8605 cd            write (2,*) 'iii=1'
8606 cd            do jjj=1,2
8607 cd              write (2,'(3(2f10.5),5x)')
8608 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8609 cd            enddo
8610 cd          endif
8611           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8612      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8613 cd          if (lprn) then
8614 cd            write (2,*) 'lll=',lll
8615 cd            write (2,*) 'iii=2'
8616 cd            do jjj=1,2
8617 cd              write (2,'(3(2f10.5),5x)')
8618 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8619 cd            enddo
8620 cd          endif
8621         enddo
8622       enddo
8623       return
8624       end
8625 C---------------------------------------------------------------------------
8626       double precision function eello4(i,j,k,l,jj,kk)
8627       implicit real*8 (a-h,o-z)
8628       include 'DIMENSIONS'
8629       include 'DIMENSIONS.ZSCOPT'
8630       include 'COMMON.IOUNITS'
8631       include 'COMMON.CHAIN'
8632       include 'COMMON.DERIV'
8633       include 'COMMON.INTERACT'
8634       include 'COMMON.CONTACTS'
8635       include 'COMMON.TORSION'
8636       include 'COMMON.VAR'
8637       include 'COMMON.GEO'
8638       double precision pizda(2,2),ggg1(3),ggg2(3)
8639 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8640 cd        eello4=0.0d0
8641 cd        return
8642 cd      endif
8643 cd      print *,'eello4:',i,j,k,l,jj,kk
8644 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8645 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8646 cold      eij=facont_hb(jj,i)
8647 cold      ekl=facont_hb(kk,k)
8648 cold      ekont=eij*ekl
8649       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8650       if (calc_grad) then
8651 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8652       gcorr_loc(k-1)=gcorr_loc(k-1)
8653      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8654       if (l.eq.j+1) then
8655         gcorr_loc(l-1)=gcorr_loc(l-1)
8656      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8657       else
8658         gcorr_loc(j-1)=gcorr_loc(j-1)
8659      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8660       endif
8661       do iii=1,2
8662         do kkk=1,5
8663           do lll=1,3
8664             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8665      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8666 cd            derx(lll,kkk,iii)=0.0d0
8667           enddo
8668         enddo
8669       enddo
8670 cd      gcorr_loc(l-1)=0.0d0
8671 cd      gcorr_loc(j-1)=0.0d0
8672 cd      gcorr_loc(k-1)=0.0d0
8673 cd      eel4=1.0d0
8674 cd      write (iout,*)'Contacts have occurred for peptide groups',
8675 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8676 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8677       if (j.lt.nres-1) then
8678         j1=j+1
8679         j2=j-1
8680       else
8681         j1=j-1
8682         j2=j-2
8683       endif
8684       if (l.lt.nres-1) then
8685         l1=l+1
8686         l2=l-1
8687       else
8688         l1=l-1
8689         l2=l-2
8690       endif
8691       do ll=1,3
8692 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8693 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8694         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8695         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8696 cgrad        ghalf=0.5d0*ggg1(ll)
8697         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8698         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8699         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8700         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8701         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8702         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8703 cgrad        ghalf=0.5d0*ggg2(ll)
8704         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8705         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8706         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8707         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8708         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8709         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8710       enddo
8711 cgrad      do m=i+1,j-1
8712 cgrad        do ll=1,3
8713 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8714 cgrad        enddo
8715 cgrad      enddo
8716 cgrad      do m=k+1,l-1
8717 cgrad        do ll=1,3
8718 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8719 cgrad        enddo
8720 cgrad      enddo
8721 cgrad      do m=i+2,j2
8722 cgrad        do ll=1,3
8723 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8724 cgrad        enddo
8725 cgrad      enddo
8726 cgrad      do m=k+2,l2
8727 cgrad        do ll=1,3
8728 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8729 cgrad        enddo
8730 cgrad      enddo
8731 cd      do iii=1,nres-3
8732 cd        write (2,*) iii,gcorr_loc(iii)
8733 cd      enddo
8734       endif ! calc_grad
8735       eello4=ekont*eel4
8736 cd      write (2,*) 'ekont',ekont
8737 cd      write (iout,*) 'eello4',ekont*eel4
8738       return
8739       end
8740 C---------------------------------------------------------------------------
8741       double precision function eello5(i,j,k,l,jj,kk)
8742       implicit real*8 (a-h,o-z)
8743       include 'DIMENSIONS'
8744       include 'DIMENSIONS.ZSCOPT'
8745       include 'COMMON.IOUNITS'
8746       include 'COMMON.CHAIN'
8747       include 'COMMON.DERIV'
8748       include 'COMMON.INTERACT'
8749       include 'COMMON.CONTACTS'
8750       include 'COMMON.TORSION'
8751       include 'COMMON.VAR'
8752       include 'COMMON.GEO'
8753       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8754       double precision ggg1(3),ggg2(3)
8755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8756 C                                                                              C
8757 C                            Parallel chains                                   C
8758 C                                                                              C
8759 C          o             o                   o             o                   C
8760 C         /l\           / \             \   / \           / \   /              C
8761 C        /   \         /   \             \ /   \         /   \ /               C
8762 C       j| o |l1       | o |              o| o |         | o |o                C
8763 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8764 C      \i/   \         /   \ /             /   \         /   \                 C
8765 C       o    k1             o                                                  C
8766 C         (I)          (II)                (III)          (IV)                 C
8767 C                                                                              C
8768 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8769 C                                                                              C
8770 C                            Antiparallel chains                               C
8771 C                                                                              C
8772 C          o             o                   o             o                   C
8773 C         /j\           / \             \   / \           / \   /              C
8774 C        /   \         /   \             \ /   \         /   \ /               C
8775 C      j1| o |l        | o |              o| o |         | o |o                C
8776 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8777 C      \i/   \         /   \ /             /   \         /   \                 C
8778 C       o     k1            o                                                  C
8779 C         (I)          (II)                (III)          (IV)                 C
8780 C                                                                              C
8781 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8782 C                                                                              C
8783 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8784 C                                                                              C
8785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8786 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8787 cd        eello5=0.0d0
8788 cd        return
8789 cd      endif
8790 cd      write (iout,*)
8791 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8792 cd     &   ' and',k,l
8793       itk=itype2loc(itype(k))
8794       itl=itype2loc(itype(l))
8795       itj=itype2loc(itype(j))
8796       eello5_1=0.0d0
8797       eello5_2=0.0d0
8798       eello5_3=0.0d0
8799       eello5_4=0.0d0
8800 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8801 cd     &   eel5_3_num,eel5_4_num)
8802       do iii=1,2
8803         do kkk=1,5
8804           do lll=1,3
8805             derx(lll,kkk,iii)=0.0d0
8806           enddo
8807         enddo
8808       enddo
8809 cd      eij=facont_hb(jj,i)
8810 cd      ekl=facont_hb(kk,k)
8811 cd      ekont=eij*ekl
8812 cd      write (iout,*)'Contacts have occurred for peptide groups',
8813 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8814 cd      goto 1111
8815 C Contribution from the graph I.
8816 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8817 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8818       call transpose2(EUg(1,1,k),auxmat(1,1))
8819       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8820       vv(1)=pizda(1,1)-pizda(2,2)
8821       vv(2)=pizda(1,2)+pizda(2,1)
8822       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8823      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8824       if (calc_grad) then
8825 C Explicit gradient in virtual-dihedral angles.
8826       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8827      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8828      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8829       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8830       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8831       vv(1)=pizda(1,1)-pizda(2,2)
8832       vv(2)=pizda(1,2)+pizda(2,1)
8833       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8834      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8835      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8836       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8837       vv(1)=pizda(1,1)-pizda(2,2)
8838       vv(2)=pizda(1,2)+pizda(2,1)
8839       if (l.eq.j+1) then
8840         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8841      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8842      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8843       else
8844         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8845      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8846      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8847       endif
8848 C Cartesian gradient
8849       do iii=1,2
8850         do kkk=1,5
8851           do lll=1,3
8852             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8853      &        pizda(1,1))
8854             vv(1)=pizda(1,1)-pizda(2,2)
8855             vv(2)=pizda(1,2)+pizda(2,1)
8856             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8857      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8858      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8859           enddo
8860         enddo
8861       enddo
8862       endif ! calc_grad
8863 c      goto 1112
8864 c1111  continue
8865 C Contribution from graph II
8866       call transpose2(EE(1,1,k),auxmat(1,1))
8867       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8868       vv(1)=pizda(1,1)+pizda(2,2)
8869       vv(2)=pizda(2,1)-pizda(1,2)
8870       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8871      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8872       if (calc_grad) then
8873 C Explicit gradient in virtual-dihedral angles.
8874       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8875      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8876       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8877       vv(1)=pizda(1,1)+pizda(2,2)
8878       vv(2)=pizda(2,1)-pizda(1,2)
8879       if (l.eq.j+1) then
8880         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8881      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8882      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8883       else
8884         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8885      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8886      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8887       endif
8888 C Cartesian gradient
8889       do iii=1,2
8890         do kkk=1,5
8891           do lll=1,3
8892             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8893      &        pizda(1,1))
8894             vv(1)=pizda(1,1)+pizda(2,2)
8895             vv(2)=pizda(2,1)-pizda(1,2)
8896             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8897      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8898      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8899           enddo
8900         enddo
8901       enddo
8902       endif ! calc_grad
8903 cd      goto 1112
8904 cd1111  continue
8905       if (l.eq.j+1) then
8906 cd        goto 1110
8907 C Parallel orientation
8908 C Contribution from graph III
8909         call transpose2(EUg(1,1,l),auxmat(1,1))
8910         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8911         vv(1)=pizda(1,1)-pizda(2,2)
8912         vv(2)=pizda(1,2)+pizda(2,1)
8913         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8914      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8915         if (calc_grad) then
8916 C Explicit gradient in virtual-dihedral angles.
8917         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8918      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8919      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8920         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8921         vv(1)=pizda(1,1)-pizda(2,2)
8922         vv(2)=pizda(1,2)+pizda(2,1)
8923         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8924      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8925      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8926         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8927         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8928         vv(1)=pizda(1,1)-pizda(2,2)
8929         vv(2)=pizda(1,2)+pizda(2,1)
8930         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8931      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8932      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8933 C Cartesian gradient
8934         do iii=1,2
8935           do kkk=1,5
8936             do lll=1,3
8937               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8938      &          pizda(1,1))
8939               vv(1)=pizda(1,1)-pizda(2,2)
8940               vv(2)=pizda(1,2)+pizda(2,1)
8941               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8942      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8943      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8944             enddo
8945           enddo
8946         enddo
8947 cd        goto 1112
8948 C Contribution from graph IV
8949 cd1110    continue
8950         call transpose2(EE(1,1,l),auxmat(1,1))
8951         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8952         vv(1)=pizda(1,1)+pizda(2,2)
8953         vv(2)=pizda(2,1)-pizda(1,2)
8954         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8955      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8956 C Explicit gradient in virtual-dihedral angles.
8957         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8958      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8959         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8960         vv(1)=pizda(1,1)+pizda(2,2)
8961         vv(2)=pizda(2,1)-pizda(1,2)
8962         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8963      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8964      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8965 C Cartesian gradient
8966         do iii=1,2
8967           do kkk=1,5
8968             do lll=1,3
8969               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8970      &          pizda(1,1))
8971               vv(1)=pizda(1,1)+pizda(2,2)
8972               vv(2)=pizda(2,1)-pizda(1,2)
8973               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8974      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8975      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8976             enddo
8977           enddo
8978         enddo
8979         endif ! calc_grad
8980       else
8981 C Antiparallel orientation
8982 C Contribution from graph III
8983 c        goto 1110
8984         call transpose2(EUg(1,1,j),auxmat(1,1))
8985         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8986         vv(1)=pizda(1,1)-pizda(2,2)
8987         vv(2)=pizda(1,2)+pizda(2,1)
8988         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8989      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8990         if (calc_grad) then
8991 C Explicit gradient in virtual-dihedral angles.
8992         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8993      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8994      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8995         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8996         vv(1)=pizda(1,1)-pizda(2,2)
8997         vv(2)=pizda(1,2)+pizda(2,1)
8998         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8999      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9000      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9001         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9002         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9003         vv(1)=pizda(1,1)-pizda(2,2)
9004         vv(2)=pizda(1,2)+pizda(2,1)
9005         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9006      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9007      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9008 C Cartesian gradient
9009         do iii=1,2
9010           do kkk=1,5
9011             do lll=1,3
9012               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9013      &          pizda(1,1))
9014               vv(1)=pizda(1,1)-pizda(2,2)
9015               vv(2)=pizda(1,2)+pizda(2,1)
9016               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9017      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9018      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9019             enddo
9020           enddo
9021         enddo
9022         endif ! calc_grad
9023 cd        goto 1112
9024 C Contribution from graph IV
9025 1110    continue
9026         call transpose2(EE(1,1,j),auxmat(1,1))
9027         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9028         vv(1)=pizda(1,1)+pizda(2,2)
9029         vv(2)=pizda(2,1)-pizda(1,2)
9030         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9031      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9032         if (calc_grad) then
9033 C Explicit gradient in virtual-dihedral angles.
9034         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9035      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9036         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9037         vv(1)=pizda(1,1)+pizda(2,2)
9038         vv(2)=pizda(2,1)-pizda(1,2)
9039         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9040      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9041      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9042 C Cartesian gradient
9043         do iii=1,2
9044           do kkk=1,5
9045             do lll=1,3
9046               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9047      &          pizda(1,1))
9048               vv(1)=pizda(1,1)+pizda(2,2)
9049               vv(2)=pizda(2,1)-pizda(1,2)
9050               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9051      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9052      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9053             enddo
9054           enddo
9055         enddo
9056         endif ! calc_grad
9057       endif
9058 1112  continue
9059       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9060 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9061 cd        write (2,*) 'ijkl',i,j,k,l
9062 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9063 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9064 cd      endif
9065 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9066 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9067 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9068 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9069       if (calc_grad) then
9070       if (j.lt.nres-1) then
9071         j1=j+1
9072         j2=j-1
9073       else
9074         j1=j-1
9075         j2=j-2
9076       endif
9077       if (l.lt.nres-1) then
9078         l1=l+1
9079         l2=l-1
9080       else
9081         l1=l-1
9082         l2=l-2
9083       endif
9084 cd      eij=1.0d0
9085 cd      ekl=1.0d0
9086 cd      ekont=1.0d0
9087 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9088 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9089 C        summed up outside the subrouine as for the other subroutines
9090 C        handling long-range interactions. The old code is commented out
9091 C        with "cgrad" to keep track of changes.
9092       do ll=1,3
9093 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9094 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9095         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9096         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9097 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9098 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9099 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9100 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9101 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9102 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9103 c     &   gradcorr5ij,
9104 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9105 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9106 cgrad        ghalf=0.5d0*ggg1(ll)
9107 cd        ghalf=0.0d0
9108         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9109         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9110         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9111         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9112         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9113         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9114 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9115 cgrad        ghalf=0.5d0*ggg2(ll)
9116 cd        ghalf=0.0d0
9117         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9118         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9119         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9120         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9121         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9122         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9123       enddo
9124       endif ! calc_grad
9125 cd      goto 1112
9126 cgrad      do m=i+1,j-1
9127 cgrad        do ll=1,3
9128 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9129 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9130 cgrad        enddo
9131 cgrad      enddo
9132 cgrad      do m=k+1,l-1
9133 cgrad        do ll=1,3
9134 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9135 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9136 cgrad        enddo
9137 cgrad      enddo
9138 c1112  continue
9139 cgrad      do m=i+2,j2
9140 cgrad        do ll=1,3
9141 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9142 cgrad        enddo
9143 cgrad      enddo
9144 cgrad      do m=k+2,l2
9145 cgrad        do ll=1,3
9146 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9147 cgrad        enddo
9148 cgrad      enddo
9149 cd      do iii=1,nres-3
9150 cd        write (2,*) iii,g_corr5_loc(iii)
9151 cd      enddo
9152       eello5=ekont*eel5
9153 cd      write (2,*) 'ekont',ekont
9154 cd      write (iout,*) 'eello5',ekont*eel5
9155       return
9156       end
9157 c--------------------------------------------------------------------------
9158       double precision function eello6(i,j,k,l,jj,kk)
9159       implicit real*8 (a-h,o-z)
9160       include 'DIMENSIONS'
9161       include 'DIMENSIONS.ZSCOPT'
9162       include 'COMMON.IOUNITS'
9163       include 'COMMON.CHAIN'
9164       include 'COMMON.DERIV'
9165       include 'COMMON.INTERACT'
9166       include 'COMMON.CONTACTS'
9167       include 'COMMON.TORSION'
9168       include 'COMMON.VAR'
9169       include 'COMMON.GEO'
9170       include 'COMMON.FFIELD'
9171       double precision ggg1(3),ggg2(3)
9172 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9173 cd        eello6=0.0d0
9174 cd        return
9175 cd      endif
9176 cd      write (iout,*)
9177 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9178 cd     &   ' and',k,l
9179       eello6_1=0.0d0
9180       eello6_2=0.0d0
9181       eello6_3=0.0d0
9182       eello6_4=0.0d0
9183       eello6_5=0.0d0
9184       eello6_6=0.0d0
9185 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9186 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9187       do iii=1,2
9188         do kkk=1,5
9189           do lll=1,3
9190             derx(lll,kkk,iii)=0.0d0
9191           enddo
9192         enddo
9193       enddo
9194 cd      eij=facont_hb(jj,i)
9195 cd      ekl=facont_hb(kk,k)
9196 cd      ekont=eij*ekl
9197 cd      eij=1.0d0
9198 cd      ekl=1.0d0
9199 cd      ekont=1.0d0
9200       if (l.eq.j+1) then
9201         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9202         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9203         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9204         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9205         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9206         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9207       else
9208         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9209         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9210         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9211         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9212         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9213           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9214         else
9215           eello6_5=0.0d0
9216         endif
9217         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9218       endif
9219 C If turn contributions are considered, they will be handled separately.
9220       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9221 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9222 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9223 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9224 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9225 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9226 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9227 cd      goto 1112
9228       if (calc_grad) then
9229       if (j.lt.nres-1) then
9230         j1=j+1
9231         j2=j-1
9232       else
9233         j1=j-1
9234         j2=j-2
9235       endif
9236       if (l.lt.nres-1) then
9237         l1=l+1
9238         l2=l-1
9239       else
9240         l1=l-1
9241         l2=l-2
9242       endif
9243       do ll=1,3
9244 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9245 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9246 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9247 cgrad        ghalf=0.5d0*ggg1(ll)
9248 cd        ghalf=0.0d0
9249         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9250         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9251         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9252         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9253         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9254         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9255         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9256         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9257 cgrad        ghalf=0.5d0*ggg2(ll)
9258 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9259 cd        ghalf=0.0d0
9260         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9261         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9262         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9263         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9264         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9265         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9266       enddo
9267       endif ! calc_grad
9268 cd      goto 1112
9269 cgrad      do m=i+1,j-1
9270 cgrad        do ll=1,3
9271 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9272 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9273 cgrad        enddo
9274 cgrad      enddo
9275 cgrad      do m=k+1,l-1
9276 cgrad        do ll=1,3
9277 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9278 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9279 cgrad        enddo
9280 cgrad      enddo
9281 cgrad1112  continue
9282 cgrad      do m=i+2,j2
9283 cgrad        do ll=1,3
9284 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9285 cgrad        enddo
9286 cgrad      enddo
9287 cgrad      do m=k+2,l2
9288 cgrad        do ll=1,3
9289 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9290 cgrad        enddo
9291 cgrad      enddo
9292 cd      do iii=1,nres-3
9293 cd        write (2,*) iii,g_corr6_loc(iii)
9294 cd      enddo
9295       eello6=ekont*eel6
9296 cd      write (2,*) 'ekont',ekont
9297 cd      write (iout,*) 'eello6',ekont*eel6
9298       return
9299       end
9300 c--------------------------------------------------------------------------
9301       double precision function eello6_graph1(i,j,k,l,imat,swap)
9302       implicit real*8 (a-h,o-z)
9303       include 'DIMENSIONS'
9304       include 'DIMENSIONS.ZSCOPT'
9305       include 'COMMON.IOUNITS'
9306       include 'COMMON.CHAIN'
9307       include 'COMMON.DERIV'
9308       include 'COMMON.INTERACT'
9309       include 'COMMON.CONTACTS'
9310       include 'COMMON.TORSION'
9311       include 'COMMON.VAR'
9312       include 'COMMON.GEO'
9313       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9314       logical swap
9315       logical lprn
9316       common /kutas/ lprn
9317 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9318 C                                                                              C
9319 C      Parallel       Antiparallel                                             C
9320 C                                                                              C
9321 C          o             o                                                     C
9322 C         /l\           /j\                                                    C
9323 C        /   \         /   \                                                   C
9324 C       /| o |         | o |\                                                  C
9325 C     \ j|/k\|  /   \  |/k\|l /                                                C
9326 C      \ /   \ /     \ /   \ /                                                 C
9327 C       o     o       o     o                                                  C
9328 C       i             i                                                        C
9329 C                                                                              C
9330 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9331       itk=itype2loc(itype(k))
9332       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9333       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9334       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9335       call transpose2(EUgC(1,1,k),auxmat(1,1))
9336       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9337       vv1(1)=pizda1(1,1)-pizda1(2,2)
9338       vv1(2)=pizda1(1,2)+pizda1(2,1)
9339       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9340       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9341       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9342       s5=scalar2(vv(1),Dtobr2(1,i))
9343 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9344       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9345       if (calc_grad) then
9346       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9347      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9348      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9349      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9350      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9351      & +scalar2(vv(1),Dtobr2der(1,i)))
9352       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9353       vv1(1)=pizda1(1,1)-pizda1(2,2)
9354       vv1(2)=pizda1(1,2)+pizda1(2,1)
9355       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9356       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9357       if (l.eq.j+1) then
9358         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9359      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9360      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9361      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9362      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9363       else
9364         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9365      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9366      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9367      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9368      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9369       endif
9370       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9371       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9372       vv1(1)=pizda1(1,1)-pizda1(2,2)
9373       vv1(2)=pizda1(1,2)+pizda1(2,1)
9374       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9375      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9376      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9377      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9378       do iii=1,2
9379         if (swap) then
9380           ind=3-iii
9381         else
9382           ind=iii
9383         endif
9384         do kkk=1,5
9385           do lll=1,3
9386             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9387             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9388             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9389             call transpose2(EUgC(1,1,k),auxmat(1,1))
9390             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9391      &        pizda1(1,1))
9392             vv1(1)=pizda1(1,1)-pizda1(2,2)
9393             vv1(2)=pizda1(1,2)+pizda1(2,1)
9394             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9395             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9396      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9397             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9398      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9399             s5=scalar2(vv(1),Dtobr2(1,i))
9400             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9401           enddo
9402         enddo
9403       enddo
9404       endif ! calc_grad
9405       return
9406       end
9407 c----------------------------------------------------------------------------
9408       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9409       implicit real*8 (a-h,o-z)
9410       include 'DIMENSIONS'
9411       include 'DIMENSIONS.ZSCOPT'
9412       include 'COMMON.IOUNITS'
9413       include 'COMMON.CHAIN'
9414       include 'COMMON.DERIV'
9415       include 'COMMON.INTERACT'
9416       include 'COMMON.CONTACTS'
9417       include 'COMMON.TORSION'
9418       include 'COMMON.VAR'
9419       include 'COMMON.GEO'
9420       logical swap
9421       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9422      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9423       logical lprn
9424       common /kutas/ lprn
9425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9426 C                                                                              C
9427 C      Parallel       Antiparallel                                             C
9428 C                                                                              C
9429 C          o             o                                                     C
9430 C     \   /l\           /j\   /                                                C
9431 C      \ /   \         /   \ /                                                 C
9432 C       o| o |         | o |o                                                  C
9433 C     \ j|/k\|      \  |/k\|l                                                  C
9434 C      \ /   \       \ /   \                                                   C
9435 C       o             o                                                        C
9436 C       i             i                                                        C
9437 C                                                                              C
9438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9439 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9440 C AL 7/4/01 s1 would occur in the sixth-order moment,
9441 C           but not in a cluster cumulant
9442 #ifdef MOMENT
9443       s1=dip(1,jj,i)*dip(1,kk,k)
9444 #endif
9445       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9446       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9447       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9448       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9449       call transpose2(EUg(1,1,k),auxmat(1,1))
9450       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9451       vv(1)=pizda(1,1)-pizda(2,2)
9452       vv(2)=pizda(1,2)+pizda(2,1)
9453       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9454 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9455 #ifdef MOMENT
9456       eello6_graph2=-(s1+s2+s3+s4)
9457 #else
9458       eello6_graph2=-(s2+s3+s4)
9459 #endif
9460 c      eello6_graph2=-s3
9461 C Derivatives in gamma(i-1)
9462       if (calc_grad) then
9463       if (i.gt.1) then
9464 #ifdef MOMENT
9465         s1=dipderg(1,jj,i)*dip(1,kk,k)
9466 #endif
9467         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9468         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9469         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9470         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9471 #ifdef MOMENT
9472         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9473 #else
9474         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9475 #endif
9476 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9477       endif
9478 C Derivatives in gamma(k-1)
9479 #ifdef MOMENT
9480       s1=dip(1,jj,i)*dipderg(1,kk,k)
9481 #endif
9482       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9483       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9484       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9485       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9486       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9487       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9488       vv(1)=pizda(1,1)-pizda(2,2)
9489       vv(2)=pizda(1,2)+pizda(2,1)
9490       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9491 #ifdef MOMENT
9492       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9493 #else
9494       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9495 #endif
9496 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9497 C Derivatives in gamma(j-1) or gamma(l-1)
9498       if (j.gt.1) then
9499 #ifdef MOMENT
9500         s1=dipderg(3,jj,i)*dip(1,kk,k)
9501 #endif
9502         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9503         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9504         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9505         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9506         vv(1)=pizda(1,1)-pizda(2,2)
9507         vv(2)=pizda(1,2)+pizda(2,1)
9508         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9509 #ifdef MOMENT
9510         if (swap) then
9511           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9512         else
9513           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9514         endif
9515 #endif
9516         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9517 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9518       endif
9519 C Derivatives in gamma(l-1) or gamma(j-1)
9520       if (l.gt.1) then
9521 #ifdef MOMENT
9522         s1=dip(1,jj,i)*dipderg(3,kk,k)
9523 #endif
9524         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9525         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9526         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9527         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9528         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9529         vv(1)=pizda(1,1)-pizda(2,2)
9530         vv(2)=pizda(1,2)+pizda(2,1)
9531         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9532 #ifdef MOMENT
9533         if (swap) then
9534           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9535         else
9536           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9537         endif
9538 #endif
9539         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9540 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9541       endif
9542 C Cartesian derivatives.
9543       if (lprn) then
9544         write (2,*) 'In eello6_graph2'
9545         do iii=1,2
9546           write (2,*) 'iii=',iii
9547           do kkk=1,5
9548             write (2,*) 'kkk=',kkk
9549             do jjj=1,2
9550               write (2,'(3(2f10.5),5x)')
9551      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9552             enddo
9553           enddo
9554         enddo
9555       endif
9556       do iii=1,2
9557         do kkk=1,5
9558           do lll=1,3
9559 #ifdef MOMENT
9560             if (iii.eq.1) then
9561               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9562             else
9563               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9564             endif
9565 #endif
9566             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9567      &        auxvec(1))
9568             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9569             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9570      &        auxvec(1))
9571             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9572             call transpose2(EUg(1,1,k),auxmat(1,1))
9573             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9574      &        pizda(1,1))
9575             vv(1)=pizda(1,1)-pizda(2,2)
9576             vv(2)=pizda(1,2)+pizda(2,1)
9577             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9578 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9579 #ifdef MOMENT
9580             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9581 #else
9582             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9583 #endif
9584             if (swap) then
9585               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9586             else
9587               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9588             endif
9589           enddo
9590         enddo
9591       enddo
9592       endif ! calc_grad
9593       return
9594       end
9595 c----------------------------------------------------------------------------
9596       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9597       implicit real*8 (a-h,o-z)
9598       include 'DIMENSIONS'
9599       include 'DIMENSIONS.ZSCOPT'
9600       include 'COMMON.IOUNITS'
9601       include 'COMMON.CHAIN'
9602       include 'COMMON.DERIV'
9603       include 'COMMON.INTERACT'
9604       include 'COMMON.CONTACTS'
9605       include 'COMMON.TORSION'
9606       include 'COMMON.VAR'
9607       include 'COMMON.GEO'
9608       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9609       logical swap
9610 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9611 C                                                                              C
9612 C      Parallel       Antiparallel                                             C
9613 C                                                                              C
9614 C          o             o                                                     C
9615 C         /l\   /   \   /j\                                                    C
9616 C        /   \ /     \ /   \                                                   C
9617 C       /| o |o       o| o |\                                                  C
9618 C       j|/k\|  /      |/k\|l /                                                C
9619 C        /   \ /       /   \ /                                                 C
9620 C       /     o       /     o                                                  C
9621 C       i             i                                                        C
9622 C                                                                              C
9623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9624 C
9625 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9626 C           energy moment and not to the cluster cumulant.
9627       iti=itortyp(itype(i))
9628       if (j.lt.nres-1) then
9629         itj1=itype2loc(itype(j+1))
9630       else
9631         itj1=nloctyp
9632       endif
9633       itk=itype2loc(itype(k))
9634       itk1=itype2loc(itype(k+1))
9635       if (l.lt.nres-1) then
9636         itl1=itype2loc(itype(l+1))
9637       else
9638         itl1=nloctyp
9639       endif
9640 #ifdef MOMENT
9641       s1=dip(4,jj,i)*dip(4,kk,k)
9642 #endif
9643       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9644       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9645       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9646       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9647       call transpose2(EE(1,1,k),auxmat(1,1))
9648       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9649       vv(1)=pizda(1,1)+pizda(2,2)
9650       vv(2)=pizda(2,1)-pizda(1,2)
9651       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9652 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9653 cd     & "sum",-(s2+s3+s4)
9654 #ifdef MOMENT
9655       eello6_graph3=-(s1+s2+s3+s4)
9656 #else
9657       eello6_graph3=-(s2+s3+s4)
9658 #endif
9659 c      eello6_graph3=-s4
9660 C Derivatives in gamma(k-1)
9661       if (calc_grad) then
9662       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9663       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9664       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9665       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9666 C Derivatives in gamma(l-1)
9667       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9668       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9669       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9670       vv(1)=pizda(1,1)+pizda(2,2)
9671       vv(2)=pizda(2,1)-pizda(1,2)
9672       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9673       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9674 C Cartesian derivatives.
9675       do iii=1,2
9676         do kkk=1,5
9677           do lll=1,3
9678 #ifdef MOMENT
9679             if (iii.eq.1) then
9680               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9681             else
9682               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9683             endif
9684 #endif
9685             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9686      &        auxvec(1))
9687             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9688             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9689      &        auxvec(1))
9690             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9691             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9692      &        pizda(1,1))
9693             vv(1)=pizda(1,1)+pizda(2,2)
9694             vv(2)=pizda(2,1)-pizda(1,2)
9695             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9696 #ifdef MOMENT
9697             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9698 #else
9699             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9700 #endif
9701             if (swap) then
9702               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9703             else
9704               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9705             endif
9706 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9707           enddo
9708         enddo
9709       enddo
9710       endif ! calc_grad
9711       return
9712       end
9713 c----------------------------------------------------------------------------
9714       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9715       implicit real*8 (a-h,o-z)
9716       include 'DIMENSIONS'
9717       include 'DIMENSIONS.ZSCOPT'
9718       include 'COMMON.IOUNITS'
9719       include 'COMMON.CHAIN'
9720       include 'COMMON.DERIV'
9721       include 'COMMON.INTERACT'
9722       include 'COMMON.CONTACTS'
9723       include 'COMMON.TORSION'
9724       include 'COMMON.VAR'
9725       include 'COMMON.GEO'
9726       include 'COMMON.FFIELD'
9727       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9728      & auxvec1(2),auxmat1(2,2)
9729       logical swap
9730 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9731 C                                                                              C
9732 C      Parallel       Antiparallel                                             C
9733 C                                                                              C
9734 C          o             o                                                     C
9735 C         /l\   /   \   /j\                                                    C
9736 C        /   \ /     \ /   \                                                   C
9737 C       /| o |o       o| o |\                                                  C
9738 C     \ j|/k\|      \  |/k\|l                                                  C
9739 C      \ /   \       \ /   \                                                   C
9740 C       o     \       o     \                                                  C
9741 C       i             i                                                        C
9742 C                                                                              C
9743 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9744 C
9745 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9746 C           energy moment and not to the cluster cumulant.
9747 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9748       iti=itype2loc(itype(i))
9749       itj=itype2loc(itype(j))
9750       if (j.lt.nres-1) then
9751         itj1=itype2loc(itype(j+1))
9752       else
9753         itj1=nloctyp
9754       endif
9755       itk=itype2loc(itype(k))
9756       if (k.lt.nres-1) then
9757         itk1=itype2loc(itype(k+1))
9758       else
9759         itk1=nloctyp
9760       endif
9761       itl=itype2loc(itype(l))
9762       if (l.lt.nres-1) then
9763         itl1=itype2loc(itype(l+1))
9764       else
9765         itl1=nloctyp
9766       endif
9767 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9768 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9769 cd     & ' itl',itl,' itl1',itl1
9770 #ifdef MOMENT
9771       if (imat.eq.1) then
9772         s1=dip(3,jj,i)*dip(3,kk,k)
9773       else
9774         s1=dip(2,jj,j)*dip(2,kk,l)
9775       endif
9776 #endif
9777       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9778       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9779       if (j.eq.l+1) then
9780         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9781         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9782       else
9783         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9784         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9785       endif
9786       call transpose2(EUg(1,1,k),auxmat(1,1))
9787       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9788       vv(1)=pizda(1,1)-pizda(2,2)
9789       vv(2)=pizda(2,1)+pizda(1,2)
9790       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9791 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9792 #ifdef MOMENT
9793       eello6_graph4=-(s1+s2+s3+s4)
9794 #else
9795       eello6_graph4=-(s2+s3+s4)
9796 #endif
9797 C Derivatives in gamma(i-1)
9798       if (calc_grad) then
9799       if (i.gt.1) then
9800 #ifdef MOMENT
9801         if (imat.eq.1) then
9802           s1=dipderg(2,jj,i)*dip(3,kk,k)
9803         else
9804           s1=dipderg(4,jj,j)*dip(2,kk,l)
9805         endif
9806 #endif
9807         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9808         if (j.eq.l+1) then
9809           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9810           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9811         else
9812           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9813           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9814         endif
9815         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9816         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9817 cd          write (2,*) 'turn6 derivatives'
9818 #ifdef MOMENT
9819           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9820 #else
9821           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9822 #endif
9823         else
9824 #ifdef MOMENT
9825           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9826 #else
9827           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9828 #endif
9829         endif
9830       endif
9831 C Derivatives in gamma(k-1)
9832 #ifdef MOMENT
9833       if (imat.eq.1) then
9834         s1=dip(3,jj,i)*dipderg(2,kk,k)
9835       else
9836         s1=dip(2,jj,j)*dipderg(4,kk,l)
9837       endif
9838 #endif
9839       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9840       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9841       if (j.eq.l+1) then
9842         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9843         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9844       else
9845         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9846         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9847       endif
9848       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9849       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9850       vv(1)=pizda(1,1)-pizda(2,2)
9851       vv(2)=pizda(2,1)+pizda(1,2)
9852       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9853       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9854 #ifdef MOMENT
9855         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9856 #else
9857         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9858 #endif
9859       else
9860 #ifdef MOMENT
9861         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9862 #else
9863         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9864 #endif
9865       endif
9866 C Derivatives in gamma(j-1) or gamma(l-1)
9867       if (l.eq.j+1 .and. l.gt.1) then
9868         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9869         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9870         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9871         vv(1)=pizda(1,1)-pizda(2,2)
9872         vv(2)=pizda(2,1)+pizda(1,2)
9873         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9874         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9875       else if (j.gt.1) then
9876         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9877         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9878         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9879         vv(1)=pizda(1,1)-pizda(2,2)
9880         vv(2)=pizda(2,1)+pizda(1,2)
9881         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9882         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9883           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9884         else
9885           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9886         endif
9887       endif
9888 C Cartesian derivatives.
9889       do iii=1,2
9890         do kkk=1,5
9891           do lll=1,3
9892 #ifdef MOMENT
9893             if (iii.eq.1) then
9894               if (imat.eq.1) then
9895                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9896               else
9897                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9898               endif
9899             else
9900               if (imat.eq.1) then
9901                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9902               else
9903                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9904               endif
9905             endif
9906 #endif
9907             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9908      &        auxvec(1))
9909             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9910             if (j.eq.l+1) then
9911               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9912      &          b1(1,j+1),auxvec(1))
9913               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9914             else
9915               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9916      &          b1(1,l+1),auxvec(1))
9917               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9918             endif
9919             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9920      &        pizda(1,1))
9921             vv(1)=pizda(1,1)-pizda(2,2)
9922             vv(2)=pizda(2,1)+pizda(1,2)
9923             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9924             if (swap) then
9925               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9926 #ifdef MOMENT
9927                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9928      &             -(s1+s2+s4)
9929 #else
9930                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9931      &             -(s2+s4)
9932 #endif
9933                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9934               else
9935 #ifdef MOMENT
9936                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9937 #else
9938                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9939 #endif
9940                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9941               endif
9942             else
9943 #ifdef MOMENT
9944               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9945 #else
9946               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9947 #endif
9948               if (l.eq.j+1) then
9949                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9950               else
9951                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9952               endif
9953             endif
9954           enddo
9955         enddo
9956       enddo
9957       endif ! calc_grad
9958       return
9959       end
9960 c----------------------------------------------------------------------------
9961       double precision function eello_turn6(i,jj,kk)
9962       implicit real*8 (a-h,o-z)
9963       include 'DIMENSIONS'
9964       include 'DIMENSIONS.ZSCOPT'
9965       include 'COMMON.IOUNITS'
9966       include 'COMMON.CHAIN'
9967       include 'COMMON.DERIV'
9968       include 'COMMON.INTERACT'
9969       include 'COMMON.CONTACTS'
9970       include 'COMMON.TORSION'
9971       include 'COMMON.VAR'
9972       include 'COMMON.GEO'
9973       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9974      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9975      &  ggg1(3),ggg2(3)
9976       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9977      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9978 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9979 C           the respective energy moment and not to the cluster cumulant.
9980       s1=0.0d0
9981       s8=0.0d0
9982       s13=0.0d0
9983 c
9984       eello_turn6=0.0d0
9985       j=i+4
9986       k=i+1
9987       l=i+3
9988       iti=itype2loc(itype(i))
9989       itk=itype2loc(itype(k))
9990       itk1=itype2loc(itype(k+1))
9991       itl=itype2loc(itype(l))
9992       itj=itype2loc(itype(j))
9993 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9994 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9995 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9996 cd        eello6=0.0d0
9997 cd        return
9998 cd      endif
9999 cd      write (iout,*)
10000 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10001 cd     &   ' and',k,l
10002 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10003       do iii=1,2
10004         do kkk=1,5
10005           do lll=1,3
10006             derx_turn(lll,kkk,iii)=0.0d0
10007           enddo
10008         enddo
10009       enddo
10010 cd      eij=1.0d0
10011 cd      ekl=1.0d0
10012 cd      ekont=1.0d0
10013       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10014 cd      eello6_5=0.0d0
10015 cd      write (2,*) 'eello6_5',eello6_5
10016 #ifdef MOMENT
10017       call transpose2(AEA(1,1,1),auxmat(1,1))
10018       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10019       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10020       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10021 #endif
10022       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10023       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10024       s2 = scalar2(b1(1,k),vtemp1(1))
10025 #ifdef MOMENT
10026       call transpose2(AEA(1,1,2),atemp(1,1))
10027       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10028       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10029       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10030 #endif
10031       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10032       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10033       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10034 #ifdef MOMENT
10035       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10036       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10037       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10038       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10039       ss13 = scalar2(b1(1,k),vtemp4(1))
10040       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10041 #endif
10042 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10043 c      s1=0.0d0
10044 c      s2=0.0d0
10045 c      s8=0.0d0
10046 c      s12=0.0d0
10047 c      s13=0.0d0
10048       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10049 C Derivatives in gamma(i+2)
10050       if (calc_grad) then
10051       s1d =0.0d0
10052       s8d =0.0d0
10053 #ifdef MOMENT
10054       call transpose2(AEA(1,1,1),auxmatd(1,1))
10055       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10056       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10057       call transpose2(AEAderg(1,1,2),atempd(1,1))
10058       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10059       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10060 #endif
10061       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10062       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10063       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10064 c      s1d=0.0d0
10065 c      s2d=0.0d0
10066 c      s8d=0.0d0
10067 c      s12d=0.0d0
10068 c      s13d=0.0d0
10069       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10070 C Derivatives in gamma(i+3)
10071 #ifdef MOMENT
10072       call transpose2(AEA(1,1,1),auxmatd(1,1))
10073       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10074       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10075       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10076 #endif
10077       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10078       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10079       s2d = scalar2(b1(1,k),vtemp1d(1))
10080 #ifdef MOMENT
10081       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10082       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10083 #endif
10084       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10085 #ifdef MOMENT
10086       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10087       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10088       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10089 #endif
10090 c      s1d=0.0d0
10091 c      s2d=0.0d0
10092 c      s8d=0.0d0
10093 c      s12d=0.0d0
10094 c      s13d=0.0d0
10095 #ifdef MOMENT
10096       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10097      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10098 #else
10099       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10100      &               -0.5d0*ekont*(s2d+s12d)
10101 #endif
10102 C Derivatives in gamma(i+4)
10103       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10104       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10105       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10106 #ifdef MOMENT
10107       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10108       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10109       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10110 #endif
10111 c      s1d=0.0d0
10112 c      s2d=0.0d0
10113 c      s8d=0.0d0
10114 C      s12d=0.0d0
10115 c      s13d=0.0d0
10116 #ifdef MOMENT
10117       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10118 #else
10119       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10120 #endif
10121 C Derivatives in gamma(i+5)
10122 #ifdef MOMENT
10123       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10124       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10125       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10126 #endif
10127       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10128       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10129       s2d = scalar2(b1(1,k),vtemp1d(1))
10130 #ifdef MOMENT
10131       call transpose2(AEA(1,1,2),atempd(1,1))
10132       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10133       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10134 #endif
10135       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10136       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10137 #ifdef MOMENT
10138       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10139       ss13d = scalar2(b1(1,k),vtemp4d(1))
10140       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10141 #endif
10142 c      s1d=0.0d0
10143 c      s2d=0.0d0
10144 c      s8d=0.0d0
10145 c      s12d=0.0d0
10146 c      s13d=0.0d0
10147 #ifdef MOMENT
10148       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10149      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10150 #else
10151       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10152      &               -0.5d0*ekont*(s2d+s12d)
10153 #endif
10154 C Cartesian derivatives
10155       do iii=1,2
10156         do kkk=1,5
10157           do lll=1,3
10158 #ifdef MOMENT
10159             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10160             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10161             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10162 #endif
10163             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10164             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10165      &          vtemp1d(1))
10166             s2d = scalar2(b1(1,k),vtemp1d(1))
10167 #ifdef MOMENT
10168             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10169             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10170             s8d = -(atempd(1,1)+atempd(2,2))*
10171      &           scalar2(cc(1,1,l),vtemp2(1))
10172 #endif
10173             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10174      &           auxmatd(1,1))
10175             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10176             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10177 c      s1d=0.0d0
10178 c      s2d=0.0d0
10179 c      s8d=0.0d0
10180 c      s12d=0.0d0
10181 c      s13d=0.0d0
10182 #ifdef MOMENT
10183             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10184      &        - 0.5d0*(s1d+s2d)
10185 #else
10186             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10187      &        - 0.5d0*s2d
10188 #endif
10189 #ifdef MOMENT
10190             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10191      &        - 0.5d0*(s8d+s12d)
10192 #else
10193             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10194      &        - 0.5d0*s12d
10195 #endif
10196           enddo
10197         enddo
10198       enddo
10199 #ifdef MOMENT
10200       do kkk=1,5
10201         do lll=1,3
10202           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10203      &      achuj_tempd(1,1))
10204           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10205           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10206           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10207           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10208           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10209      &      vtemp4d(1))
10210           ss13d = scalar2(b1(1,k),vtemp4d(1))
10211           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10212           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10213         enddo
10214       enddo
10215 #endif
10216 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10217 cd     &  16*eel_turn6_num
10218 cd      goto 1112
10219       if (j.lt.nres-1) then
10220         j1=j+1
10221         j2=j-1
10222       else
10223         j1=j-1
10224         j2=j-2
10225       endif
10226       if (l.lt.nres-1) then
10227         l1=l+1
10228         l2=l-1
10229       else
10230         l1=l-1
10231         l2=l-2
10232       endif
10233       do ll=1,3
10234 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10235 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10236 cgrad        ghalf=0.5d0*ggg1(ll)
10237 cd        ghalf=0.0d0
10238         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10239         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10240         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10241      &    +ekont*derx_turn(ll,2,1)
10242         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10243         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10244      &    +ekont*derx_turn(ll,4,1)
10245         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10246         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10247         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10248 cgrad        ghalf=0.5d0*ggg2(ll)
10249 cd        ghalf=0.0d0
10250         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10251      &    +ekont*derx_turn(ll,2,2)
10252         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10253         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10254      &    +ekont*derx_turn(ll,4,2)
10255         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10256         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10257         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10258       enddo
10259 cd      goto 1112
10260 cgrad      do m=i+1,j-1
10261 cgrad        do ll=1,3
10262 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10263 cgrad        enddo
10264 cgrad      enddo
10265 cgrad      do m=k+1,l-1
10266 cgrad        do ll=1,3
10267 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10268 cgrad        enddo
10269 cgrad      enddo
10270 cgrad1112  continue
10271 cgrad      do m=i+2,j2
10272 cgrad        do ll=1,3
10273 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10274 cgrad        enddo
10275 cgrad      enddo
10276 cgrad      do m=k+2,l2
10277 cgrad        do ll=1,3
10278 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10279 cgrad        enddo
10280 cgrad      enddo
10281 cd      do iii=1,nres-3
10282 cd        write (2,*) iii,g_corr6_loc(iii)
10283 cd      enddo
10284       endif ! calc_grad
10285       eello_turn6=ekont*eel_turn6
10286 cd      write (2,*) 'ekont',ekont
10287 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10288       return
10289       end
10290
10291 crc-------------------------------------------------
10292 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10293       subroutine Eliptransfer(eliptran)
10294       implicit real*8 (a-h,o-z)
10295       include 'DIMENSIONS'
10296       include 'DIMENSIONS.ZSCOPT'
10297       include 'COMMON.GEO'
10298       include 'COMMON.VAR'
10299       include 'COMMON.LOCAL'
10300       include 'COMMON.CHAIN'
10301       include 'COMMON.DERIV'
10302       include 'COMMON.INTERACT'
10303       include 'COMMON.IOUNITS'
10304       include 'COMMON.CALC'
10305       include 'COMMON.CONTROL'
10306       include 'COMMON.SPLITELE'
10307       include 'COMMON.SBRIDGE'
10308 C this is done by Adasko
10309 C      print *,"wchodze"
10310 C structure of box:
10311 C      water
10312 C--bordliptop-- buffore starts
10313 C--bufliptop--- here true lipid starts
10314 C      lipid
10315 C--buflipbot--- lipid ends buffore starts
10316 C--bordlipbot--buffore ends
10317       eliptran=0.0
10318       do i=1,nres
10319 C       do i=1,1
10320         if (itype(i).eq.ntyp1) cycle
10321
10322         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10323         if (positi.le.0) positi=positi+boxzsize
10324 C        print *,i
10325 C first for peptide groups
10326 c for each residue check if it is in lipid or lipid water border area
10327        if ((positi.gt.bordlipbot)
10328      &.and.(positi.lt.bordliptop)) then
10329 C the energy transfer exist
10330         if (positi.lt.buflipbot) then
10331 C what fraction I am in
10332          fracinbuf=1.0d0-
10333      &        ((positi-bordlipbot)/lipbufthick)
10334 C lipbufthick is thickenes of lipid buffore
10335          sslip=sscalelip(fracinbuf)
10336          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10337          eliptran=eliptran+sslip*pepliptran
10338          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10339          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10340 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10341         elseif (positi.gt.bufliptop) then
10342          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10343          sslip=sscalelip(fracinbuf)
10344          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10345          eliptran=eliptran+sslip*pepliptran
10346          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10347          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10348 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10349 C          print *, "doing sscalefor top part"
10350 C         print *,i,sslip,fracinbuf,ssgradlip
10351         else
10352          eliptran=eliptran+pepliptran
10353 C         print *,"I am in true lipid"
10354         endif
10355 C       else
10356 C       eliptran=elpitran+0.0 ! I am in water
10357        endif
10358        enddo
10359 C       print *, "nic nie bylo w lipidzie?"
10360 C now multiply all by the peptide group transfer factor
10361 C       eliptran=eliptran*pepliptran
10362 C now the same for side chains
10363 CV       do i=1,1
10364        do i=1,nres
10365         if (itype(i).eq.ntyp1) cycle
10366         positi=(mod(c(3,i+nres),boxzsize))
10367         if (positi.le.0) positi=positi+boxzsize
10368 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10369 c for each residue check if it is in lipid or lipid water border area
10370 C       respos=mod(c(3,i+nres),boxzsize)
10371 C       print *,positi,bordlipbot,buflipbot
10372        if ((positi.gt.bordlipbot)
10373      & .and.(positi.lt.bordliptop)) then
10374 C the energy transfer exist
10375         if (positi.lt.buflipbot) then
10376          fracinbuf=1.0d0-
10377      &     ((positi-bordlipbot)/lipbufthick)
10378 C lipbufthick is thickenes of lipid buffore
10379          sslip=sscalelip(fracinbuf)
10380          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10381          eliptran=eliptran+sslip*liptranene(itype(i))
10382          gliptranx(3,i)=gliptranx(3,i)
10383      &+ssgradlip*liptranene(itype(i))
10384          gliptranc(3,i-1)= gliptranc(3,i-1)
10385      &+ssgradlip*liptranene(itype(i))
10386 C         print *,"doing sccale for lower part"
10387         elseif (positi.gt.bufliptop) then
10388          fracinbuf=1.0d0-
10389      &((bordliptop-positi)/lipbufthick)
10390          sslip=sscalelip(fracinbuf)
10391          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10392          eliptran=eliptran+sslip*liptranene(itype(i))
10393          gliptranx(3,i)=gliptranx(3,i)
10394      &+ssgradlip*liptranene(itype(i))
10395          gliptranc(3,i-1)= gliptranc(3,i-1)
10396      &+ssgradlip*liptranene(itype(i))
10397 C          print *, "doing sscalefor top part",sslip,fracinbuf
10398         else
10399          eliptran=eliptran+liptranene(itype(i))
10400 C         print *,"I am in true lipid"
10401         endif
10402         endif ! if in lipid or buffor
10403 C       else
10404 C       eliptran=elpitran+0.0 ! I am in water
10405        enddo
10406        return
10407        end
10408
10409
10410 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10411
10412       SUBROUTINE MATVEC2(A1,V1,V2)
10413       implicit real*8 (a-h,o-z)
10414       include 'DIMENSIONS'
10415       DIMENSION A1(2,2),V1(2),V2(2)
10416 c      DO 1 I=1,2
10417 c        VI=0.0
10418 c        DO 3 K=1,2
10419 c    3     VI=VI+A1(I,K)*V1(K)
10420 c        Vaux(I)=VI
10421 c    1 CONTINUE
10422
10423       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10424       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10425
10426       v2(1)=vaux1
10427       v2(2)=vaux2
10428       END
10429 C---------------------------------------
10430       SUBROUTINE MATMAT2(A1,A2,A3)
10431       implicit real*8 (a-h,o-z)
10432       include 'DIMENSIONS'
10433       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10434 c      DIMENSION AI3(2,2)
10435 c        DO  J=1,2
10436 c          A3IJ=0.0
10437 c          DO K=1,2
10438 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10439 c          enddo
10440 c          A3(I,J)=A3IJ
10441 c       enddo
10442 c      enddo
10443
10444       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10445       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10446       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10447       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10448
10449       A3(1,1)=AI3_11
10450       A3(2,1)=AI3_21
10451       A3(1,2)=AI3_12
10452       A3(2,2)=AI3_22
10453       END
10454
10455 c-------------------------------------------------------------------------
10456       double precision function scalar2(u,v)
10457       implicit none
10458       double precision u(2),v(2)
10459       double precision sc
10460       integer i
10461       scalar2=u(1)*v(1)+u(2)*v(2)
10462       return
10463       end
10464
10465 C-----------------------------------------------------------------------------
10466
10467       subroutine transpose2(a,at)
10468       implicit none
10469       double precision a(2,2),at(2,2)
10470       at(1,1)=a(1,1)
10471       at(1,2)=a(2,1)
10472       at(2,1)=a(1,2)
10473       at(2,2)=a(2,2)
10474       return
10475       end
10476 c--------------------------------------------------------------------------
10477       subroutine transpose(n,a,at)
10478       implicit none
10479       integer n,i,j
10480       double precision a(n,n),at(n,n)
10481       do i=1,n
10482         do j=1,n
10483           at(j,i)=a(i,j)
10484         enddo
10485       enddo
10486       return
10487       end
10488 C---------------------------------------------------------------------------
10489       subroutine prodmat3(a1,a2,kk,transp,prod)
10490       implicit none
10491       integer i,j
10492       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10493       logical transp
10494 crc      double precision auxmat(2,2),prod_(2,2)
10495
10496       if (transp) then
10497 crc        call transpose2(kk(1,1),auxmat(1,1))
10498 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10499 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10500
10501            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10502      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10503            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10504      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10505            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10506      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10507            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10508      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10509
10510       else
10511 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10512 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10513
10514            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10515      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10516            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10517      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10518            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10519      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10520            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10521      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10522
10523       endif
10524 c      call transpose2(a2(1,1),a2t(1,1))
10525
10526 crc      print *,transp
10527 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10528 crc      print *,((prod(i,j),i=1,2),j=1,2)
10529
10530       return
10531       end
10532 C-----------------------------------------------------------------------------
10533       double precision function scalar(u,v)
10534       implicit none
10535       double precision u(3),v(3)
10536       double precision sc
10537       integer i
10538       sc=0.0d0
10539       do i=1,3
10540         sc=sc+u(i)*v(i)
10541       enddo
10542       scalar=sc
10543       return
10544       end
10545 C-----------------------------------------------------------------------
10546       double precision function sscale(r)
10547       double precision r,gamm
10548       include "COMMON.SPLITELE"
10549       if(r.lt.r_cut-rlamb) then
10550         sscale=1.0d0
10551       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10552         gamm=(r-(r_cut-rlamb))/rlamb
10553         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10554       else
10555         sscale=0d0
10556       endif
10557       return
10558       end
10559 C-----------------------------------------------------------------------
10560 C-----------------------------------------------------------------------
10561       double precision function sscagrad(r)
10562       double precision r,gamm
10563       include "COMMON.SPLITELE"
10564       if(r.lt.r_cut-rlamb) then
10565         sscagrad=0.0d0
10566       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10567         gamm=(r-(r_cut-rlamb))/rlamb
10568         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10569       else
10570         sscagrad=0.0d0
10571       endif
10572       return
10573       end
10574 C-----------------------------------------------------------------------
10575 C-----------------------------------------------------------------------
10576       double precision function sscalelip(r)
10577       double precision r,gamm
10578       include "COMMON.SPLITELE"
10579 C      if(r.lt.r_cut-rlamb) then
10580 C        sscale=1.0d0
10581 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10582 C        gamm=(r-(r_cut-rlamb))/rlamb
10583         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10584 C      else
10585 C        sscale=0d0
10586 C      endif
10587       return
10588       end
10589 C-----------------------------------------------------------------------
10590       double precision function sscagradlip(r)
10591       double precision r,gamm
10592       include "COMMON.SPLITELE"
10593 C     if(r.lt.r_cut-rlamb) then
10594 C        sscagrad=0.0d0
10595 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10596 C        gamm=(r-(r_cut-rlamb))/rlamb
10597         sscagradlip=r*(6*r-6.0d0)
10598 C      else
10599 C        sscagrad=0.0d0
10600 C      endif
10601       return
10602       end
10603
10604 C-----------------------------------------------------------------------
10605        subroutine set_shield_fac
10606       implicit real*8 (a-h,o-z)
10607       include 'DIMENSIONS'
10608       include 'DIMENSIONS.ZSCOPT'
10609       include 'COMMON.CHAIN'
10610       include 'COMMON.DERIV'
10611       include 'COMMON.IOUNITS'
10612       include 'COMMON.SHIELD'
10613       include 'COMMON.INTERACT'
10614 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10615       double precision div77_81/0.974996043d0/,
10616      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10617
10618 C the vector between center of side_chain and peptide group
10619        double precision pep_side(3),long,side_calf(3),
10620      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10621      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10622 C the line belowe needs to be changed for FGPROC>1
10623       do i=1,nres-1
10624       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10625       ishield_list(i)=0
10626 Cif there two consequtive dummy atoms there is no peptide group between them
10627 C the line below has to be changed for FGPROC>1
10628       VolumeTotal=0.0
10629       do k=1,nres
10630        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10631        dist_pep_side=0.0
10632        dist_side_calf=0.0
10633        do j=1,3
10634 C first lets set vector conecting the ithe side-chain with kth side-chain
10635       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10636 C      pep_side(j)=2.0d0
10637 C and vector conecting the side-chain with its proper calfa
10638       side_calf(j)=c(j,k+nres)-c(j,k)
10639 C      side_calf(j)=2.0d0
10640       pept_group(j)=c(j,i)-c(j,i+1)
10641 C lets have their lenght
10642       dist_pep_side=pep_side(j)**2+dist_pep_side
10643       dist_side_calf=dist_side_calf+side_calf(j)**2
10644       dist_pept_group=dist_pept_group+pept_group(j)**2
10645       enddo
10646        dist_pep_side=dsqrt(dist_pep_side)
10647        dist_pept_group=dsqrt(dist_pept_group)
10648        dist_side_calf=dsqrt(dist_side_calf)
10649       do j=1,3
10650         pep_side_norm(j)=pep_side(j)/dist_pep_side
10651         side_calf_norm(j)=dist_side_calf
10652       enddo
10653 C now sscale fraction
10654        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10655 C       print *,buff_shield,"buff"
10656 C now sscale
10657         if (sh_frac_dist.le.0.0) cycle
10658 C If we reach here it means that this side chain reaches the shielding sphere
10659 C Lets add him to the list for gradient
10660         ishield_list(i)=ishield_list(i)+1
10661 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10662 C this list is essential otherwise problem would be O3
10663         shield_list(ishield_list(i),i)=k
10664 C Lets have the sscale value
10665         if (sh_frac_dist.gt.1.0) then
10666          scale_fac_dist=1.0d0
10667          do j=1,3
10668          sh_frac_dist_grad(j)=0.0d0
10669          enddo
10670         else
10671          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10672      &                   *(2.0*sh_frac_dist-3.0d0)
10673          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10674      &                  /dist_pep_side/buff_shield*0.5
10675 C remember for the final gradient multiply sh_frac_dist_grad(j)
10676 C for side_chain by factor -2 !
10677          do j=1,3
10678          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10679 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10680 C     &                    sh_frac_dist_grad(j)
10681          enddo
10682         endif
10683 C        if ((i.eq.3).and.(k.eq.2)) then
10684 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10685 C     & ,"TU"
10686 C        endif
10687
10688 C this is what is now we have the distance scaling now volume...
10689       short=short_r_sidechain(itype(k))
10690       long=long_r_sidechain(itype(k))
10691       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10692 C now costhet_grad
10693 C       costhet=0.0d0
10694        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10695 C       costhet_fac=0.0d0
10696        do j=1,3
10697          costhet_grad(j)=costhet_fac*pep_side(j)
10698        enddo
10699 C remember for the final gradient multiply costhet_grad(j)
10700 C for side_chain by factor -2 !
10701 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10702 C pep_side0pept_group is vector multiplication
10703       pep_side0pept_group=0.0
10704       do j=1,3
10705       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10706       enddo
10707       cosalfa=(pep_side0pept_group/
10708      & (dist_pep_side*dist_side_calf))
10709       fac_alfa_sin=1.0-cosalfa**2
10710       fac_alfa_sin=dsqrt(fac_alfa_sin)
10711       rkprim=fac_alfa_sin*(long-short)+short
10712 C now costhet_grad
10713        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10714        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10715
10716        do j=1,3
10717          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10718      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10719      &*(long-short)/fac_alfa_sin*cosalfa/
10720      &((dist_pep_side*dist_side_calf))*
10721      &((side_calf(j))-cosalfa*
10722      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10723
10724         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10725      &*(long-short)/fac_alfa_sin*cosalfa
10726      &/((dist_pep_side*dist_side_calf))*
10727      &(pep_side(j)-
10728      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10729        enddo
10730
10731       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10732      &                    /VSolvSphere_div
10733      &                    *wshield
10734 C now the gradient...
10735 C grad_shield is gradient of Calfa for peptide groups
10736 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10737 C     &               costhet,cosphi
10738 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10739 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10740       do j=1,3
10741       grad_shield(j,i)=grad_shield(j,i)
10742 C gradient po skalowaniu
10743      &                +(sh_frac_dist_grad(j)
10744 C  gradient po costhet
10745      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10746      &-scale_fac_dist*(cosphi_grad_long(j))
10747      &/(1.0-cosphi) )*div77_81
10748      &*VofOverlap
10749 C grad_shield_side is Cbeta sidechain gradient
10750       grad_shield_side(j,ishield_list(i),i)=
10751      &        (sh_frac_dist_grad(j)*-2.0d0
10752      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10753      &       +scale_fac_dist*(cosphi_grad_long(j))
10754      &        *2.0d0/(1.0-cosphi))
10755      &        *div77_81*VofOverlap
10756
10757        grad_shield_loc(j,ishield_list(i),i)=
10758      &   scale_fac_dist*cosphi_grad_loc(j)
10759      &        *2.0d0/(1.0-cosphi)
10760      &        *div77_81*VofOverlap
10761       enddo
10762       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10763       enddo
10764       fac_shield(i)=VolumeTotal*div77_81+div4_81
10765 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10766       enddo
10767       return
10768       end
10769 C--------------------------------------------------------------------------
10770 C first for shielding is setting of function of side-chains
10771        subroutine set_shield_fac2
10772       implicit real*8 (a-h,o-z)
10773       include 'DIMENSIONS'
10774       include 'DIMENSIONS.ZSCOPT'
10775       include 'COMMON.CHAIN'
10776       include 'COMMON.DERIV'
10777       include 'COMMON.IOUNITS'
10778       include 'COMMON.SHIELD'
10779       include 'COMMON.INTERACT'
10780 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10781       double precision div77_81/0.974996043d0/,
10782      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10783
10784 C the vector between center of side_chain and peptide group
10785        double precision pep_side(3),long,side_calf(3),
10786      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10787      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10788 C the line belowe needs to be changed for FGPROC>1
10789       do i=1,nres-1
10790       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10791       ishield_list(i)=0
10792 Cif there two consequtive dummy atoms there is no peptide group between them
10793 C the line below has to be changed for FGPROC>1
10794       VolumeTotal=0.0
10795       do k=1,nres
10796        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10797        dist_pep_side=0.0
10798        dist_side_calf=0.0
10799        do j=1,3
10800 C first lets set vector conecting the ithe side-chain with kth side-chain
10801       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10802 C      pep_side(j)=2.0d0
10803 C and vector conecting the side-chain with its proper calfa
10804       side_calf(j)=c(j,k+nres)-c(j,k)
10805 C      side_calf(j)=2.0d0
10806       pept_group(j)=c(j,i)-c(j,i+1)
10807 C lets have their lenght
10808       dist_pep_side=pep_side(j)**2+dist_pep_side
10809       dist_side_calf=dist_side_calf+side_calf(j)**2
10810       dist_pept_group=dist_pept_group+pept_group(j)**2
10811       enddo
10812        dist_pep_side=dsqrt(dist_pep_side)
10813        dist_pept_group=dsqrt(dist_pept_group)
10814        dist_side_calf=dsqrt(dist_side_calf)
10815       do j=1,3
10816         pep_side_norm(j)=pep_side(j)/dist_pep_side
10817         side_calf_norm(j)=dist_side_calf
10818       enddo
10819 C now sscale fraction
10820        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10821 C       print *,buff_shield,"buff"
10822 C now sscale
10823         if (sh_frac_dist.le.0.0) cycle
10824 C If we reach here it means that this side chain reaches the shielding sphere
10825 C Lets add him to the list for gradient
10826         ishield_list(i)=ishield_list(i)+1
10827 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10828 C this list is essential otherwise problem would be O3
10829         shield_list(ishield_list(i),i)=k
10830 C Lets have the sscale value
10831         if (sh_frac_dist.gt.1.0) then
10832          scale_fac_dist=1.0d0
10833          do j=1,3
10834          sh_frac_dist_grad(j)=0.0d0
10835          enddo
10836         else
10837          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10838      &                   *(2.0d0*sh_frac_dist-3.0d0)
10839          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10840      &                  /dist_pep_side/buff_shield*0.5d0
10841 C remember for the final gradient multiply sh_frac_dist_grad(j)
10842 C for side_chain by factor -2 !
10843          do j=1,3
10844          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10845 C         sh_frac_dist_grad(j)=0.0d0
10846 C         scale_fac_dist=1.0d0
10847 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10848 C     &                    sh_frac_dist_grad(j)
10849          enddo
10850         endif
10851 C this is what is now we have the distance scaling now volume...
10852       short=short_r_sidechain(itype(k))
10853       long=long_r_sidechain(itype(k))
10854       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10855       sinthet=short/dist_pep_side*costhet
10856 C now costhet_grad
10857 C       costhet=0.6d0
10858 C       sinthet=0.8
10859        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10860 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10861 C     &             -short/dist_pep_side**2/costhet)
10862 C       costhet_fac=0.0d0
10863        do j=1,3
10864          costhet_grad(j)=costhet_fac*pep_side(j)
10865        enddo
10866 C remember for the final gradient multiply costhet_grad(j)
10867 C for side_chain by factor -2 !
10868 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10869 C pep_side0pept_group is vector multiplication
10870       pep_side0pept_group=0.0d0
10871       do j=1,3
10872       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10873       enddo
10874       cosalfa=(pep_side0pept_group/
10875      & (dist_pep_side*dist_side_calf))
10876       fac_alfa_sin=1.0d0-cosalfa**2
10877       fac_alfa_sin=dsqrt(fac_alfa_sin)
10878       rkprim=fac_alfa_sin*(long-short)+short
10879 C      rkprim=short
10880
10881 C now costhet_grad
10882        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10883 C       cosphi=0.6
10884        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10885        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10886      &      dist_pep_side**2)
10887 C       sinphi=0.8
10888        do j=1,3
10889          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10890      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10891      &*(long-short)/fac_alfa_sin*cosalfa/
10892      &((dist_pep_side*dist_side_calf))*
10893      &((side_calf(j))-cosalfa*
10894      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10895 C       cosphi_grad_long(j)=0.0d0
10896         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10897      &*(long-short)/fac_alfa_sin*cosalfa
10898      &/((dist_pep_side*dist_side_calf))*
10899      &(pep_side(j)-
10900      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10901 C       cosphi_grad_loc(j)=0.0d0
10902        enddo
10903 C      print *,sinphi,sinthet
10904       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10905      &                    /VSolvSphere_div
10906 C     &                    *wshield
10907 C now the gradient...
10908       do j=1,3
10909       grad_shield(j,i)=grad_shield(j,i)
10910 C gradient po skalowaniu
10911      &                +(sh_frac_dist_grad(j)*VofOverlap
10912 C  gradient po costhet
10913      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10914      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10915      &       sinphi/sinthet*costhet*costhet_grad(j)
10916      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10917      & )*wshield
10918 C grad_shield_side is Cbeta sidechain gradient
10919       grad_shield_side(j,ishield_list(i),i)=
10920      &        (sh_frac_dist_grad(j)*-2.0d0
10921      &        *VofOverlap
10922      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10923      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10924      &       sinphi/sinthet*costhet*costhet_grad(j)
10925      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10926      &       )*wshield
10927
10928        grad_shield_loc(j,ishield_list(i),i)=
10929      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10930      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10931      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10932      &        ))
10933      &        *wshield
10934       enddo
10935       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10936       enddo
10937       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10938 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10939 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10940       enddo
10941       return
10942       end
10943 C--------------------------------------------------------------------------
10944       double precision function tschebyshev(m,n,x,y)
10945       implicit none
10946       include "DIMENSIONS"
10947       integer i,m,n
10948       double precision x(n),y,yy(0:maxvar),aux
10949 c Tschebyshev polynomial. Note that the first term is omitted
10950 c m=0: the constant term is included
10951 c m=1: the constant term is not included
10952       yy(0)=1.0d0
10953       yy(1)=y
10954       do i=2,n
10955         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10956       enddo
10957       aux=0.0d0
10958       do i=m,n
10959         aux=aux+x(i)*yy(i)
10960       enddo
10961       tschebyshev=aux
10962       return
10963       end
10964 C--------------------------------------------------------------------------
10965       double precision function gradtschebyshev(m,n,x,y)
10966       implicit none
10967       include "DIMENSIONS"
10968       integer i,m,n
10969       double precision x(n+1),y,yy(0:maxvar),aux
10970 c Tschebyshev polynomial. Note that the first term is omitted
10971 c m=0: the constant term is included
10972 c m=1: the constant term is not included
10973       yy(0)=1.0d0
10974       yy(1)=2.0d0*y
10975       do i=2,n
10976         yy(i)=2*y*yy(i-1)-yy(i-2)
10977       enddo
10978       aux=0.0d0
10979       do i=m,n
10980         aux=aux+x(i+1)*yy(i)*(i+1)
10981 C        print *, x(i+1),yy(i),i
10982       enddo
10983       gradtschebyshev=aux
10984       return
10985       end
10986