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

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       include 'COMMON.WEIGHTS'
  24       include 'COMMON.WEIGHTDER'
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105,106) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 107
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 107
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 107
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 107
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47       goto 107
  48 C New SC-SC potential
  49   106 call emomo(evdw,evdw_p,evdw_m)
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   107 continue
  54       call vec_and_deriv
  55       if (shield_mode.eq.1) then
  56        call set_shield_fac
  57       else if  (shield_mode.eq.2) then
  58        call set_shield_fac2
  59       endif
  60       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  61 C            write(iout,*) 'po eelec'
  62
  63 C Calculate excluded-volume interaction energy between peptide groups
  64 C and side chains.
  65 C
  66       call escp(evdw2,evdw2_14)
  67 c
  68 c Calculate the bond-stretching energy
  69 c
  70
  71       call ebond(estr)
  72 C       write (iout,*) "estr",estr
  73 C
  74 C Calculate the disulfide-bridge and other energy and the contributions
  75 C from other distance constraints.
  76 cd    print *,'Calling EHPB'
  77       call edis(ehpb)
  78 cd    print *,'EHPB exitted succesfully.'
  79 C
  80 C Calculate the virtual-bond-angle energy.
  81 C
  82 C      print *,'Bend energy finished.'
  83       if (wang.gt.0d0) then
  84        if (tor_mode.eq.0) then
  85          call ebend(ebe)
  86        else
  87 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  88 C energy function
  89          call ebend_kcc(ebe)
  90        endif
  91       else
  92         ebe=0.0d0
  93       endif
  94       ethetacnstr=0.0d0
  95       if (with_theta_constr) call etheta_constr(ethetacnstr)
  96 c      call ebend(ebe,ethetacnstr)
  97 cd    print *,'Bend energy finished.'
  98 C
  99 C Calculate the SC local energy.
 100 C
 101       call esc(escloc)
 102 C       print *,'SCLOC energy finished.'
 103 C
 104 C Calculate the virtual-bond torsional energy.
 105 C
 106       if (wtor.gt.0.0d0) then
 107          if (tor_mode.eq.0) then
 108            call etor(etors)
 109          else
 110 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 111 C energy function
 112            call etor_kcc(etors)
 113          endif
 114       else
 115         etors=0.0d0
 116       endif
 117       edihcnstr=0.0d0
 118       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 119 c      print *,"Processor",myrank," computed Utor"
 120 C
 121 C 6/23/01 Calculate double-torsional energy
 122 C
 123       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 124         call etor_d(etors_d)
 125       else
 126         etors_d=0
 127       endif
 128 c      print *,"Processor",myrank," computed Utord"
 129 C
 130       call eback_sc_corr(esccor)
 131
 132       eliptran=0.0d0
 133       if (wliptran.gt.0) then
 134         call Eliptransfer(eliptran)
 135       endif
 136
 137 C
 138 C 12/1/95 Multi-body terms
 139 C
 140       n_corr=0
 141       n_corr1=0
 142       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 143      &    .or. wturn6.gt.0.0d0) then
 144 c         write(iout,*)"calling multibody_eello"
 145          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 146 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 147 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 148       else
 149          ecorr=0.0d0
 150          ecorr5=0.0d0
 151          ecorr6=0.0d0
 152          eturn6=0.0d0
 153       endif
 154       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 155 c         write (iout,*) "Calling multibody_hbond"
 156          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 157       endif
 158 #ifdef SPLITELE
 159       if (shield_mode.gt.0) then
 160       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 161      & +welec*ees
 162      & +wvdwpp*evdw1
 163      & +wang*ebe+wtor*etors+wscloc*escloc
 164      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 165      & +wcorr6*ecorr6+wturn4*eello_turn4
 166      & +wturn3*eello_turn3+wturn6*eturn6
 167      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 168      & +wbond*estr+wsccor*esccor+ethetacnstr
 169      & +wliptran*eliptran
 170       else
 171       etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees
 172      & +wvdwpp*evdw1
 173      & +wang*ebe+wtor*etors+wscloc*escloc
 174      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 175      & +wcorr6*ecorr6+wturn4*eello_turn4
 176      & +wturn3*eello_turn3+wturn6*eturn6
 177      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 178      & +wbond*estr+wsccor*esccor+ethetacnstr
 179      & +wliptran*eliptran
 180       endif
 181 #else
 182       if (shield_mode.gt.0) then
 183       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 184      & +welec*(ees+evdw1)
 185      & +wang*ebe+wtor*etors+wscloc*escloc
 186      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 187      & +wcorr6*ecorr6+wturn4*eello_turn4
 188      & +wturn3*eello_turn3+wturn6*eturn6
 189      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 190      & +wbond*estr+wsccor*esccor+ethetacnstr
 191      & +wliptran*eliptran
 192       else
 193       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 194      & +welec*(ees+evdw1)
 195      & +wang*ebe+wtor*etors+wscloc*escloc
 196      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 197      & +wcorr6*ecorr6+wturn4*eello_turn4
 198      & +wturn3*eello_turn3+wturn6*eturn6
 199      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 200      & +wbond*estr+wsccor*esccor+ethetacnstr
 201      & +wliptran*eliptran
 202       endif
 203 #endif
 204       energia(0)=etot
 205       energia(1)=evdw
 206 #ifdef SCP14
 207       energia(2)=evdw2-evdw2_14
 208       energia(17)=evdw2_14
 209 #else
 210       energia(2)=evdw2
 211       energia(17)=0.0d0
 212 #endif
 213 #ifdef SPLITELE
 214       energia(3)=ees
 215       energia(16)=evdw1
 216 #else
 217       energia(3)=ees+evdw1
 218       energia(16)=0.0d0
 219 #endif
 220       energia(4)=ecorr
 221       energia(5)=ecorr5
 222       energia(6)=ecorr6
 223       energia(7)=eel_loc
 224       energia(8)=eello_turn3
 225       energia(9)=eello_turn4
 226       energia(10)=eturn6
 227       energia(11)=ebe
 228       energia(12)=escloc
 229       energia(13)=etors
 230       energia(14)=etors_d
 231       energia(15)=ehpb
 232       energia(17)=estr
 233       energia(19)=esccor
 234       energia(20)=edihcnstr
 235       energia(21)=evdw_t
 236       energia(24)=ethetacnstr
 237       energia(22)=eliptran
 238 c detecting NaNQ
 239 #ifdef ISNAN
 240 #ifdef AIX
 241       if (isnan(etot).ne.0) energia(0)=1.0d+99
 242 #else
 243       if (isnan(etot)) energia(0)=1.0d+99
 244 #endif
 245 #else
 246       i=0
 247 #ifdef WINPGI
 248       idumm=proc_proc(etot,i)
 249 #else
 250       call proc_proc(etot,i)
 251 #endif
 252       if(i.eq.1)energia(0)=1.0d+99
 253 #endif
 254 #ifdef MPL
 255 c     endif
 256 #endif
 257 #ifdef DEBUG
 258       call enerprint(energia)
 259 #endif
 260       if (calc_grad) then
 261 C
 262 C Sum up the components of the Cartesian gradient.
 263 C
 264 #ifdef SPLITELE
 265       do i=1,nct
 266         do j=1,3
 267       if (shield_mode.eq.0) then
 268           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 269      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 270      &                wbond*gradb(j,i)+
 271      &                wstrain*ghpbc(j,i)+
 272      &                wcorr*gradcorr(j,i)+
 273      &                wel_loc*gel_loc(j,i)+
 274      &                wturn3*gcorr3_turn(j,i)+
 275      &                wturn4*gcorr4_turn(j,i)+
 276      &                wcorr5*gradcorr5(j,i)+
 277      &                wcorr6*gradcorr6(j,i)+
 278      &                wturn6*gcorr6_turn(j,i)+
 279      &                wsccor*gsccorc(j,i)
 280      &               +wliptran*gliptranc(j,i)
 281           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 282      &                  wbond*gradbx(j,i)+
 283      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 284      &                  wsccor*gsccorx(j,i)
 285      &                 +wliptran*gliptranx(j,i)
 286         else
 287           gradc(j,i,icg)=wsc*gvdwc(j,i)
 288      &                +wscp*gvdwc_scp(j,i)+
 289      &               welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 290      &                wbond*gradb(j,i)+
 291      &                wstrain*ghpbc(j,i)+
 292      &                wcorr*gradcorr(j,i)+
 293      &                wel_loc*gel_loc(j,i)+
 294      &                wturn3*gcorr3_turn(j,i)+
 295      &                wturn4*gcorr4_turn(j,i)+
 296      &                wcorr5*gradcorr5(j,i)+
 297      &                wcorr6*gradcorr6(j,i)+
 298      &                wturn6*gcorr6_turn(j,i)+
 299      &                wsccor*gsccorc(j,i)
 300      &               +wliptran*gliptranc(j,i)
 301      &                 +welec*gshieldc(j,i)
 302      &                 +welec*gshieldc_loc(j,i)
 303      &                 +wcorr*gshieldc_ec(j,i)
 304      &                 +wcorr*gshieldc_loc_ec(j,i)
 305      &                 +wturn3*gshieldc_t3(j,i)
 306      &                 +wturn3*gshieldc_loc_t3(j,i)
 307      &                 +wturn4*gshieldc_t4(j,i)
 308      &                 +wturn4*gshieldc_loc_t4(j,i)
 309      &                 +wel_loc*gshieldc_ll(j,i)
 310      &                 +wel_loc*gshieldc_loc_ll(j,i)
 311
 312           gradx(j,i,icg)=wsc*gvdwx(j,i)
 313      &                 +wscp*gradx_scp(j,i)+
 314      &                  wbond*gradbx(j,i)+
 315      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 316      &                  wsccor*gsccorx(j,i)
 317      &                 +wliptran*gliptranx(j,i)
 318      &                 +welec*gshieldx(j,i)
 319      &                 +wcorr*gshieldx_ec(j,i)
 320      &                 +wturn3*gshieldx_t3(j,i)
 321      &                 +wturn4*gshieldx_t4(j,i)
 322      &                 +wel_loc*gshieldx_ll(j,i)
 323
 324
 325         endif
 326         enddo
 327 #else
 328       do i=1,nct
 329         do j=1,3
 330                 if (shield_mode.eq.0) then
 331           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 332      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 333      &                wbond*gradb(j,i)+
 334      &                wcorr*gradcorr(j,i)+
 335      &                wel_loc*gel_loc(j,i)+
 336      &                wturn3*gcorr3_turn(j,i)+
 337      &                wturn4*gcorr4_turn(j,i)+
 338      &                wcorr5*gradcorr5(j,i)+
 339      &                wcorr6*gradcorr6(j,i)+
 340      &                wturn6*gcorr6_turn(j,i)+
 341      &                wsccor*gsccorc(j,i)
 342      &               +wliptran*gliptranc(j,i)
 343           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 344      &                  wbond*gradbx(j,i)+
 345      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 346      &                  wsccor*gsccorx(j,i)
 347      &                 +wliptran*gliptranx(j,i)
 348               else
 349           gradc(j,i,icg)=wsc*gvdwc(j,i)+
 350      &                   wscp*gvdwc_scp(j,i)+
 351      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 352      &                wbond*gradb(j,i)+
 353      &                wcorr*gradcorr(j,i)+
 354      &                wel_loc*gel_loc(j,i)+
 355      &                wturn3*gcorr3_turn(j,i)+
 356      &                wturn4*gcorr4_turn(j,i)+
 357      &                wcorr5*gradcorr5(j,i)+
 358      &                wcorr6*gradcorr6(j,i)+
 359      &                wturn6*gcorr6_turn(j,i)+
 360      &                wsccor*gsccorc(j,i)
 361      &               +wliptran*gliptranc(j,i)
 362      &                 +welec*gshieldc(j,i)
 363      &                 +welec*gshieldc_loc(j,i)
 364      &                 +wcorr*gshieldc_ec(j,i)
 365      &                 +wcorr*gshieldc_loc_ec(j,i)
 366      &                 +wturn3*gshieldc_t3(j,i)
 367      &                 +wturn3*gshieldc_loc_t3(j,i)
 368      &                 +wturn4*gshieldc_t4(j,i)
 369      &                 +wturn4*gshieldc_loc_t4(j,i)
 370      &                 +wel_loc*gshieldc_ll(j,i)
 371      &                 +wel_loc*gshieldc_loc_ll(j,i)
 372
 373           gradx(j,i,icg)=wsc*gvdwx(j,i)+
 374      &                  wscp*gradx_scp(j,i)+
 375      &                  wbond*gradbx(j,i)+
 376      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 377      &                  wsccor*gsccorx(j,i)
 378      &                 +wliptran*gliptranx(j,i)
 379      &                 +welec*gshieldx(j,i)
 380      &                 +wcorr*gshieldx_ec(j,i)
 381      &                 +wturn3*gshieldx_t3(j,i)
 382      &                 +wturn4*gshieldx_t4(j,i)
 383      &                 +wel_loc*gshieldx_ll(j,i)
 384
 385          endif
 386         enddo
 387 #endif
 388       enddo
 389
 390
 391       do i=1,nres-3
 392         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 393      &   +wcorr5*g_corr5_loc(i)
 394      &   +wcorr6*g_corr6_loc(i)
 395      &   +wturn4*gel_loc_turn4(i)
 396      &   +wturn3*gel_loc_turn3(i)
 397      &   +wturn6*gel_loc_turn6(i)
 398      &   +wel_loc*gel_loc_loc(i)
 399 c     &   +wsccor*gsccor_loc(i)
 400 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 401       enddo
 402       endif
 403 c      if (dyn_ss) call dyn_set_nss
 404       return
 405       end
 406 C------------------------------------------------------------------------
 407       subroutine enerprint(energia)
 408       implicit real*8 (a-h,o-z)
 409       include 'DIMENSIONS'
 410       include 'DIMENSIONS.ZSCOPT'
 411       include 'COMMON.IOUNITS'
 412       include 'COMMON.FFIELD'
 413       include 'COMMON.SBRIDGE'
 414       double precision energia(0:max_ene)
 415       etot=energia(0)
 416       evdw=energia(1)+energia(21)
 417 #ifdef SCP14
 418       evdw2=energia(2)+energia(17)
 419 #else
 420       evdw2=energia(2)
 421 #endif
 422       ees=energia(3)
 423 #ifdef SPLITELE
 424       evdw1=energia(16)
 425 #endif
 426       ecorr=energia(4)
 427       ecorr5=energia(5)
 428       ecorr6=energia(6)
 429       eel_loc=energia(7)
 430       eello_turn3=energia(8)
 431       eello_turn4=energia(9)
 432       eello_turn6=energia(10)
 433       ebe=energia(11)
 434       escloc=energia(12)
 435       etors=energia(13)
 436       etors_d=energia(14)
 437       ehpb=energia(15)
 438       esccor=energia(19)
 439       edihcnstr=energia(20)
 440       estr=energia(17)
 441       ethetacnstr=energia(24)
 442       eliptran=energia(22)
 443 #ifdef SPLITELE
 444       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,
 445      &  wvdwpp,
 446      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor,
 447      &  etors_d,wtor_d,ehpb,wstrain,
 448      &  ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6,
 449      &  eel_loc,wel_loc,eello_turn3,wturn3,
 450      &  eello_turn4,wturn4,eello_turn6,wturn6,
 451      &  esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss,
 452      & eliptran,wliptran,etot
 453    10 format (/'Virtual-chain energies:'//
 454      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 455      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 456      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 457      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 458      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 459      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 460      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 461      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 462      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 463      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 464      & ' (SS bridges & dist. cnstr.)'/
 465      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 466      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 467      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 468      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 469      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 470      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 471      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 472      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 473      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 474      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 475      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 476      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 477      & 'ETOT=  ',1pE16.6,' (total)')
 478 #else
 479       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,
 480      &  ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d,
 481      &  ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5,
 482      &  ecorr6,wcorr6,eel_loc,wel_loc,
 483      &  eello_turn3,wturn3,eello_turn4,wturn4,
 484      &  eello_turn6,wturn6,esccor,wsccor,
 485      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 486    10 format (/'Virtual-chain energies:'//
 487      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 488      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 489      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 490      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 491      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 492      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 493      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 494      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 495      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 496      & ' (SS bridges & dist. cnstr.)'/
 497      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 498      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 499      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 500      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 501      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 502      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 503      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 504      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 505      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 506      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 507      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 508      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 509      & 'ETOT=  ',1pE16.6,' (total)')
 510 #endif
 511       return
 512       end
 513 C-----------------------------------------------------------------------
 514       subroutine elj(evdw)
 515 C
 516 C This subroutine calculates the interaction energy of nonbonded side chains
 517 C assuming the LJ potential of interaction.
 518 C
 519       implicit real*8 (a-h,o-z)
 520       include 'DIMENSIONS'
 521       include 'DIMENSIONS.ZSCOPT'
 522       parameter (accur=1.0d-10)
 523       include 'COMMON.GEO'
 524       include 'COMMON.VAR'
 525       include 'COMMON.LOCAL'
 526       include 'COMMON.CHAIN'
 527       include 'COMMON.DERIV'
 528       include 'COMMON.INTERACT'
 529       include 'COMMON.TORSION'
 530       include 'COMMON.WEIGHTDER'
 531       include 'COMMON.SBRIDGE'
 532       include 'COMMON.NAMES'
 533       include 'COMMON.IOUNITS'
 534       include 'COMMON.CONTACTS'
 535       dimension gg(3)
 536       integer icant
 537       external icant
 538 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 539       do i=1,nntyp
 540         do j=1,2
 541           eneps_temp(j,i)=0.0d0
 542         enddo
 543       enddo
 544       evdw=0.0D0
 545       do i=iatsc_s,iatsc_e
 546         itypi=itype(i)
 547         itypi1=itype(i+1)
 548         xi=c(1,nres+i)
 549         yi=c(2,nres+i)
 550         zi=c(3,nres+i)
 551 C Change 12/1/95
 552         num_conti=0
 553 C
 554 C Calculate SC interaction energy.
 555 C
 556         do iint=1,nint_gr(i)
 557 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 558 cd   &                  'iend=',iend(i,iint)
 559           do j=istart(i,iint),iend(i,iint)
 560             itypj=itype(j)
 561             xj=c(1,nres+j)-xi
 562             yj=c(2,nres+j)-yi
 563             zj=c(3,nres+j)-zi
 564 C Change 12/1/95 to calculate four-body interactions
 565             rij=xj*xj+yj*yj+zj*zj
 566             rrij=1.0D0/rij
 567 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 568             eps0ij=eps(itypi,itypj)
 569             fac=rrij**expon2
 570             e1=fac*fac*aa(itypi,itypj)
 571             e2=fac*bb(itypi,itypj)
 572             evdwij=e1+e2
 573             ij=icant(itypi,itypj)
 574             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 575             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 576 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 577 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 578 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 579 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 580 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 581 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 582             evdw=evdw+evdwij
 583             if (calc_grad) then
 584 C
 585 C Calculate the components of the gradient in DC and X
 586 C
 587             fac=-rrij*(e1+evdwij)
 588             gg(1)=xj*fac
 589             gg(2)=yj*fac
 590             gg(3)=zj*fac
 591             do k=1,3
 592               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 593               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 594             enddo
 595             do k=i,j-1
 596               do l=1,3
 597                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 598               enddo
 599             enddo
 600             endif
 601 C
 602 C 12/1/95, revised on 5/20/97
 603 C
 604 C Calculate the contact function. The ith column of the array JCONT will
 605 C contain the numbers of atoms that make contacts with the atom I (of numbers
 606 C greater than I). The arrays FACONT and GACONT will contain the values of
 607 C the contact function and its derivative.
 608 C
 609 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 610 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 611 C Uncomment next line, if the correlation interactions are contact function only
 612             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 613               rij=dsqrt(rij)
 614               sigij=sigma(itypi,itypj)
 615               r0ij=rs0(itypi,itypj)
 616 C
 617 C Check whether the SC's are not too far to make a contact.
 618 C
 619               rcut=1.5d0*r0ij
 620               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 621 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 622 C
 623               if (fcont.gt.0.0D0) then
 624 C If the SC-SC distance if close to sigma, apply spline.
 625 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 626 cAdam &             fcont1,fprimcont1)
 627 cAdam           fcont1=1.0d0-fcont1
 628 cAdam           if (fcont1.gt.0.0d0) then
 629 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 630 cAdam             fcont=fcont*fcont1
 631 cAdam           endif
 632 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 633 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 634 cga             do k=1,3
 635 cga               gg(k)=gg(k)*eps0ij
 636 cga             enddo
 637 cga             eps0ij=-evdwij*eps0ij
 638 C Uncomment for AL's type of SC correlation interactions.
 639 cadam           eps0ij=-evdwij
 640                 num_conti=num_conti+1
 641                 jcont(num_conti,i)=j
 642                 facont(num_conti,i)=fcont*eps0ij
 643                 fprimcont=eps0ij*fprimcont/rij
 644                 fcont=expon*fcont
 645 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 646 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 647 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 648 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 649                 gacont(1,num_conti,i)=-fprimcont*xj
 650                 gacont(2,num_conti,i)=-fprimcont*yj
 651                 gacont(3,num_conti,i)=-fprimcont*zj
 652 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 653 cd              write (iout,'(2i3,3f10.5)')
 654 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 655               endif
 656             endif
 657           enddo      ! j
 658         enddo        ! iint
 659 C Change 12/1/95
 660         num_cont(i)=num_conti
 661       enddo          ! i
 662       if (calc_grad) then
 663       do i=1,nct
 664         do j=1,3
 665           gvdwc(j,i)=expon*gvdwc(j,i)
 666           gvdwx(j,i)=expon*gvdwx(j,i)
 667         enddo
 668       enddo
 669       endif
 670 C******************************************************************************
 671 C
 672 C                              N O T E !!!
 673 C
 674 C To save time, the factor of EXPON has been extracted from ALL components
 675 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 676 C use!
 677 C
 678 C******************************************************************************
 679       return
 680       end
 681 C-----------------------------------------------------------------------------
 682       subroutine eljk(evdw)
 683 C
 684 C This subroutine calculates the interaction energy of nonbonded side chains
 685 C assuming the LJK potential of interaction.
 686 C
 687       implicit real*8 (a-h,o-z)
 688       include 'DIMENSIONS'
 689       include 'DIMENSIONS.ZSCOPT'
 690       include 'COMMON.GEO'
 691       include 'COMMON.VAR'
 692       include 'COMMON.LOCAL'
 693       include 'COMMON.CHAIN'
 694       include 'COMMON.DERIV'
 695       include 'COMMON.INTERACT'
 696       include 'COMMON.WEIGHTDER'
 697       include 'COMMON.IOUNITS'
 698       include 'COMMON.NAMES'
 699       dimension gg(3)
 700       logical scheck
 701       integer icant
 702       external icant
 703 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 704       do i=1,nntyp
 705         do j=1,2
 706           eneps_temp(j,i)=0.0d0
 707         enddo
 708       enddo
 709       evdw=0.0D0
 710       do i=iatsc_s,iatsc_e
 711         itypi=itype(i)
 712         itypi1=itype(i+1)
 713         xi=c(1,nres+i)
 714         yi=c(2,nres+i)
 715         zi=c(3,nres+i)
 716 C
 717 C Calculate SC interaction energy.
 718 C
 719         do iint=1,nint_gr(i)
 720           do j=istart(i,iint),iend(i,iint)
 721             itypj=itype(j)
 722             xj=c(1,nres+j)-xi
 723             yj=c(2,nres+j)-yi
 724             zj=c(3,nres+j)-zi
 725             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 726             fac_augm=rrij**expon
 727             e_augm=augm(itypi,itypj)*fac_augm
 728             r_inv_ij=dsqrt(rrij)
 729             rij=1.0D0/r_inv_ij
 730             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 731             fac=r_shift_inv**expon
 732             e1=fac*fac*aa(itypi,itypj)
 733             e2=fac*bb(itypi,itypj)
 734             evdwij=e_augm+e1+e2
 735             ij=icant(itypi,itypj)
 736             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 737      &        /dabs(eps(itypi,itypj))
 738             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 739 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 740 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 741 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 742 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 743 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 744 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 745 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 746             evdw=evdw+evdwij
 747             if (calc_grad) then
 748 C
 749 C Calculate the components of the gradient in DC and X
 750 C
 751             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 752             gg(1)=xj*fac
 753             gg(2)=yj*fac
 754             gg(3)=zj*fac
 755             do k=1,3
 756               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 757               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 758             enddo
 759             do k=i,j-1
 760               do l=1,3
 761                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 762               enddo
 763             enddo
 764             endif
 765           enddo      ! j
 766         enddo        ! iint
 767       enddo          ! i
 768       if (calc_grad) then
 769       do i=1,nct
 770         do j=1,3
 771           gvdwc(j,i)=expon*gvdwc(j,i)
 772           gvdwx(j,i)=expon*gvdwx(j,i)
 773         enddo
 774       enddo
 775       endif
 776       return
 777       end
 778 C-----------------------------------------------------------------------------
 779       subroutine ebp(evdw)
 780 C
 781 C This subroutine calculates the interaction energy of nonbonded side chains
 782 C assuming the Berne-Pechukas potential of interaction.
 783 C
 784       implicit real*8 (a-h,o-z)
 785       include 'DIMENSIONS'
 786       include 'DIMENSIONS.ZSCOPT'
 787       include 'COMMON.GEO'
 788       include 'COMMON.VAR'
 789       include 'COMMON.LOCAL'
 790       include 'COMMON.CHAIN'
 791       include 'COMMON.DERIV'
 792       include 'COMMON.NAMES'
 793       include 'COMMON.INTERACT'
 794       include 'COMMON.WEIGHTDER'
 795       include 'COMMON.IOUNITS'
 796       include 'COMMON.CALC'
 797       common /srutu/ icall
 798 c     double precision rrsave(maxdim)
 799       logical lprn
 800       integer icant
 801       external icant
 802       do i=1,nntyp
 803         do j=1,2
 804           eneps_temp(j,i)=0.0d0
 805         enddo
 806       enddo
 807       evdw=0.0D0
 808 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 809       evdw=0.0D0
 810 c     if (icall.eq.0) then
 811 c       lprn=.true.
 812 c     else
 813         lprn=.false.
 814 c     endif
 815       ind=0
 816       do i=iatsc_s,iatsc_e
 817         itypi=itype(i)
 818         itypi1=itype(i+1)
 819         xi=c(1,nres+i)
 820         yi=c(2,nres+i)
 821         zi=c(3,nres+i)
 822         dxi=dc_norm(1,nres+i)
 823         dyi=dc_norm(2,nres+i)
 824         dzi=dc_norm(3,nres+i)
 825         dsci_inv=vbld_inv(i+nres)
 826 C
 827 C Calculate SC interaction energy.
 828 C
 829         do iint=1,nint_gr(i)
 830           do j=istart(i,iint),iend(i,iint)
 831             ind=ind+1
 832             itypj=itype(j)
 833             dscj_inv=vbld_inv(j+nres)
 834             chi1=chi(itypi,itypj)
 835             chi2=chi(itypj,itypi)
 836             chi12=chi1*chi2
 837             chip1=chip(itypi)
 838             chip2=chip(itypj)
 839             chip12=chip1*chip2
 840             alf1=alp(itypi)
 841             alf2=alp(itypj)
 842             alf12=0.5D0*(alf1+alf2)
 843 C For diagnostics only!!!
 844 c           chi1=0.0D0
 845 c           chi2=0.0D0
 846 c           chi12=0.0D0
 847 c           chip1=0.0D0
 848 c           chip2=0.0D0
 849 c           chip12=0.0D0
 850 c           alf1=0.0D0
 851 c           alf2=0.0D0
 852 c           alf12=0.0D0
 853             xj=c(1,nres+j)-xi
 854             yj=c(2,nres+j)-yi
 855             zj=c(3,nres+j)-zi
 856             dxj=dc_norm(1,nres+j)
 857             dyj=dc_norm(2,nres+j)
 858             dzj=dc_norm(3,nres+j)
 859             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 860 cd          if (icall.eq.0) then
 861 cd            rrsave(ind)=rrij
 862 cd          else
 863 cd            rrij=rrsave(ind)
 864 cd          endif
 865             rij=dsqrt(rrij)
 866 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 867             call sc_angular
 868 C Calculate whole angle-dependent part of epsilon and contributions
 869 C to its derivatives
 870             fac=(rrij*sigsq)**expon2
 871             e1=fac*fac*aa(itypi,itypj)
 872             e2=fac*bb(itypi,itypj)
 873             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 874             eps2der=evdwij*eps3rt
 875             eps3der=evdwij*eps2rt
 876             evdwij=evdwij*eps2rt*eps3rt
 877             ij=icant(itypi,itypj)
 878             aux=eps1*eps2rt**2*eps3rt**2
 879             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 880      &        /dabs(eps(itypi,itypj))
 881             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 882             evdw=evdw+evdwij
 883             if (calc_grad) then
 884             if (lprn) then
 885             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 886             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 887 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 888 cd     &        restyp(itypi),i,restyp(itypj),j,
 889 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 890 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 891 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 892 cd     &        evdwij
 893             endif
 894 C Calculate gradient components.
 895             e1=e1*eps1*eps2rt**2*eps3rt**2
 896             fac=-expon*(e1+evdwij)
 897             sigder=fac/sigsq
 898             fac=rrij*fac
 899 C Calculate radial part of the gradient
 900             gg(1)=xj*fac
 901             gg(2)=yj*fac
 902             gg(3)=zj*fac
 903 C Calculate the angular part of the gradient and sum add the contributions
 904 C to the appropriate components of the Cartesian gradient.
 905             call sc_grad
 906             endif
 907           enddo      ! j
 908         enddo        ! iint
 909       enddo          ! i
 910 c     stop
 911       return
 912       end
 913 C-----------------------------------------------------------------------------
 914       subroutine egb(evdw)
 915 C
 916 C This subroutine calculates the interaction energy of nonbonded side chains
 917 C assuming the Gay-Berne potential of interaction.
 918 C
 919       implicit real*8 (a-h,o-z)
 920       include 'DIMENSIONS'
 921       include 'DIMENSIONS.ZSCOPT'
 922       include 'COMMON.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         itypi1=itype(i+1)
 950         xi=c(1,nres+i)
 951         yi=c(2,nres+i)
 952         zi=c(3,nres+i)
 953         dxi=dc_norm(1,nres+i)
 954         dyi=dc_norm(2,nres+i)
 955         dzi=dc_norm(3,nres+i)
 956         dsci_inv=vbld_inv(i+nres)
 957 C
 958 C Calculate SC interaction energy.
 959 C
 960         do iint=1,nint_gr(i)
 961           do j=istart(i,iint),iend(i,iint)
 962             ind=ind+1
 963             itypj=itype(j)
 964             dscj_inv=vbld_inv(j+nres)
 965             sig0ij=sigma(itypi,itypj)
 966             chi1=chi(itypi,itypj)
 967             chi2=chi(itypj,itypi)
 968             chi12=chi1*chi2
 969             chip1=chip(itypi)
 970             chip2=chip(itypj)
 971             chip12=chip1*chip2
 972             alf1=alp(itypi)
 973             alf2=alp(itypj)
 974             alf12=0.5D0*(alf1+alf2)
 975 C For diagnostics only!!!
 976 c           chi1=0.0D0
 977 c           chi2=0.0D0
 978 c           chi12=0.0D0
 979 c           chip1=0.0D0
 980 c           chip2=0.0D0
 981 c           chip12=0.0D0
 982 c           alf1=0.0D0
 983 c           alf2=0.0D0
 984 c           alf12=0.0D0
 985             xj=c(1,nres+j)-xi
 986             yj=c(2,nres+j)-yi
 987             zj=c(3,nres+j)-zi
 988             dxj=dc_norm(1,nres+j)
 989             dyj=dc_norm(2,nres+j)
 990             dzj=dc_norm(3,nres+j)
 991 c            write (iout,*) i,j,xj,yj,zj
 992             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 993             rij=dsqrt(rrij)
 994 C Calculate angle-dependent terms of energy and contributions to their
 995 C derivatives.
 996             call sc_angular
 997             sigsq=1.0D0/sigsq
 998             sig=sig0ij*dsqrt(sigsq)
 999             rij_shift=1.0D0/rij-sig+sig0ij
1000 C I hate to put IF's in the loops, but here don't have another choice!!!!
1001             if (rij_shift.le.0.0D0) then
1002               evdw=1.0D20
1003               return
1004             endif
1005             sigder=-sig*sigsq
1006 c---------------------------------------------------------------
1007             rij_shift=1.0D0/rij_shift
1008             fac=rij_shift**expon
1009             e1=fac*fac*aa(itypi,itypj)
1010             e2=fac*bb(itypi,itypj)
1011             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1012             eps2der=evdwij*eps3rt
1013             eps3der=evdwij*eps2rt
1014             evdwij=evdwij*eps2rt*eps3rt
1015             evdw=evdw+evdwij
1016             ij=icant(itypi,itypj)
1017             aux=eps1*eps2rt**2*eps3rt**2
1018 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1019 c     &        /dabs(eps(itypi,itypj))
1020 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1021 c-----------------------
1022             eps0ij=eps(itypi,itypj)
1023             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1024             rr0ij=r0(itypi,itypj)
1025             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1026 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1027 c-----------------------
1028 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1029 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1030 c     &         aux*e2/eps(itypi,itypj)
1031             if (lprn) then
1032             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1033             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1034             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1035      &        restyp(itypi),i,restyp(itypj),j,
1036      &        epsi,sigm,chi1,chi2,chip1,chip2,
1037      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1038      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1039      &        evdwij
1040             endif
1041             if (calc_grad) then
1042 C Calculate gradient components.
1043             e1=e1*eps1*eps2rt**2*eps3rt**2
1044             fac=-expon*(e1+evdwij)*rij_shift
1045             sigder=fac*sigder
1046             fac=rij*fac
1047 C Calculate the radial part of the gradient
1048             gg(1)=xj*fac
1049             gg(2)=yj*fac
1050             gg(3)=zj*fac
1051 C Calculate angular part of the gradient.
1052             call sc_grad
1053             endif
1054           enddo      ! j
1055         enddo        ! iint
1056       enddo          ! i
1057       return
1058       end
1059 C-----------------------------------------------------------------------------
1060       subroutine egbv(evdw)
1061 C
1062 C This subroutine calculates the interaction energy of nonbonded side chains
1063 C assuming the Gay-Berne-Vorobjev potential of interaction.
1064 C
1065       implicit real*8 (a-h,o-z)
1066       include 'DIMENSIONS'
1067       include 'DIMENSIONS.ZSCOPT'
1068       include 'COMMON.GEO'
1069       include 'COMMON.VAR'
1070       include 'COMMON.LOCAL'
1071       include 'COMMON.CHAIN'
1072       include 'COMMON.DERIV'
1073       include 'COMMON.NAMES'
1074       include 'COMMON.INTERACT'
1075       include 'COMMON.WEIGHTDER'
1076       include 'COMMON.IOUNITS'
1077       include 'COMMON.CALC'
1078       common /srutu/ icall
1079       logical lprn
1080       integer icant
1081       external icant
1082       do i=1,nntyp
1083         do j=1,2
1084           eneps_temp(j,i)=0.0d0
1085         enddo
1086       enddo
1087       evdw=0.0D0
1088 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1089       evdw=0.0D0
1090       lprn=.false.
1091 c      if (icall.gt.0) lprn=.true.
1092       ind=0
1093       do i=iatsc_s,iatsc_e
1094         itypi=itype(i)
1095         itypi1=itype(i+1)
1096         xi=c(1,nres+i)
1097         yi=c(2,nres+i)
1098         zi=c(3,nres+i)
1099         dxi=dc_norm(1,nres+i)
1100         dyi=dc_norm(2,nres+i)
1101         dzi=dc_norm(3,nres+i)
1102         dsci_inv=vbld_inv(i+nres)
1103 C
1104 C Calculate SC interaction energy.
1105 C
1106         do iint=1,nint_gr(i)
1107           do j=istart(i,iint),iend(i,iint)
1108             ind=ind+1
1109             itypj=itype(j)
1110             dscj_inv=vbld_inv(j+nres)
1111             sig0ij=sigma(itypi,itypj)
1112             r0ij=r0(itypi,itypj)
1113             chi1=chi(itypi,itypj)
1114             chi2=chi(itypj,itypi)
1115             chi12=chi1*chi2
1116             chip1=chip(itypi)
1117             chip2=chip(itypj)
1118             chip12=chip1*chip2
1119             alf1=alp(itypi)
1120             alf2=alp(itypj)
1121             alf12=0.5D0*(alf1+alf2)
1122 C For diagnostics only!!!
1123 c           chi1=0.0D0
1124 c           chi2=0.0D0
1125 c           chi12=0.0D0
1126 c           chip1=0.0D0
1127 c           chip2=0.0D0
1128 c           chip12=0.0D0
1129 c           alf1=0.0D0
1130 c           alf2=0.0D0
1131 c           alf12=0.0D0
1132             xj=c(1,nres+j)-xi
1133             yj=c(2,nres+j)-yi
1134             zj=c(3,nres+j)-zi
1135             dxj=dc_norm(1,nres+j)
1136             dyj=dc_norm(2,nres+j)
1137             dzj=dc_norm(3,nres+j)
1138             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1139             rij=dsqrt(rrij)
1140 C Calculate angle-dependent terms of energy and contributions to their
1141 C derivatives.
1142             call sc_angular
1143             sigsq=1.0D0/sigsq
1144             sig=sig0ij*dsqrt(sigsq)
1145             rij_shift=1.0D0/rij-sig+r0ij
1146 C I hate to put IF's in the loops, but here don't have another choice!!!!
1147             if (rij_shift.le.0.0D0) then
1148               evdw=1.0D20
1149               return
1150             endif
1151             sigder=-sig*sigsq
1152 c---------------------------------------------------------------
1153             rij_shift=1.0D0/rij_shift
1154             fac=rij_shift**expon
1155             e1=fac*fac*aa(itypi,itypj)
1156             e2=fac*bb(itypi,itypj)
1157             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1158             eps2der=evdwij*eps3rt
1159             eps3der=evdwij*eps2rt
1160             fac_augm=rrij**expon
1161             e_augm=augm(itypi,itypj)*fac_augm
1162             evdwij=evdwij*eps2rt*eps3rt
1163             evdw=evdw+evdwij+e_augm
1164             ij=icant(itypi,itypj)
1165             aux=eps1*eps2rt**2*eps3rt**2
1166             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1167      &        /dabs(eps(itypi,itypj))
1168             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1169 c            eneps_temp(ij)=eneps_temp(ij)
1170 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1171 c            if (lprn) then
1172 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1173 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1174 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1175 c     &        restyp(itypi),i,restyp(itypj),j,
1176 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1177 c     &        chi1,chi2,chip1,chip2,
1178 c     &        eps1,eps2rt**2,eps3rt**2,
1179 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1180 c     &        evdwij+e_augm
1181 c            endif
1182             if (calc_grad) then
1183 C Calculate gradient components.
1184             e1=e1*eps1*eps2rt**2*eps3rt**2
1185             fac=-expon*(e1+evdwij)*rij_shift
1186             sigder=fac*sigder
1187             fac=rij*fac-2*expon*rrij*e_augm
1188 C Calculate the radial part of the gradient
1189             gg(1)=xj*fac
1190             gg(2)=yj*fac
1191             gg(3)=zj*fac
1192 C Calculate angular part of the gradient.
1193             call sc_grad
1194             endif
1195           enddo      ! j
1196         enddo        ! iint
1197       enddo          ! i
1198       return
1199       end
1200 C-----------------------------------------------------------------------------
1201       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1202 C
1203 C This subroutine calculates the interaction energy of nonbonded side chains
1204 C assuming the Gay-Berne potential of interaction.
1205 C
1206        IMPLICIT NONE
1207        INCLUDE 'DIMENSIONS'
1208        INCLUDE 'DIMENSIONS.ZSCOPT'
1209        INCLUDE 'COMMON.CALC'
1210        INCLUDE 'COMMON.CONTROL'
1211        INCLUDE 'COMMON.CHAIN'
1212        INCLUDE 'COMMON.DERIV'
1213        INCLUDE 'COMMON.EMP'
1214        INCLUDE 'COMMON.GEO'
1215        INCLUDE 'COMMON.INTERACT'
1216        INCLUDE 'COMMON.IOUNITS'
1217        INCLUDE 'COMMON.LOCAL'
1218        INCLUDE 'COMMON.NAMES'
1219        INCLUDE 'COMMON.VAR'
1220        INCLUDE 'COMMON.WEIGHTDER'
1221        logical lprn
1222        double precision scalar
1223        double precision ener(4)
1224        integer troll
1225        integer iint,ij
1226        integer icant
1227
1228        energy_dec=.false.
1229        IF (energy_dec) write (iout,'(a)')
1230      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1231      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1232        evdw   = 0.0D0
1233        evdw_p = 0.0D0
1234        evdw_m = 0.0D0
1235 c DIAGNOSTICS
1236 ccccc      energy_dec=.false.
1237 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1238 c      lprn   = .false.
1239 c     if (icall.eq.0) lprn=.false.
1240 c END DIAGNOSTICS
1241 c      ind = 0
1242        DO i = iatsc_s, iatsc_e
1243         itypi  = itype(i)
1244 c        itypi1 = itype(i+1)
1245         dxi    = dc_norm(1,nres+i)
1246         dyi    = dc_norm(2,nres+i)
1247         dzi    = dc_norm(3,nres+i)
1248 c        dsci_inv=dsc_inv(itypi)
1249         dsci_inv = vbld_inv(i+nres)
1250 c        DO k = 1, 3
1251 c         ctail(k,1) = c(k, i+nres)
1252 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1253 c        END DO
1254         xi=c(1,nres+i)
1255         yi=c(2,nres+i)
1256         zi=c(3,nres+i)
1257 c!-------------------------------------------------------------------
1258 C Calculate SC interaction energy.
1259         DO iint = 1, nint_gr(i)
1260          DO j = istart(i,iint), iend(i,iint)
1261 c! initialize variables for electrostatic gradients
1262           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1263 c            ind=ind+1
1264 c            dscj_inv = dsc_inv(itypj)
1265           dscj_inv = vbld_inv(j+nres)
1266 c! rij holds 1/(distance of Calpha atoms)
1267           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1268           rij  = dsqrt(rrij)
1269 c!-------------------------------------------------------------------
1270 C Calculate angle-dependent terms of energy and contributions to their
1271 C derivatives.
1272
1273 #ifdef CHECK_MOMO
1274 c!      DO troll = 10, 5000
1275 c!      om1    = 0.0d0
1276 c!      om2    = 0.0d0
1277 c!      om12   = 1.0d0
1278 c!      sqom1  = om1 * om1
1279 c!      sqom2  = om2 * om2
1280 c!      sqom12 = om12 * om12
1281 c!      rij    = 5.0d0 / troll
1282 c!      rrij   = rij * rij
1283 c!      Rtail  = troll / 5.0d0
1284 c!      Rhead  = troll / 5.0d0
1285 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1286 c!      Rtail = dsqrt((Rtail**2)
1287 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1288 c!      rij = 1.0d0/Rtail
1289 c!      rrij = rij * rij
1290 #endif
1291           CALL sc_angular
1292 c! this should be in elgrad_init but om's are calculated by sc_angular
1293 c! which in turn is used by older potentials
1294 c! which proves how tangled UNRES code is >.<
1295 c! om = omega, sqom = om^2
1296           sqom1  = om1 * om1
1297           sqom2  = om2 * om2
1298           sqom12 = om12 * om12
1299
1300 c! now we calculate EGB - Gey-Berne
1301 c! It will be summed up in evdwij and saved in evdw
1302           sigsq     = 1.0D0  / sigsq
1303           sig       = sig0ij * dsqrt(sigsq)
1304 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1305           rij_shift = Rtail - sig + sig0ij
1306           IF (rij_shift.le.0.0D0) THEN
1307            evdw = 1.0D20
1308            RETURN
1309           END IF
1310           sigder = -sig * sigsq
1311           rij_shift = 1.0D0 / rij_shift
1312           fac       = rij_shift**expon
1313           c1        = fac  * fac * aa(itypi,itypj)
1314 c!          c1        = 0.0d0
1315           c2        = fac  * bb(itypi,itypj)
1316 c!          c2        = 0.0d0
1317           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1318           eps2der   = eps3rt * evdwij
1319           eps3der   = eps2rt * evdwij
1320 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1321           evdwij    = eps2rt * eps3rt * evdwij
1322 c!      evdwij = 0.0d0
1323 c!      write (*,*) "Gey Berne = ", evdwij
1324 #ifdef TSCSC
1325           IF (bb(itypi,itypj).gt.0) THEN
1326            evdw_p = evdw_p + evdwij
1327           ELSE
1328            evdw_m = evdw_m + evdwij
1329           END IF
1330 #else
1331           evdw = evdw
1332      &         + evdwij
1333 #endif
1334 c!-------------------------------------------------------------------
1335 c! Calculate some components of GGB
1336           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1337           fac    = -expon * (c1 + evdwij) * rij_shift
1338           sigder = fac * sigder
1339 c!          fac    = rij * fac
1340 c! Calculate distance derivative
1341 c!          gg(1) = xj * fac
1342 c!          gg(2) = yj * fac
1343 c!          gg(3) = zj * fac
1344           gg(1) = fac
1345           gg(2) = fac
1346           gg(3) = fac
1347 c!      write (*,*) "gg(1) = ", gg(1)
1348 c!      write (*,*) "gg(2) = ", gg(2)
1349 c!      write (*,*) "gg(3) = ", gg(3)
1350 c! The angular derivatives of GGB are brought together in sc_grad
1351 c!-------------------------------------------------------------------
1352 c! Fcav
1353 c!
1354 c! Catch gly-gly interactions to skip calculation of something that
1355 c! does not exist
1356
1357       IF (itypi.eq.10.and.itypj.eq.10) THEN
1358        Fcav = 0.0d0
1359        dFdR = 0.0d0
1360        dCAVdOM1  = 0.0d0
1361        dCAVdOM2  = 0.0d0
1362        dCAVdOM12 = 0.0d0
1363       ELSE
1364
1365 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1366        fac = chis1 * sqom1 + chis2 * sqom2
1367      &     - 2.0d0 * chis12 * om1 * om2 * om12
1368 c! we will use pom later in Gcav, so dont mess with it!
1369        pom = 1.0d0 - chis1 * chis2 * sqom12
1370
1371        Lambf = (1.0d0 - (fac / pom))
1372        Lambf = dsqrt(Lambf)
1373
1374
1375        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1376 c!       write (*,*) "sparrow = ", sparrow
1377        Chif = Rtail * sparrow
1378        ChiLambf = Chif * Lambf
1379        eagle = dsqrt(ChiLambf)
1380        bat = ChiLambf ** 11.0d0
1381
1382        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1383        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1384        botsq = bot * bot
1385
1386 c!      write (*,*) "sig1 = ",sig1
1387 c!      write (*,*) "sig2 = ",sig2
1388 c!      write (*,*) "Rtail = ",Rtail
1389 c!      write (*,*) "sparrow = ",sparrow
1390 c!      write (*,*) "Chis1 = ", chis1
1391 c!      write (*,*) "Chis2 = ", chis2
1392 c!      write (*,*) "Chis12 = ", chis12
1393 c!      write (*,*) "om1 = ", om1
1394 c!      write (*,*) "om2 = ", om2
1395 c!      write (*,*) "om12 = ", om12
1396 c!      write (*,*) "sqom1 = ", sqom1
1397 c!      write (*,*) "sqom2 = ", sqom2
1398 c!      write (*,*) "sqom12 = ", sqom12
1399 c!      write (*,*) "Lambf = ",Lambf
1400 c!      write (*,*) "b1 = ",b1
1401 c!      write (*,*) "b2 = ",b2
1402 c!      write (*,*) "b3 = ",b3
1403 c!      write (*,*) "b4 = ",b4
1404 c!      write (*,*) "top = ",top
1405 c!      write (*,*) "bot = ",bot
1406        Fcav = top / bot
1407 c!       Fcav = 0.0d0
1408 c!      write (*,*) "Fcav = ", Fcav
1409 c!-------------------------------------------------------------------
1410 c! derivative of Fcav is Gcav...
1411 c!---------------------------------------------------
1412
1413        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1414        dbot = 12.0d0 * b4 * bat * Lambf
1415        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1416 c!       dFdR = 0.0d0
1417 c!      write (*,*) "dFcav/dR = ", dFdR
1418
1419        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1420        dbot = 12.0d0 * b4 * bat * Chif
1421        eagle = Lambf * pom
1422        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1423        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1424        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1425      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1426
1427        dFdL = ((dtop * bot - top * dbot) / botsq)
1428 c!       dFdL = 0.0d0
1429        dCAVdOM1  = dFdL * ( dFdOM1 )
1430        dCAVdOM2  = dFdL * ( dFdOM2 )
1431        dCAVdOM12 = dFdL * ( dFdOM12 )
1432 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1433 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1434 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1435 c!      write (*,*) ""
1436 c!-------------------------------------------------------------------
1437 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1438 c! Pom is used here to project the gradient vector into
1439 c! cartesian coordinates and at the same time contains
1440 c! dXhb/dXsc derivative (for charged amino acids
1441 c! location of hydrophobic centre of interaction is not
1442 c! the same as geometric centre of side chain, this
1443 c! derivative takes that into account)
1444 c! derivatives of omega angles will be added in sc_grad
1445
1446        DO k= 1, 3
1447         ertail(k) = Rtail_distance(k)/Rtail
1448        END DO
1449        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1450        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1451        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1452        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1453        DO k = 1, 3
1454 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1455 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1456         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1457         gvdwx(k,i) = gvdwx(k,i)
1458      &             - (( dFdR + gg(k) ) * pom)
1459 c!     &             - ( dFdR * pom )
1460         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1461         gvdwx(k,j) = gvdwx(k,j)
1462      &             + (( dFdR + gg(k) ) * pom)
1463 c!     &             + ( dFdR * pom )
1464
1465         gvdwc(k,i) = gvdwc(k,i)
1466      &             - (( dFdR + gg(k) ) * ertail(k))
1467 c!     &             - ( dFdR * ertail(k))
1468
1469         gvdwc(k,j) = gvdwc(k,j)
1470      &             + (( dFdR + gg(k) ) * ertail(k))
1471 c!     &             + ( dFdR * ertail(k))
1472
1473         gg(k) = 0.0d0
1474 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1475 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1476       END DO
1477
1478 c!-------------------------------------------------------------------
1479 c! Compute head-head and head-tail energies for each state
1480
1481           isel = iabs(Qi) + iabs(Qj)
1482           IF (isel.eq.0) THEN
1483 c! No charges - do nothing
1484            eheadtail = 0.0d0
1485
1486           ELSE IF (isel.eq.4) THEN
1487 c! Calculate dipole-dipole interactions
1488            CALL edd(ecl)
1489            eheadtail = ECL
1490
1491           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1492 c! Charge-nonpolar interactions
1493            CALL eqn(epol)
1494            eheadtail = epol
1495
1496           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1497 c! Nonpolar-charge interactions
1498            CALL enq(epol)
1499            eheadtail = epol
1500
1501           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1502 c! Charge-dipole interactions
1503            CALL eqd(ecl, elj, epol)
1504            eheadtail = ECL + elj + epol
1505
1506           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1507 c! Dipole-charge interactions
1508            CALL edq(ecl, elj, epol)
1509            eheadtail = ECL + elj + epol
1510
1511           ELSE IF ((isel.eq.2.and.
1512      &          iabs(Qi).eq.1).and.
1513      &          nstate(itypi,itypj).eq.1) THEN
1514 c! Same charge-charge interaction ( +/+ or -/- )
1515            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1516            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1517
1518           ELSE IF ((isel.eq.2.and.
1519      &          iabs(Qi).eq.1).and.
1520      &          nstate(itypi,itypj).ne.1) THEN
1521 c! Different charge-charge interaction ( +/- or -/+ )
1522            CALL energy_quad
1523      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1524           END IF
1525        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1526 c!      write (*,*) "evdw = ", evdw
1527 c!      write (*,*) "Fcav = ", Fcav
1528 c!      write (*,*) "eheadtail = ", eheadtail
1529        evdw = evdw
1530      &      + Fcav
1531      &      + eheadtail
1532        ij=icant(itypi,itypj)
1533        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1534        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1535        eneps_temp(3,ij)=eheadtail
1536        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1537      &  restyp(itype(i)),i,restyp(itype(j)),j,
1538      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1539      &  Equad,evdw
1540        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1541      &  restyp(itype(i)),i,restyp(itype(j)),j,
1542      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1543      &  Equad,evdw
1544 #ifdef CHECK_MOMO
1545        evdw = 0.0d0
1546        END DO ! troll
1547 #endif
1548
1549 c!-------------------------------------------------------------------
1550 c! As all angular derivatives are done, now we sum them up,
1551 c! then transform and project into cartesian vectors and add to gvdwc
1552 c! We call sc_grad always, with the exception of +/- interaction.
1553 c! This is because energy_quad subroutine needs to handle
1554 c! this job in his own way.
1555 c! This IS probably not very efficient and SHOULD be optimised
1556 c! but it will require major restructurization of emomo
1557 c! so it will be left as it is for now
1558 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1559        IF (nstate(itypi,itypj).eq.1) THEN
1560 #ifdef TSCSC
1561         IF (bb(itypi,itypj).gt.0) THEN
1562          CALL sc_grad
1563         ELSE
1564          CALL sc_grad_T
1565         END IF
1566 #else
1567         CALL sc_grad
1568 #endif
1569        END IF
1570 c!-------------------------------------------------------------------
1571 c! NAPISY KONCOWE
1572          END DO   ! j
1573         END DO    ! iint
1574        END DO     ! i
1575 c      write (iout,*) "Number of loop steps in EGB:",ind
1576 c      energy_dec=.false.
1577        RETURN
1578       END SUBROUTINE emomo
1579 c! END OF MOMO
1580 C-----------------------------------------------------------------------------
1581       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1582        IMPLICIT NONE
1583        INCLUDE 'DIMENSIONS'
1584        INCLUDE 'DIMENSIONS.ZSCOPT'
1585        INCLUDE 'COMMON.CALC'
1586        INCLUDE 'COMMON.CHAIN'
1587        INCLUDE 'COMMON.CONTROL'
1588        INCLUDE 'COMMON.DERIV'
1589        INCLUDE 'COMMON.EMP'
1590        INCLUDE 'COMMON.GEO'
1591        INCLUDE 'COMMON.INTERACT'
1592        INCLUDE 'COMMON.IOUNITS'
1593        INCLUDE 'COMMON.LOCAL'
1594        INCLUDE 'COMMON.NAMES'
1595        INCLUDE 'COMMON.VAR'
1596        double precision scalar, facd3, facd4, federmaus, adler
1597 c! Epol and Gpol analytical parameters
1598        alphapol1 = alphapol(itypi,itypj)
1599        alphapol2 = alphapol(itypj,itypi)
1600 c! Fisocav and Gisocav analytical parameters
1601        al1  = alphiso(1,itypi,itypj)
1602        al2  = alphiso(2,itypi,itypj)
1603        al3  = alphiso(3,itypi,itypj)
1604        al4  = alphiso(4,itypi,itypj)
1605        csig = (1.0d0
1606      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1607      &      + sigiso2(itypi,itypj)**2.0d0))
1608 c!
1609        pis  = sig0head(itypi,itypj)
1610        eps_head = epshead(itypi,itypj)
1611        Rhead_sq = Rhead * Rhead
1612 c! R1 - distance between head of ith side chain and tail of jth sidechain
1613 c! R2 - distance between head of jth side chain and tail of ith sidechain
1614        R1 = 0.0d0
1615        R2 = 0.0d0
1616        DO k = 1, 3
1617 c! Calculate head-to-tail distances needed by Epol
1618         R1=R1+(ctail(k,2)-chead(k,1))**2
1619         R2=R2+(chead(k,2)-ctail(k,1))**2
1620        END DO
1621 c! Pitagoras
1622        R1 = dsqrt(R1)
1623        R2 = dsqrt(R2)
1624
1625 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1626 c!     &        +dhead(1,1,itypi,itypj))**2))
1627 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1628 c!     &        +dhead(2,1,itypi,itypj))**2))
1629 c!-------------------------------------------------------------------
1630 c! Coulomb electrostatic interaction
1631        Ecl = (332.0d0 * Qij) / Rhead
1632 c! derivative of Ecl is Gcl...
1633        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1634        dGCLdOM1 = 0.0d0
1635        dGCLdOM2 = 0.0d0
1636        dGCLdOM12 = 0.0d0
1637 c!-------------------------------------------------------------------
1638 c! Generalised Born Solvent Polarization
1639 c! Charged head polarizes the solvent
1640        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1641        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1642        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1643 c! Derivative of Egb is Ggb...
1644        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1645        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1646      &        / ( 2.0d0 * Fgb )
1647        dGGBdR = dGGBdFGB * dFGBdR
1648 c!-------------------------------------------------------------------
1649 c! Fisocav - isotropic cavity creation term
1650 c! or "how much energy it costs to put charged head in water"
1651        pom = Rhead * csig
1652        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1653        bot = (1.0d0 + al4 * pom**12.0d0)
1654        botsq = bot * bot
1655        FisoCav = top / bot
1656 c!      write (*,*) "Rhead = ",Rhead
1657 c!      write (*,*) "csig = ",csig
1658 c!      write (*,*) "pom = ",pom
1659 c!      write (*,*) "al1 = ",al1
1660 c!      write (*,*) "al2 = ",al2
1661 c!      write (*,*) "al3 = ",al3
1662 c!      write (*,*) "al4 = ",al4
1663 c!      write (*,*) "top = ",top
1664 c!      write (*,*) "bot = ",bot
1665 c! Derivative of Fisocav is GCV...
1666        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1667        dbot = 12.0d0 * al4 * pom ** 11.0d0
1668        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1669 c!-------------------------------------------------------------------
1670 c! Epol
1671 c! Polarization energy - charged heads polarize hydrophobic "neck"
1672        MomoFac1 = (1.0d0 - chi1 * sqom2)
1673        MomoFac2 = (1.0d0 - chi2 * sqom1)
1674        RR1  = ( R1 * R1 ) / MomoFac1
1675        RR2  = ( R2 * R2 ) / MomoFac2
1676        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1677        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1678        fgb1 = sqrt( RR1 + a12sq * ee1 )
1679        fgb2 = sqrt( RR2 + a12sq * ee2 )
1680        epol = 332.0d0 * eps_inout_fac * (
1681      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1682 c!       epol = 0.0d0
1683 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1684 c       write (*,*) "alphapol1 = ", alphapol1
1685 c       write (*,*) "alphapol2 = ", alphapol2
1686 c       write (*,*) "fgb1 = ", fgb1
1687 c       write (*,*) "fgb2 = ", fgb2
1688 c       write (*,*) "epol = ", epol
1689 c! derivative of Epol is Gpol...
1690        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1691      &          / (fgb1 ** 5.0d0)
1692        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1693      &          / (fgb2 ** 5.0d0)
1694        dFGBdR1 = ( (R1 / MomoFac1)
1695      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1696      &        / ( 2.0d0 * fgb1 )
1697        dFGBdR2 = ( (R2 / MomoFac2)
1698      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1699      &        / ( 2.0d0 * fgb2 )
1700        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1701      &          * ( 2.0d0 - 0.5d0 * ee1) )
1702      &          / ( 2.0d0 * fgb1 )
1703        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1704      &          * ( 2.0d0 - 0.5d0 * ee2) )
1705      &          / ( 2.0d0 * fgb2 )
1706        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1707 c!       dPOLdR1 = 0.0d0
1708        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1709 c!       dPOLdR2 = 0.0d0
1710        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1711 c!       dPOLdOM1 = 0.0d0
1712        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1713 c!       dPOLdOM2 = 0.0d0
1714 c!-------------------------------------------------------------------
1715 c! Elj
1716 c! Lennard-Jones 6-12 interaction between heads
1717        pom = (pis / Rhead)**6.0d0
1718        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1719 c! derivative of Elj is Glj
1720        dGLJdR = 4.0d0 * eps_head
1721      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1722      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1723 c!-------------------------------------------------------------------
1724 c! Return the results
1725 c! These things do the dRdX derivatives, that is
1726 c! allow us to change what we see from function that changes with
1727 c! distance to function that changes with LOCATION (of the interaction
1728 c! site)
1729        DO k = 1, 3
1730         erhead(k) = Rhead_distance(k)/Rhead
1731         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1732         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1733        END DO
1734
1735        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1736        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1737        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1738        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1739        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1740        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1741        facd1 = d1 * vbld_inv(i+nres)
1742        facd2 = d2 * vbld_inv(j+nres)
1743        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1744        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1745
1746 c! Now we add appropriate partial derivatives (one in each dimension)
1747        DO k = 1, 3
1748         hawk   = (erhead_tail(k,1) +
1749      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1750         condor = (erhead_tail(k,2) +
1751      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1752
1753         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1754         gvdwx(k,i) = gvdwx(k,i)
1755      &             - dGCLdR * pom
1756      &             - dGGBdR * pom
1757      &             - dGCVdR * pom
1758      &             - dPOLdR1 * hawk
1759      &             - dPOLdR2 * (erhead_tail(k,2)
1760      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1761      &             - dGLJdR * pom
1762
1763         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1764         gvdwx(k,j) = gvdwx(k,j)
1765      &             + dGCLdR * pom
1766      &             + dGGBdR * pom
1767      &             + dGCVdR * pom
1768      &             + dPOLdR1 * (erhead_tail(k,1)
1769      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1770      &             + dPOLdR2 * condor
1771      &             + dGLJdR * pom
1772
1773         gvdwc(k,i) = gvdwc(k,i)
1774      &             - dGCLdR * erhead(k)
1775      &             - dGGBdR * erhead(k)
1776      &             - dGCVdR * erhead(k)
1777      &             - dPOLdR1 * erhead_tail(k,1)
1778      &             - dPOLdR2 * erhead_tail(k,2)
1779      &             - dGLJdR * erhead(k)
1780
1781         gvdwc(k,j) = gvdwc(k,j)
1782      &             + dGCLdR * erhead(k)
1783      &             + dGGBdR * erhead(k)
1784      &             + dGCVdR * erhead(k)
1785      &             + dPOLdR1 * erhead_tail(k,1)
1786      &             + dPOLdR2 * erhead_tail(k,2)
1787      &             + dGLJdR * erhead(k)
1788
1789        END DO
1790        RETURN
1791       END SUBROUTINE eqq
1792 c!-------------------------------------------------------------------
1793       SUBROUTINE energy_quad
1794      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1795        IMPLICIT NONE
1796        INCLUDE 'DIMENSIONS'
1797        INCLUDE 'DIMENSIONS.ZSCOPT'
1798        INCLUDE 'COMMON.CALC'
1799        INCLUDE 'COMMON.CHAIN'
1800        INCLUDE 'COMMON.CONTROL'
1801        INCLUDE 'COMMON.DERIV'
1802        INCLUDE 'COMMON.EMP'
1803        INCLUDE 'COMMON.GEO'
1804        INCLUDE 'COMMON.INTERACT'
1805        INCLUDE 'COMMON.IOUNITS'
1806        INCLUDE 'COMMON.LOCAL'
1807        INCLUDE 'COMMON.NAMES'
1808        INCLUDE 'COMMON.VAR'
1809        double precision scalar
1810        double precision ener(4)
1811        double precision dcosom1(3),dcosom2(3)
1812 c! used in Epol derivatives
1813        double precision facd3, facd4
1814        double precision federmaus, adler
1815 c! Epol and Gpol analytical parameters
1816        alphapol1 = alphapol(itypi,itypj)
1817        alphapol2 = alphapol(itypj,itypi)
1818 c! Fisocav and Gisocav analytical parameters
1819        al1  = alphiso(1,itypi,itypj)
1820        al2  = alphiso(2,itypi,itypj)
1821        al3  = alphiso(3,itypi,itypj)
1822        al4  = alphiso(4,itypi,itypj)
1823        csig = (1.0d0
1824      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1825      &      + sigiso2(itypi,itypj)**2.0d0))
1826 c!
1827        w1   = wqdip(1,itypi,itypj)
1828        w2   = wqdip(2,itypi,itypj)
1829        pis  = sig0head(itypi,itypj)
1830        eps_head = epshead(itypi,itypj)
1831 c! First things first:
1832 c! We need to do sc_grad's job with GB and Fcav
1833        eom1  =
1834      &         eps2der * eps2rt_om1
1835      &       - 2.0D0 * alf1 * eps3der
1836      &       + sigder * sigsq_om1
1837      &       + dCAVdOM1
1838        eom2  =
1839      &         eps2der * eps2rt_om2
1840      &       + 2.0D0 * alf2 * eps3der
1841      &       + sigder * sigsq_om2
1842      &       + dCAVdOM2
1843        eom12 =
1844      &         evdwij  * eps1_om12
1845      &       + eps2der * eps2rt_om12
1846      &       - 2.0D0 * alf12 * eps3der
1847      &       + sigder *sigsq_om12
1848      &       + dCAVdOM12
1849 c! now some magical transformations to project gradient into
1850 c! three cartesian vectors
1851        DO k = 1, 3
1852         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1853         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1854         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1855 c! this acts on hydrophobic center of interaction
1856         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1857      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1858      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1859         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1860      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1861      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1862 c! this acts on Calpha
1863         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1864         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1865        END DO
1866 c! sc_grad is done, now we will compute
1867        eheadtail = 0.0d0
1868        eom1 = 0.0d0
1869        eom2 = 0.0d0
1870        eom12 = 0.0d0
1871
1872 c! ENERGY DEBUG
1873 c!       ii = 1
1874 c!       jj = 1
1875 c!       d1 = dhead(1, 1, itypi, itypj)
1876 c!       d2 = dhead(2, 1, itypi, itypj)
1877 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1878 c!     &        +dhead(1,ii,itypi,itypj))**2))
1879 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1880 c!     &        +dhead(2,jj,itypi,itypj))**2))
1881 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1882 c! END OF ENERGY DEBUG
1883 c*************************************************************
1884        DO istate = 1, nstate(itypi,itypj)
1885 c*************************************************************
1886         IF (istate.ne.1) THEN
1887          IF (istate.lt.3) THEN
1888           ii = 1
1889          ELSE
1890           ii = 2
1891          END IF
1892         jj = istate/ii
1893         d1 = dhead(1,ii,itypi,itypj)
1894         d2 = dhead(2,jj,itypi,itypj)
1895         DO k = 1,3
1896          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1897          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1898          Rhead_distance(k) = chead(k,2) - chead(k,1)
1899         END DO
1900 c! pitagoras (root of sum of squares)
1901         Rhead = dsqrt(
1902      &          (Rhead_distance(1)*Rhead_distance(1))
1903      &        + (Rhead_distance(2)*Rhead_distance(2))
1904      &        + (Rhead_distance(3)*Rhead_distance(3)))
1905         END IF
1906         Rhead_sq = Rhead * Rhead
1907
1908 c! R1 - distance between head of ith side chain and tail of jth sidechain
1909 c! R2 - distance between head of jth side chain and tail of ith sidechain
1910         R1 = 0.0d0
1911         R2 = 0.0d0
1912         DO k = 1, 3
1913 c! Calculate head-to-tail distances
1914          R1=R1+(ctail(k,2)-chead(k,1))**2
1915          R2=R2+(chead(k,2)-ctail(k,1))**2
1916         END DO
1917 c! Pitagoras
1918         R1 = dsqrt(R1)
1919         R2 = dsqrt(R2)
1920
1921 c! ENERGY DEBUG
1922 c!      write (*,*) "istate = ", istate
1923 c!      write (*,*) "ii = ", ii
1924 c!      write (*,*) "jj = ", jj
1925 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1926 c!     &        +dhead(1,ii,itypi,itypj))**2))
1927 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1928 c!     &        +dhead(2,jj,itypi,itypj))**2))
1929 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1930 c!      Rhead_sq = Rhead * Rhead
1931 c!      write (*,*) "d1 = ",d1
1932 c!      write (*,*) "d2 = ",d2
1933 c!      write (*,*) "R1 = ",R1
1934 c!      write (*,*) "R2 = ",R2
1935 c!      write (*,*) "Rhead = ",Rhead
1936 c! END OF ENERGY DEBUG
1937
1938 c!-------------------------------------------------------------------
1939 c! Coulomb electrostatic interaction
1940         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1941 c!        Ecl = 0.0d0
1942 c!        write (*,*) "Ecl = ", Ecl
1943 c! derivative of Ecl is Gcl...
1944         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1945 c!        dGCLdR = 0.0d0
1946         dGCLdOM1 = 0.0d0
1947         dGCLdOM2 = 0.0d0
1948         dGCLdOM12 = 0.0d0
1949 c!-------------------------------------------------------------------
1950 c! Generalised Born Solvent Polarization
1951         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1952         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1953         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1954 c!        Egb = 0.0d0
1955 c!      write (*,*) "a1*a2 = ", a12sq
1956 c!      write (*,*) "Rhead = ", Rhead
1957 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1958 c!      write (*,*) "ee = ", ee
1959 c!      write (*,*) "Fgb = ", Fgb
1960 c!      write (*,*) "fac = ", eps_inout_fac
1961 c!      write (*,*) "Qij = ", Qij
1962 c!      write (*,*) "Egb = ", Egb
1963 c! Derivative of Egb is Ggb...
1964 c! dFGBdR is used by Quad's later...
1965         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1966         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1967      &         / ( 2.0d0 * Fgb )
1968         dGGBdR = dGGBdFGB * dFGBdR
1969 c!        dGGBdR = 0.0d0
1970 c!-------------------------------------------------------------------
1971 c! Fisocav - isotropic cavity creation term
1972         pom = Rhead * csig
1973         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1974         bot = (1.0d0 + al4 * pom**12.0d0)
1975         botsq = bot * bot
1976         FisoCav = top / bot
1977 c!        FisoCav = 0.0d0
1978 c!      write (*,*) "pom = ",pom
1979 c!      write (*,*) "al1 = ",al1
1980 c!      write (*,*) "al2 = ",al2
1981 c!      write (*,*) "al3 = ",al3
1982 c!      write (*,*) "al4 = ",al4
1983 c!      write (*,*) "top = ",top
1984 c!      write (*,*) "bot = ",bot
1985 c!      write (*,*) "Fisocav = ", Fisocav
1986
1987 c! Derivative of Fisocav is GCV...
1988         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1989         dbot = 12.0d0 * al4 * pom ** 11.0d0
1990         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1991 c!        dGCVdR = 0.0d0
1992 c!-------------------------------------------------------------------
1993 c! Polarization energy
1994 c! Epol
1995         MomoFac1 = (1.0d0 - chi1 * sqom2)
1996         MomoFac2 = (1.0d0 - chi2 * sqom1)
1997         RR1  = ( R1 * R1 ) / MomoFac1
1998         RR2  = ( R2 * R2 ) / MomoFac2
1999         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2000         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2001         fgb1 = sqrt( RR1 + a12sq * ee1 )
2002         fgb2 = sqrt( RR2 + a12sq * ee2 )
2003         epol = 332.0d0 * eps_inout_fac * (
2004      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2005 c!        epol = 0.0d0
2006 c! derivative of Epol is Gpol...
2007         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2008      &            / (fgb1 ** 5.0d0)
2009         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2010      &            / (fgb2 ** 5.0d0)
2011         dFGBdR1 = ( (R1 / MomoFac1)
2012      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2013      &          / ( 2.0d0 * fgb1 )
2014         dFGBdR2 = ( (R2 / MomoFac2)
2015      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2016      &          / ( 2.0d0 * fgb2 )
2017         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2018      &           * ( 2.0d0 - 0.5d0 * ee1) )
2019      &           / ( 2.0d0 * fgb1 )
2020         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2021      &           * ( 2.0d0 - 0.5d0 * ee2) )
2022      &           / ( 2.0d0 * fgb2 )
2023         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2024 c!        dPOLdR1 = 0.0d0
2025         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2026 c!        dPOLdR2 = 0.0d0
2027         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2028 c!        dPOLdOM1 = 0.0d0
2029         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2030 c!        dPOLdOM2 = 0.0d0
2031 c!-------------------------------------------------------------------
2032 c! Elj
2033         pom = (pis / Rhead)**6.0d0
2034         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2035 c!        Elj = 0.0d0
2036 c! derivative of Elj is Glj
2037         dGLJdR = 4.0d0 * eps_head
2038      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2039      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2040 c!        dGLJdR = 0.0d0
2041 c!-------------------------------------------------------------------
2042 c! Equad
2043        IF (Wqd.ne.0.0d0) THEN
2044         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2045      &        - 37.5d0  * ( sqom1 + sqom2 )
2046      &        + 157.5d0 * ( sqom1 * sqom2 )
2047      &        - 45.0d0  * om1*om2*om12
2048         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2049         Equad = fac * Beta1
2050 c!        Equad = 0.0d0
2051 c! derivative of Equad...
2052         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2053 c!        dQUADdR = 0.0d0
2054         dQUADdOM1 = fac
2055      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2056 c!        dQUADdOM1 = 0.0d0
2057         dQUADdOM2 = fac
2058      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2059 c!        dQUADdOM2 = 0.0d0
2060         dQUADdOM12 = fac
2061      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2062 c!        dQUADdOM12 = 0.0d0
2063         ELSE
2064          Beta1 = 0.0d0
2065          Equad = 0.0d0
2066         END IF
2067 c!-------------------------------------------------------------------
2068 c! Return the results
2069 c! Angular stuff
2070         eom1 = dPOLdOM1 + dQUADdOM1
2071         eom2 = dPOLdOM2 + dQUADdOM2
2072         eom12 = dQUADdOM12
2073 c! now some magical transformations to project gradient into
2074 c! three cartesian vectors
2075         DO k = 1, 3
2076          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2077          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2078          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2079         END DO
2080 c! Radial stuff
2081         DO k = 1, 3
2082          erhead(k) = Rhead_distance(k)/Rhead
2083          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2084          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2085         END DO
2086         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2087         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2088         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2089         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2090         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2091         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2092         facd1 = d1 * vbld_inv(i+nres)
2093         facd2 = d2 * vbld_inv(j+nres)
2094         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2095         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2096 c! Throw the results into gheadtail which holds gradients
2097 c! for each micro-state
2098         DO k = 1, 3
2099          hawk   = erhead_tail(k,1) +
2100      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2101          condor = erhead_tail(k,2) +
2102      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2103
2104          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2105 c! this acts on hydrophobic center of interaction
2106          gheadtail(k,1,1) = gheadtail(k,1,1)
2107      &                    - dGCLdR * pom
2108      &                    - dGGBdR * pom
2109      &                    - dGCVdR * pom
2110      &                    - dPOLdR1 * hawk
2111      &                    - dPOLdR2 * (erhead_tail(k,2)
2112      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2113      &                    - dGLJdR * pom
2114      &                    - dQUADdR * pom
2115      &                    - tuna(k)
2116      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2117      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2118
2119          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2120 c! this acts on hydrophobic center of interaction
2121          gheadtail(k,2,1) = gheadtail(k,2,1)
2122      &                    + dGCLdR * pom
2123      &                    + dGGBdR * pom
2124      &                    + dGCVdR * pom
2125      &                    + dPOLdR1 * (erhead_tail(k,1)
2126      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2127      &                    + dPOLdR2 * condor
2128      &                    + dGLJdR * pom
2129      &                    + dQUADdR * pom
2130      &                    + tuna(k)
2131      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2132      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2133
2134 c! this acts on Calpha
2135          gheadtail(k,3,1) = gheadtail(k,3,1)
2136      &                    - dGCLdR * erhead(k)
2137      &                    - dGGBdR * erhead(k)
2138      &                    - dGCVdR * erhead(k)
2139      &                    - dPOLdR1 * erhead_tail(k,1)
2140      &                    - dPOLdR2 * erhead_tail(k,2)
2141      &                    - dGLJdR * erhead(k)
2142      &                    - dQUADdR * erhead(k)
2143      &                    - tuna(k)
2144
2145 c! this acts on Calpha
2146          gheadtail(k,4,1) = gheadtail(k,4,1)
2147      &                    + dGCLdR * erhead(k)
2148      &                    + dGGBdR * erhead(k)
2149      &                    + dGCVdR * erhead(k)
2150      &                    + dPOLdR1 * erhead_tail(k,1)
2151      &                    + dPOLdR2 * erhead_tail(k,2)
2152      &                    + dGLJdR * erhead(k)
2153      &                    + dQUADdR * erhead(k)
2154      &                    + tuna(k)
2155         END DO
2156 c!      write(*,*) "ECL = ", Ecl
2157 c!      write(*,*) "Egb = ", Egb
2158 c!      write(*,*) "Epol = ", Epol
2159 c!      write(*,*) "Fisocav = ", Fisocav
2160 c!      write(*,*) "Elj = ", Elj
2161 c!      write(*,*) "Equad = ", Equad
2162 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2163 c!      write(*,*) "eheadtail = ", eheadtail
2164 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2165 c!      write(*,*) "dGCLdR = ", dGCLdR
2166 c!      write(*,*) "dGGBdR = ", dGGBdR
2167 c!      write(*,*) "dGCVdR = ", dGCVdR
2168 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2169 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2170 c!      write(*,*) "dGLJdR = ", dGLJdR
2171 c!      write(*,*) "dQUADdR = ", dQUADdR
2172 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2173         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2174         eheadtail = eheadtail
2175      &            + wstate(istate, itypi, itypj)
2176      &            * dexp(-betaT * ener(istate))
2177 c! foreach cartesian dimension
2178         DO k = 1, 3
2179 c! foreach of two gvdwx and gvdwc
2180          DO l = 1, 4
2181           gheadtail(k,l,2) = gheadtail(k,l,2)
2182      &                     + wstate( istate, itypi, itypj )
2183      &                     * dexp(-betaT * ener(istate))
2184      &                     * gheadtail(k,l,1)
2185           gheadtail(k,l,1) = 0.0d0
2186          END DO
2187         END DO
2188        END DO
2189 c! Here ended the gigantic DO istate = 1, 4, which starts
2190 c! at the beggining of the subroutine
2191
2192        DO k = 1, 3
2193         DO l = 1, 4
2194          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2195         END DO
2196         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2197         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2198         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2199         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2200         DO l = 1, 4
2201          gheadtail(k,l,1) = 0.0d0
2202          gheadtail(k,l,2) = 0.0d0
2203         END DO
2204        END DO
2205        eheadtail = (-dlog(eheadtail)) / betaT
2206        dPOLdOM1 = 0.0d0
2207        dPOLdOM2 = 0.0d0
2208        dQUADdOM1 = 0.0d0
2209        dQUADdOM2 = 0.0d0
2210        dQUADdOM12 = 0.0d0
2211        RETURN
2212       END SUBROUTINE energy_quad
2213 c!-------------------------------------------------------------------
2214       SUBROUTINE eqn(Epol)
2215       IMPLICIT NONE
2216       INCLUDE 'DIMENSIONS'
2217       INCLUDE 'DIMENSIONS.ZSCOPT'
2218       INCLUDE 'COMMON.CALC'
2219       INCLUDE 'COMMON.CHAIN'
2220       INCLUDE 'COMMON.CONTROL'
2221       INCLUDE 'COMMON.DERIV'
2222       INCLUDE 'COMMON.EMP'
2223       INCLUDE 'COMMON.GEO'
2224       INCLUDE 'COMMON.INTERACT'
2225       INCLUDE 'COMMON.IOUNITS'
2226       INCLUDE 'COMMON.LOCAL'
2227       INCLUDE 'COMMON.NAMES'
2228       INCLUDE 'COMMON.VAR'
2229       double precision scalar, facd4, federmaus
2230       alphapol1 = alphapol(itypi,itypj)
2231 c! R1 - distance between head of ith side chain and tail of jth sidechain
2232        R1 = 0.0d0
2233        DO k = 1, 3
2234 c! Calculate head-to-tail distances
2235         R1=R1+(ctail(k,2)-chead(k,1))**2
2236        END DO
2237 c! Pitagoras
2238        R1 = dsqrt(R1)
2239
2240 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2241 c!     &        +dhead(1,1,itypi,itypj))**2))
2242 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2243 c!     &        +dhead(2,1,itypi,itypj))**2))
2244 c--------------------------------------------------------------------
2245 c Polarization energy
2246 c Epol
2247        MomoFac1 = (1.0d0 - chi1 * sqom2)
2248        RR1  = R1 * R1 / MomoFac1
2249        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2250        fgb1 = sqrt( RR1 + a12sq * ee1)
2251        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2252 c!       epol = 0.0d0
2253 c!------------------------------------------------------------------
2254 c! derivative of Epol is Gpol...
2255        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2256      &          / (fgb1 ** 5.0d0)
2257        dFGBdR1 = ( (R1 / MomoFac1)
2258      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2259      &        / ( 2.0d0 * fgb1 )
2260        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2261      &          * (2.0d0 - 0.5d0 * ee1) )
2262      &          / (2.0d0 * fgb1)
2263        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2264 c!       dPOLdR1 = 0.0d0
2265        dPOLdOM1 = 0.0d0
2266        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2267 c!       dPOLdOM2 = 0.0d0
2268 c!-------------------------------------------------------------------
2269 c! Return the results
2270 c! (see comments in Eqq)
2271        DO k = 1, 3
2272         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2273        END DO
2274        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2275        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2276        facd1 = d1 * vbld_inv(i+nres)
2277        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2278
2279        DO k = 1, 3
2280         hawk = (erhead_tail(k,1) +
2281      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2282
2283         gvdwx(k,i) = gvdwx(k,i)
2284      &             - dPOLdR1 * hawk
2285         gvdwx(k,j) = gvdwx(k,j)
2286      &             + dPOLdR1 * (erhead_tail(k,1)
2287      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2288
2289         gvdwc(k,i) = gvdwc(k,i)
2290      &             - dPOLdR1 * erhead_tail(k,1)
2291         gvdwc(k,j) = gvdwc(k,j)
2292      &             + dPOLdR1 * erhead_tail(k,1)
2293
2294        END DO
2295        RETURN
2296       END SUBROUTINE eqn
2297
2298
2299 c!-------------------------------------------------------------------
2300
2301
2302
2303       SUBROUTINE enq(Epol)
2304        IMPLICIT NONE
2305        INCLUDE 'DIMENSIONS'
2306        INCLUDE 'DIMENSIONS.ZSCOPT'
2307        INCLUDE 'COMMON.CALC'
2308        INCLUDE 'COMMON.CHAIN'
2309        INCLUDE 'COMMON.CONTROL'
2310        INCLUDE 'COMMON.DERIV'
2311        INCLUDE 'COMMON.EMP'
2312        INCLUDE 'COMMON.GEO'
2313        INCLUDE 'COMMON.INTERACT'
2314        INCLUDE 'COMMON.IOUNITS'
2315        INCLUDE 'COMMON.LOCAL'
2316        INCLUDE 'COMMON.NAMES'
2317        INCLUDE 'COMMON.VAR'
2318        double precision scalar, facd3, adler
2319        alphapol2 = alphapol(itypj,itypi)
2320 c! R2 - distance between head of jth side chain and tail of ith sidechain
2321        R2 = 0.0d0
2322        DO k = 1, 3
2323 c! Calculate head-to-tail distances
2324         R2=R2+(chead(k,2)-ctail(k,1))**2
2325        END DO
2326 c! Pitagoras
2327        R2 = dsqrt(R2)
2328
2329 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2330 c!     &        +dhead(1,1,itypi,itypj))**2))
2331 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2332 c!     &        +dhead(2,1,itypi,itypj))**2))
2333 c------------------------------------------------------------------------
2334 c Polarization energy
2335        MomoFac2 = (1.0d0 - chi2 * sqom1)
2336        RR2  = R2 * R2 / MomoFac2
2337        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2338        fgb2 = sqrt(RR2  + a12sq * ee2)
2339        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2340 c!       epol = 0.0d0
2341 c!-------------------------------------------------------------------
2342 c! derivative of Epol is Gpol...
2343        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2344      &          / (fgb2 ** 5.0d0)
2345        dFGBdR2 = ( (R2 / MomoFac2)
2346      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2347      &        / (2.0d0 * fgb2)
2348        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2349      &          * (2.0d0 - 0.5d0 * ee2) )
2350      &          / (2.0d0 * fgb2)
2351        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2352 c!       dPOLdR2 = 0.0d0
2353        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2354 c!       dPOLdOM1 = 0.0d0
2355        dPOLdOM2 = 0.0d0
2356 c!-------------------------------------------------------------------
2357 c! Return the results
2358 c! (See comments in Eqq)
2359        DO k = 1, 3
2360         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2361        END DO
2362        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2363        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2364        facd2 = d2 * vbld_inv(j+nres)
2365        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2366        DO k = 1, 3
2367         condor = (erhead_tail(k,2)
2368      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2369
2370         gvdwx(k,i) = gvdwx(k,i)
2371      &             - dPOLdR2 * (erhead_tail(k,2)
2372      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2373         gvdwx(k,j) = gvdwx(k,j)
2374      &             + dPOLdR2 * condor
2375
2376         gvdwc(k,i) = gvdwc(k,i)
2377      &             - dPOLdR2 * erhead_tail(k,2)
2378         gvdwc(k,j) = gvdwc(k,j)
2379      &             + dPOLdR2 * erhead_tail(k,2)
2380
2381        END DO
2382       RETURN
2383       END SUBROUTINE enq
2384
2385
2386 c!-------------------------------------------------------------------
2387
2388
2389       SUBROUTINE eqd(Ecl,Elj,Epol)
2390        IMPLICIT NONE
2391        INCLUDE 'DIMENSIONS'
2392        INCLUDE 'DIMENSIONS.ZSCOPT'
2393        INCLUDE 'COMMON.CALC'
2394        INCLUDE 'COMMON.CHAIN'
2395        INCLUDE 'COMMON.CONTROL'
2396        INCLUDE 'COMMON.DERIV'
2397        INCLUDE 'COMMON.EMP'
2398        INCLUDE 'COMMON.GEO'
2399        INCLUDE 'COMMON.INTERACT'
2400        INCLUDE 'COMMON.IOUNITS'
2401        INCLUDE 'COMMON.LOCAL'
2402        INCLUDE 'COMMON.NAMES'
2403        INCLUDE 'COMMON.VAR'
2404        double precision scalar, facd4, federmaus
2405        alphapol1 = alphapol(itypi,itypj)
2406        w1        = wqdip(1,itypi,itypj)
2407        w2        = wqdip(2,itypi,itypj)
2408        pis       = sig0head(itypi,itypj)
2409        eps_head   = epshead(itypi,itypj)
2410 c!-------------------------------------------------------------------
2411 c! R1 - distance between head of ith side chain and tail of jth sidechain
2412        R1 = 0.0d0
2413        DO k = 1, 3
2414 c! Calculate head-to-tail distances
2415         R1=R1+(ctail(k,2)-chead(k,1))**2
2416        END DO
2417 c! Pitagoras
2418        R1 = dsqrt(R1)
2419
2420 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2421 c!     &        +dhead(1,1,itypi,itypj))**2))
2422 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2423 c!     &        +dhead(2,1,itypi,itypj))**2))
2424
2425 c!-------------------------------------------------------------------
2426 c! ecl
2427        sparrow  = w1 * Qi * om1
2428        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2429        Ecl = sparrow / Rhead**2.0d0
2430      &     - hawk    / Rhead**4.0d0
2431 c!-------------------------------------------------------------------
2432 c! derivative of ecl is Gcl
2433 c! dF/dr part
2434        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2435      &           + 4.0d0 * hawk    / Rhead**5.0d0
2436 c! dF/dom1
2437        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2438 c! dF/dom2
2439        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2440 c--------------------------------------------------------------------
2441 c Polarization energy
2442 c Epol
2443        MomoFac1 = (1.0d0 - chi1 * sqom2)
2444        RR1  = R1 * R1 / MomoFac1
2445        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2446        fgb1 = sqrt( RR1 + a12sq * ee1)
2447        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2448 c!       epol = 0.0d0
2449 c!------------------------------------------------------------------
2450 c! derivative of Epol is Gpol...
2451        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2452      &          / (fgb1 ** 5.0d0)
2453        dFGBdR1 = ( (R1 / MomoFac1)
2454      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2455      &        / ( 2.0d0 * fgb1 )
2456        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2457      &          * (2.0d0 - 0.5d0 * ee1) )
2458      &          / (2.0d0 * fgb1)
2459        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2460 c!       dPOLdR1 = 0.0d0
2461        dPOLdOM1 = 0.0d0
2462        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2463 c!       dPOLdOM2 = 0.0d0
2464 c!-------------------------------------------------------------------
2465 c! Elj
2466        pom = (pis / Rhead)**6.0d0
2467        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2468 c! derivative of Elj is Glj
2469        dGLJdR = 4.0d0 * eps_head
2470      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2471      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2472 c!-------------------------------------------------------------------
2473 c! Return the results
2474        DO k = 1, 3
2475         erhead(k) = Rhead_distance(k)/Rhead
2476         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2477        END DO
2478
2479        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2480        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2481        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2482        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2483        facd1 = d1 * vbld_inv(i+nres)
2484        facd2 = d2 * vbld_inv(j+nres)
2485        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2486
2487        DO k = 1, 3
2488         hawk = (erhead_tail(k,1) +
2489      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2490
2491         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2492         gvdwx(k,i) = gvdwx(k,i)
2493      &             - dGCLdR * pom
2494      &             - dPOLdR1 * hawk
2495      &             - dGLJdR * pom
2496
2497         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2498         gvdwx(k,j) = gvdwx(k,j)
2499      &             + dGCLdR * pom
2500      &             + dPOLdR1 * (erhead_tail(k,1)
2501      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2502      &             + dGLJdR * pom
2503
2504
2505         gvdwc(k,i) = gvdwc(k,i)
2506      &             - dGCLdR * erhead(k)
2507      &             - dPOLdR1 * erhead_tail(k,1)
2508      &             - dGLJdR * erhead(k)
2509
2510         gvdwc(k,j) = gvdwc(k,j)
2511      &             + dGCLdR * erhead(k)
2512      &             + dPOLdR1 * erhead_tail(k,1)
2513      &             + dGLJdR * erhead(k)
2514
2515        END DO
2516        RETURN
2517       END SUBROUTINE eqd
2518
2519
2520 c!-------------------------------------------------------------------
2521
2522
2523       SUBROUTINE edq(Ecl,Elj,Epol)
2524        IMPLICIT NONE
2525        INCLUDE 'DIMENSIONS'
2526        INCLUDE 'DIMENSIONS.ZSCOPT'
2527        INCLUDE 'COMMON.CALC'
2528        INCLUDE 'COMMON.CHAIN'
2529        INCLUDE 'COMMON.CONTROL'
2530        INCLUDE 'COMMON.DERIV'
2531        INCLUDE 'COMMON.EMP'
2532        INCLUDE 'COMMON.GEO'
2533        INCLUDE 'COMMON.INTERACT'
2534        INCLUDE 'COMMON.IOUNITS'
2535        INCLUDE 'COMMON.LOCAL'
2536        INCLUDE 'COMMON.NAMES'
2537        INCLUDE 'COMMON.VAR'
2538        double precision scalar, facd3, adler
2539        alphapol2 = alphapol(itypj,itypi)
2540        w1        = wqdip(1,itypi,itypj)
2541        w2        = wqdip(2,itypi,itypj)
2542        pis       = sig0head(itypi,itypj)
2543        eps_head  = epshead(itypi,itypj)
2544 c!-------------------------------------------------------------------
2545 c! R2 - distance between head of jth side chain and tail of ith sidechain
2546        R2 = 0.0d0
2547        DO k = 1, 3
2548 c! Calculate head-to-tail distances
2549         R2=R2+(chead(k,2)-ctail(k,1))**2
2550        END DO
2551 c! Pitagoras
2552        R2 = dsqrt(R2)
2553
2554 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2555 c!     &        +dhead(1,1,itypi,itypj))**2))
2556 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2557 c!     &        +dhead(2,1,itypi,itypj))**2))
2558
2559
2560 c!-------------------------------------------------------------------
2561 c! ecl
2562        sparrow  = w1 * Qi * om1
2563        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2564        ECL = sparrow / Rhead**2.0d0
2565      &     - hawk    / Rhead**4.0d0
2566 c!-------------------------------------------------------------------
2567 c! derivative of ecl is Gcl
2568 c! dF/dr part
2569        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2570      &           + 4.0d0 * hawk    / Rhead**5.0d0
2571 c! dF/dom1
2572        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2573 c! dF/dom2
2574        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2575 c--------------------------------------------------------------------
2576 c Polarization energy
2577 c Epol
2578        MomoFac2 = (1.0d0 - chi2 * sqom1)
2579        RR2  = R2 * R2 / MomoFac2
2580        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2581        fgb2 = sqrt(RR2  + a12sq * ee2)
2582        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2583 c!       epol = 0.0d0
2584 c! derivative of Epol is Gpol...
2585        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2586      &          / (fgb2 ** 5.0d0)
2587        dFGBdR2 = ( (R2 / MomoFac2)
2588      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2589      &        / (2.0d0 * fgb2)
2590        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2591      &          * (2.0d0 - 0.5d0 * ee2) )
2592      &          / (2.0d0 * fgb2)
2593        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2594 c!       dPOLdR2 = 0.0d0
2595        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2596 c!       dPOLdOM1 = 0.0d0
2597        dPOLdOM2 = 0.0d0
2598 c!-------------------------------------------------------------------
2599 c! Elj
2600        pom = (pis / Rhead)**6.0d0
2601        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2602 c! derivative of Elj is Glj
2603        dGLJdR = 4.0d0 * eps_head
2604      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2605      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2606 c!-------------------------------------------------------------------
2607 c! Return the results
2608 c! (see comments in Eqq)
2609        DO k = 1, 3
2610         erhead(k) = Rhead_distance(k)/Rhead
2611         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2612        END DO
2613        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2614        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2615        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2616        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2617        facd1 = d1 * vbld_inv(i+nres)
2618        facd2 = d2 * vbld_inv(j+nres)
2619        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2620
2621        DO k = 1, 3
2622         condor = (erhead_tail(k,2)
2623      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2624
2625         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2626         gvdwx(k,i) = gvdwx(k,i)
2627      &             - dGCLdR * pom
2628      &             - dPOLdR2 * (erhead_tail(k,2)
2629      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2630      &             - dGLJdR * pom
2631
2632         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2633         gvdwx(k,j) = gvdwx(k,j)
2634      &             + dGCLdR * pom
2635      &             + dPOLdR2 * condor
2636      &             + dGLJdR * pom
2637
2638
2639         gvdwc(k,i) = gvdwc(k,i)
2640      &             - dGCLdR * erhead(k)
2641      &             - dPOLdR2 * erhead_tail(k,2)
2642      &             - dGLJdR * erhead(k)
2643
2644         gvdwc(k,j) = gvdwc(k,j)
2645      &             + dGCLdR * erhead(k)
2646      &             + dPOLdR2 * erhead_tail(k,2)
2647      &             + dGLJdR * erhead(k)
2648
2649        END DO
2650        RETURN
2651       END SUBROUTINE edq
2652
2653
2654 C--------------------------------------------------------------------
2655
2656
2657       SUBROUTINE edd(ECL)
2658        IMPLICIT NONE
2659        INCLUDE 'DIMENSIONS'
2660        INCLUDE 'DIMENSIONS.ZSCOPT'
2661        INCLUDE 'COMMON.CALC'
2662        INCLUDE 'COMMON.CHAIN'
2663        INCLUDE 'COMMON.CONTROL'
2664        INCLUDE 'COMMON.DERIV'
2665        INCLUDE 'COMMON.EMP'
2666        INCLUDE 'COMMON.GEO'
2667        INCLUDE 'COMMON.INTERACT'
2668        INCLUDE 'COMMON.IOUNITS'
2669        INCLUDE 'COMMON.LOCAL'
2670        INCLUDE 'COMMON.NAMES'
2671        INCLUDE 'COMMON.VAR'
2672        double precision scalar
2673 c!       csig = sigiso(itypi,itypj)
2674        w1 = wqdip(1,itypi,itypj)
2675        w2 = wqdip(2,itypi,itypj)
2676 c!-------------------------------------------------------------------
2677 c! ECL
2678        fac = (om12 - 3.0d0 * om1 * om2)
2679        c1 = (w1 / (Rhead**3.0d0)) * fac
2680        c2 = (w2 / Rhead ** 6.0d0)
2681      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2682        ECL = c1 - c2
2683 c!       write (*,*) "w1 = ", w1
2684 c!       write (*,*) "w2 = ", w2
2685 c!       write (*,*) "om1 = ", om1
2686 c!       write (*,*) "om2 = ", om2
2687 c!       write (*,*) "om12 = ", om12
2688 c!       write (*,*) "fac = ", fac
2689 c!       write (*,*) "c1 = ", c1
2690 c!       write (*,*) "c2 = ", c2
2691 c!       write (*,*) "Ecl = ", Ecl
2692 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2693 c!       write (*,*) "c2_2 = ",
2694 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2695 c!-------------------------------------------------------------------
2696 c! dervative of ECL is GCL...
2697 c! dECL/dr
2698        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2699        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2700      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2701        dGCLdR = c1 - c2
2702 c! dECL/dom1
2703        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2704        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2705      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2706        dGCLdOM1 = c1 - c2
2707 c! dECL/dom2
2708        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2709        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2710      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2711        dGCLdOM2 = c1 - c2
2712 c! dECL/dom12
2713        c1 = w1 / (Rhead ** 3.0d0)
2714        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2715        dGCLdOM12 = c1 - c2
2716 c!-------------------------------------------------------------------
2717 c! Return the results
2718 c! (see comments in Eqq)
2719        DO k= 1, 3
2720         erhead(k) = Rhead_distance(k)/Rhead
2721        END DO
2722        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2723        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2724        facd1 = d1 * vbld_inv(i+nres)
2725        facd2 = d2 * vbld_inv(j+nres)
2726        DO k = 1, 3
2727
2728         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2729         gvdwx(k,i) = gvdwx(k,i)
2730      &             - dGCLdR * pom
2731         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2732         gvdwx(k,j) = gvdwx(k,j)
2733      &             + dGCLdR * pom
2734
2735         gvdwc(k,i) = gvdwc(k,i)
2736      &             - dGCLdR * erhead(k)
2737         gvdwc(k,j) = gvdwc(k,j)
2738      &             + dGCLdR * erhead(k)
2739        END DO
2740        RETURN
2741       END SUBROUTINE edd
2742
2743
2744 c!-------------------------------------------------------------------
2745
2746
2747       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2748        IMPLICIT NONE
2749 c! maxres
2750        INCLUDE 'DIMENSIONS'
2751        INCLUDE 'DIMENSIONS.ZSCOPT'
2752 c! itypi, itypj, i, j, k, l, chead,
2753        INCLUDE 'COMMON.CALC'
2754 c! c, nres, dc_norm
2755        INCLUDE 'COMMON.CHAIN'
2756 c! gradc, gradx
2757        INCLUDE 'COMMON.DERIV'
2758 c! electrostatic gradients-specific variables
2759        INCLUDE 'COMMON.EMP'
2760 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2761        INCLUDE 'COMMON.INTERACT'
2762 c! t_bath, Rb
2763 c       INCLUDE 'COMMON.MD'
2764 c! io for debug, disable it in final builds
2765        INCLUDE 'COMMON.IOUNITS'
2766        double precision Rb /1.987D-3/
2767 c!-------------------------------------------------------------------
2768 c! Variable Init
2769
2770 c! what amino acid is the aminoacid j'th?
2771        itypj = itype(j)
2772 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2773 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2774 c!       t_bath = 300
2775 c!       BetaT = 1.0d0 / (t_bath * Rb)
2776        BetaT = 1.0d0 / (298.0d0 * Rb)
2777 c! Gay-berne var's
2778        sig0ij = sigma( itypi,itypj )
2779        chi1   = chi( itypi, itypj )
2780        chi2   = chi( itypj, itypi )
2781        chi12  = chi1 * chi2
2782        chip1  = chipp( itypi, itypj )
2783        chip2  = chipp( itypj, itypi )
2784        chip12 = chip1 * chip2
2785 c! not used by momo potential, but needed by sc_angular which is shared
2786 c! by all energy_potential subroutines
2787        alf1   = 0.0d0
2788        alf2   = 0.0d0
2789        alf12  = 0.0d0
2790 c! location, location, location
2791        xj  = c( 1, nres+j ) - xi
2792        yj  = c( 2, nres+j ) - yi
2793        zj  = c( 3, nres+j ) - zi
2794        dxj = dc_norm( 1, nres+j )
2795        dyj = dc_norm( 2, nres+j )
2796        dzj = dc_norm( 3, nres+j )
2797 c! distance from center of chain(?) to polar/charged head
2798 c!       write (*,*) "istate = ", 1
2799 c!       write (*,*) "ii = ", 1
2800 c!       write (*,*) "jj = ", 1
2801        d1 = dhead(1, 1, itypi, itypj)
2802        d2 = dhead(2, 1, itypi, itypj)
2803 c! ai*aj from Fgb
2804        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2805 c!       a12sq = a12sq * a12sq
2806 c! charge of amino acid itypi is...
2807        Qi  = icharge(itypi)
2808        Qj  = icharge(itypj)
2809        Qij = Qi * Qj
2810 c! chis1,2,12
2811        chis1 = chis(itypi,itypj)
2812        chis2 = chis(itypj,itypi)
2813        chis12 = chis1 * chis2
2814        sig1 = sigmap1(itypi,itypj)
2815        sig2 = sigmap2(itypi,itypj)
2816 c!       write (*,*) "sig1 = ", sig1
2817 c!       write (*,*) "sig2 = ", sig2
2818 c! alpha factors from Fcav/Gcav
2819        b1 = alphasur(1,itypi,itypj)
2820        b2 = alphasur(2,itypi,itypj)
2821        b3 = alphasur(3,itypi,itypj)
2822        b4 = alphasur(4,itypi,itypj)
2823 c! used to determine whether we want to do quadrupole calculations
2824        wqd = wquad(itypi, itypj)
2825 c! used by Fgb
2826        eps_in = epsintab(itypi,itypj)
2827        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2828 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2829 c!-------------------------------------------------------------------
2830 c! tail location and distance calculations
2831        Rtail = 0.0d0
2832        DO k = 1, 3
2833         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2834         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2835        END DO
2836 c! tail distances will be themselves usefull elswhere
2837 c1 (in Gcav, for example)
2838        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2839        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2840        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2841        Rtail = dsqrt(
2842      &     (Rtail_distance(1)*Rtail_distance(1))
2843      &   + (Rtail_distance(2)*Rtail_distance(2))
2844      &   + (Rtail_distance(3)*Rtail_distance(3)))
2845 c!-------------------------------------------------------------------
2846 c! Calculate location and distance between polar heads
2847 c! distance between heads
2848 c! for each one of our three dimensional space...
2849        DO k = 1,3
2850 c! location of polar head is computed by taking hydrophobic centre
2851 c! and moving by a d1 * dc_norm vector
2852 c! see unres publications for very informative images
2853         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2854         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2855 c! distance
2856 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2857 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2858         Rhead_distance(k) = chead(k,2) - chead(k,1)
2859        END DO
2860 c! pitagoras (root of sum of squares)
2861        Rhead = dsqrt(
2862      &     (Rhead_distance(1)*Rhead_distance(1))
2863      &   + (Rhead_distance(2)*Rhead_distance(2))
2864      &   + (Rhead_distance(3)*Rhead_distance(3)))
2865 c!-------------------------------------------------------------------
2866 c! zero everything that should be zero'ed
2867        Egb = 0.0d0
2868        ECL = 0.0d0
2869        Elj = 0.0d0
2870        Equad = 0.0d0
2871        Epol = 0.0d0
2872        eheadtail = 0.0d0
2873        dGCLdOM1 = 0.0d0
2874        dGCLdOM2 = 0.0d0
2875        dGCLdOM12 = 0.0d0
2876        dPOLdOM1 = 0.0d0
2877        dPOLdOM2 = 0.0d0
2878        RETURN
2879       END SUBROUTINE elgrad_init
2880
2881
2882 C-----------------------------------------------------------------------------
2883       subroutine sc_angular
2884 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2885 C om12. Called by ebp, egb, and egbv.
2886       implicit none
2887       include 'COMMON.CALC'
2888       erij(1)=xj*rij
2889       erij(2)=yj*rij
2890       erij(3)=zj*rij
2891       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2892       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2893       om12=dxi*dxj+dyi*dyj+dzi*dzj
2894       chiom12=chi12*om12
2895 C Calculate eps1(om12) and its derivative in om12
2896       faceps1=1.0D0-om12*chiom12
2897       faceps1_inv=1.0D0/faceps1
2898       eps1=dsqrt(faceps1_inv)
2899 C Following variable is eps1*deps1/dom12
2900       eps1_om12=faceps1_inv*chiom12
2901 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2902 C and om12.
2903       om1om2=om1*om2
2904       chiom1=chi1*om1
2905       chiom2=chi2*om2
2906       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2907       sigsq=1.0D0-facsig*faceps1_inv
2908       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2909       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2910       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2911 C Calculate eps2 and its derivatives in om1, om2, and om12.
2912       chipom1=chip1*om1
2913       chipom2=chip2*om2
2914       chipom12=chip12*om12
2915       facp=1.0D0-om12*chipom12
2916       facp_inv=1.0D0/facp
2917       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2918 C Following variable is the square root of eps2
2919       eps2rt=1.0D0-facp1*facp_inv
2920 C Following three variables are the derivatives of the square root of eps
2921 C in om1, om2, and om12.
2922       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2923       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2924       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2925 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2926       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2927 C Calculate whole angle-dependent part of epsilon and contributions
2928 C to its derivatives
2929       return
2930       end
2931 C----------------------------------------------------------------------------
2932       subroutine sc_grad
2933       implicit real*8 (a-h,o-z)
2934       include 'DIMENSIONS'
2935       include 'DIMENSIONS.ZSCOPT'
2936       include 'COMMON.CHAIN'
2937       include 'COMMON.DERIV'
2938       include 'COMMON.CALC'
2939       double precision dcosom1(3),dcosom2(3)
2940       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2941       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2942       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2943      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2944       do k=1,3
2945         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2946         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2947       enddo
2948       do k=1,3
2949         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2950       enddo
2951       do k=1,3
2952         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2953      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2954      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2955         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2956      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2957      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2958       enddo
2959 C
2960 C Calculate the components of the gradient in DC and X
2961 C
2962       do k=i,j-1
2963         do l=1,3
2964           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2965         enddo
2966       enddo
2967       return
2968       end
2969 c------------------------------------------------------------------------------
2970       subroutine vec_and_deriv
2971       implicit real*8 (a-h,o-z)
2972       include 'DIMENSIONS'
2973       include 'DIMENSIONS.ZSCOPT'
2974       include 'COMMON.IOUNITS'
2975       include 'COMMON.GEO'
2976       include 'COMMON.VAR'
2977       include 'COMMON.LOCAL'
2978       include 'COMMON.CHAIN'
2979       include 'COMMON.VECTORS'
2980       include 'COMMON.DERIV'
2981       include 'COMMON.INTERACT'
2982       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2983 C Compute the local reference systems. For reference system (i), the
2984 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2985 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2986       do i=1,nres-1
2987 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2988           if (i.eq.nres-1) then
2989 C Case of the last full residue
2990 C Compute the Z-axis
2991             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2992             costh=dcos(pi-theta(nres))
2993             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2994             do k=1,3
2995               uz(k,i)=fac*uz(k,i)
2996             enddo
2997             if (calc_grad) then
2998 C Compute the derivatives of uz
2999             uzder(1,1,1)= 0.0d0
3000             uzder(2,1,1)=-dc_norm(3,i-1)
3001             uzder(3,1,1)= dc_norm(2,i-1)
3002             uzder(1,2,1)= dc_norm(3,i-1)
3003             uzder(2,2,1)= 0.0d0
3004             uzder(3,2,1)=-dc_norm(1,i-1)
3005             uzder(1,3,1)=-dc_norm(2,i-1)
3006             uzder(2,3,1)= dc_norm(1,i-1)
3007             uzder(3,3,1)= 0.0d0
3008             uzder(1,1,2)= 0.0d0
3009             uzder(2,1,2)= dc_norm(3,i)
3010             uzder(3,1,2)=-dc_norm(2,i)
3011             uzder(1,2,2)=-dc_norm(3,i)
3012             uzder(2,2,2)= 0.0d0
3013             uzder(3,2,2)= dc_norm(1,i)
3014             uzder(1,3,2)= dc_norm(2,i)
3015             uzder(2,3,2)=-dc_norm(1,i)
3016             uzder(3,3,2)= 0.0d0
3017             endif
3018 C Compute the Y-axis
3019             facy=fac
3020             do k=1,3
3021               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3022             enddo
3023             if (calc_grad) then
3024 C Compute the derivatives of uy
3025             do j=1,3
3026               do k=1,3
3027                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3028      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3029                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3030               enddo
3031               uyder(j,j,1)=uyder(j,j,1)-costh
3032               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3033             enddo
3034             do j=1,2
3035               do k=1,3
3036                 do l=1,3
3037                   uygrad(l,k,j,i)=uyder(l,k,j)
3038                   uzgrad(l,k,j,i)=uzder(l,k,j)
3039                 enddo
3040               enddo
3041             enddo
3042             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3043             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3044             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3045             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3046             endif
3047           else
3048 C Other residues
3049 C Compute the Z-axis
3050             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3051             costh=dcos(pi-theta(i+2))
3052             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3053             do k=1,3
3054               uz(k,i)=fac*uz(k,i)
3055             enddo
3056             if (calc_grad) then
3057 C Compute the derivatives of uz
3058             uzder(1,1,1)= 0.0d0
3059             uzder(2,1,1)=-dc_norm(3,i+1)
3060             uzder(3,1,1)= dc_norm(2,i+1)
3061             uzder(1,2,1)= dc_norm(3,i+1)
3062             uzder(2,2,1)= 0.0d0
3063             uzder(3,2,1)=-dc_norm(1,i+1)
3064             uzder(1,3,1)=-dc_norm(2,i+1)
3065             uzder(2,3,1)= dc_norm(1,i+1)
3066             uzder(3,3,1)= 0.0d0
3067             uzder(1,1,2)= 0.0d0
3068             uzder(2,1,2)= dc_norm(3,i)
3069             uzder(3,1,2)=-dc_norm(2,i)
3070             uzder(1,2,2)=-dc_norm(3,i)
3071             uzder(2,2,2)= 0.0d0
3072             uzder(3,2,2)= dc_norm(1,i)
3073             uzder(1,3,2)= dc_norm(2,i)
3074             uzder(2,3,2)=-dc_norm(1,i)
3075             uzder(3,3,2)= 0.0d0
3076             endif
3077 C Compute the Y-axis
3078             facy=fac
3079             do k=1,3
3080               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3081             enddo
3082             if (calc_grad) then
3083 C Compute the derivatives of uy
3084             do j=1,3
3085               do k=1,3
3086                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3087      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3088                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3089               enddo
3090               uyder(j,j,1)=uyder(j,j,1)-costh
3091               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3092             enddo
3093             do j=1,2
3094               do k=1,3
3095                 do l=1,3
3096                   uygrad(l,k,j,i)=uyder(l,k,j)
3097                   uzgrad(l,k,j,i)=uzder(l,k,j)
3098                 enddo
3099               enddo
3100             enddo
3101             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3102             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3103             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3104             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3105           endif
3106           endif
3107       enddo
3108       if (calc_grad) then
3109       do i=1,nres-1
3110         vbld_inv_temp(1)=vbld_inv(i+1)
3111         if (i.lt.nres-1) then
3112           vbld_inv_temp(2)=vbld_inv(i+2)
3113         else
3114           vbld_inv_temp(2)=vbld_inv(i)
3115         endif
3116         do j=1,2
3117           do k=1,3
3118             do l=1,3
3119               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3120               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3121             enddo
3122           enddo
3123         enddo
3124       enddo
3125       endif
3126       return
3127       end
3128 c------------------------------------------------------------------------------
3129       subroutine set_matrices
3130       implicit real*8 (a-h,o-z)
3131       include 'DIMENSIONS'
3132 #ifdef MPI
3133       include "mpif.h"
3134       integer IERR
3135       integer status(MPI_STATUS_SIZE)
3136 #endif
3137       include 'DIMENSIONS.ZSCOPT'
3138       include 'COMMON.IOUNITS'
3139       include 'COMMON.GEO'
3140       include 'COMMON.VAR'
3141       include 'COMMON.LOCAL'
3142       include 'COMMON.CHAIN'
3143       include 'COMMON.DERIV'
3144       include 'COMMON.INTERACT'
3145       include 'COMMON.CONTACTS'
3146       include 'COMMON.TORSION'
3147       include 'COMMON.VECTORS'
3148       include 'COMMON.FFIELD'
3149       double precision auxvec(2),auxmat(2,2)
3150 C
3151 C Compute the virtual-bond-torsional-angle dependent quantities needed
3152 C to calculate the el-loc multibody terms of various order.
3153 C
3154 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3155       do i=3,nres+1
3156         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3157           iti = itype2loc(itype(i-2))
3158         else
3159           iti=nloctyp
3160         endif
3161 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3162         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3163           iti1 = itype2loc(itype(i-1))
3164         else
3165           iti1=nloctyp
3166         endif
3167 #ifdef NEWCORR
3168         cost1=dcos(theta(i-1))
3169         sint1=dsin(theta(i-1))
3170         sint1sq=sint1*sint1
3171         sint1cub=sint1sq*sint1
3172         sint1cost1=2*sint1*cost1
3173 #ifdef DEBUG
3174         write (iout,*) "bnew1",i,iti
3175         write (iout,*) (bnew1(k,1,iti),k=1,3)
3176         write (iout,*) (bnew1(k,2,iti),k=1,3)
3177         write (iout,*) "bnew2",i,iti
3178         write (iout,*) (bnew2(k,1,iti),k=1,3)
3179         write (iout,*) (bnew2(k,2,iti),k=1,3)
3180 #endif
3181         do k=1,2
3182           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3183           b1(k,i-2)=sint1*b1k
3184           gtb1(k,i-2)=cost1*b1k-sint1sq*
3185      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3186           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3187           b2(k,i-2)=sint1*b2k
3188           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3189      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3190         enddo
3191         do k=1,2
3192           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3193           cc(1,k,i-2)=sint1sq*aux
3194           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3195      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3196           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3197           dd(1,k,i-2)=sint1sq*aux
3198           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3199      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3200         enddo
3201         cc(2,1,i-2)=cc(1,2,i-2)
3202         cc(2,2,i-2)=-cc(1,1,i-2)
3203         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3204         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3205         dd(2,1,i-2)=dd(1,2,i-2)
3206         dd(2,2,i-2)=-dd(1,1,i-2)
3207         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3208         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3209         do k=1,2
3210           do l=1,2
3211             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3212             EE(l,k,i-2)=sint1sq*aux
3213             if (calc_grad)
3214      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3215           enddo
3216         enddo
3217         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3218         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3219         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3220         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3221         if (calc_grad) then
3222         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3223         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3224         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3225         endif
3226 c        b1tilde(1,i-2)=b1(1,i-2)
3227 c        b1tilde(2,i-2)=-b1(2,i-2)
3228 c        b2tilde(1,i-2)=b2(1,i-2)
3229 c        b2tilde(2,i-2)=-b2(2,i-2)
3230 #ifdef DEBUG
3231         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3232         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3233         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3234         write (iout,*) 'theta=', theta(i-1)
3235 #endif
3236 #else
3237         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3238           iti = itype2loc(itype(i-2))
3239         else
3240           iti=nloctyp
3241         endif
3242 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3243         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3244           iti1 = itype2loc(itype(i-1))
3245         else
3246           iti1=nloctyp
3247         endif
3248         b1(1,i-2)=b(3,iti)
3249         b1(2,i-2)=b(5,iti)
3250         b2(1,i-2)=b(2,iti)
3251         b2(2,i-2)=b(4,iti)
3252         do k=1,2
3253           do l=1,2
3254            CC(k,l,i-2)=ccold(k,l,iti)
3255            DD(k,l,i-2)=ddold(k,l,iti)
3256            EE(k,l,i-2)=eeold(k,l,iti)
3257           enddo
3258         enddo
3259 #endif
3260         b1tilde(1,i-2)= b1(1,i-2)
3261         b1tilde(2,i-2)=-b1(2,i-2)
3262         b2tilde(1,i-2)= b2(1,i-2)
3263         b2tilde(2,i-2)=-b2(2,i-2)
3264 c
3265         Ctilde(1,1,i-2)= CC(1,1,i-2)
3266         Ctilde(1,2,i-2)= CC(1,2,i-2)
3267         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3268         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3269 c
3270         Dtilde(1,1,i-2)= DD(1,1,i-2)
3271         Dtilde(1,2,i-2)= DD(1,2,i-2)
3272         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3273         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3274 c        write(iout,*) "i",i," iti",iti
3275 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3276 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3277       enddo
3278       do i=3,nres+1
3279         if (i .lt. nres+1) then
3280           sin1=dsin(phi(i))
3281           cos1=dcos(phi(i))
3282           sintab(i-2)=sin1
3283           costab(i-2)=cos1
3284           obrot(1,i-2)=cos1
3285           obrot(2,i-2)=sin1
3286           sin2=dsin(2*phi(i))
3287           cos2=dcos(2*phi(i))
3288           sintab2(i-2)=sin2
3289           costab2(i-2)=cos2
3290           obrot2(1,i-2)=cos2
3291           obrot2(2,i-2)=sin2
3292           Ug(1,1,i-2)=-cos1
3293           Ug(1,2,i-2)=-sin1
3294           Ug(2,1,i-2)=-sin1
3295           Ug(2,2,i-2)= cos1
3296           Ug2(1,1,i-2)=-cos2
3297           Ug2(1,2,i-2)=-sin2
3298           Ug2(2,1,i-2)=-sin2
3299           Ug2(2,2,i-2)= cos2
3300         else
3301           costab(i-2)=1.0d0
3302           sintab(i-2)=0.0d0
3303           obrot(1,i-2)=1.0d0
3304           obrot(2,i-2)=0.0d0
3305           obrot2(1,i-2)=0.0d0
3306           obrot2(2,i-2)=0.0d0
3307           Ug(1,1,i-2)=1.0d0
3308           Ug(1,2,i-2)=0.0d0
3309           Ug(2,1,i-2)=0.0d0
3310           Ug(2,2,i-2)=1.0d0
3311           Ug2(1,1,i-2)=0.0d0
3312           Ug2(1,2,i-2)=0.0d0
3313           Ug2(2,1,i-2)=0.0d0
3314           Ug2(2,2,i-2)=0.0d0
3315         endif
3316         if (i .gt. 3 .and. i .lt. nres+1) then
3317           obrot_der(1,i-2)=-sin1
3318           obrot_der(2,i-2)= cos1
3319           Ugder(1,1,i-2)= sin1
3320           Ugder(1,2,i-2)=-cos1
3321           Ugder(2,1,i-2)=-cos1
3322           Ugder(2,2,i-2)=-sin1
3323           dwacos2=cos2+cos2
3324           dwasin2=sin2+sin2
3325           obrot2_der(1,i-2)=-dwasin2
3326           obrot2_der(2,i-2)= dwacos2
3327           Ug2der(1,1,i-2)= dwasin2
3328           Ug2der(1,2,i-2)=-dwacos2
3329           Ug2der(2,1,i-2)=-dwacos2
3330           Ug2der(2,2,i-2)=-dwasin2
3331         else
3332           obrot_der(1,i-2)=0.0d0
3333           obrot_der(2,i-2)=0.0d0
3334           Ugder(1,1,i-2)=0.0d0
3335           Ugder(1,2,i-2)=0.0d0
3336           Ugder(2,1,i-2)=0.0d0
3337           Ugder(2,2,i-2)=0.0d0
3338           obrot2_der(1,i-2)=0.0d0
3339           obrot2_der(2,i-2)=0.0d0
3340           Ug2der(1,1,i-2)=0.0d0
3341           Ug2der(1,2,i-2)=0.0d0
3342           Ug2der(2,1,i-2)=0.0d0
3343           Ug2der(2,2,i-2)=0.0d0
3344         endif
3345 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3346         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3347           iti = itype2loc(itype(i-2))
3348         else
3349           iti=nloctyp
3350         endif
3351 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3352         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3353           iti1 = itype2loc(itype(i-1))
3354         else
3355           iti1=nloctyp
3356         endif
3357 cd        write (iout,*) '*******i',i,' iti1',iti
3358 cd        write (iout,*) 'b1',b1(:,iti)
3359 cd        write (iout,*) 'b2',b2(:,iti)
3360 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3361 c        if (i .gt. iatel_s+2) then
3362         if (i .gt. nnt+2) then
3363           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3364 #ifdef NEWCORR
3365           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3366 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3367 #endif
3368 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3369 c     &    EE(1,2,iti),EE(2,2,i)
3370           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3371           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3372 c          write(iout,*) "Macierz EUG",
3373 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3374 c     &    eug(2,2,i-2)
3375           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3376      &    then
3377           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3378           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3379           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3380           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3381           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3382           endif
3383         else
3384           do k=1,2
3385             Ub2(k,i-2)=0.0d0
3386             Ctobr(k,i-2)=0.0d0
3387             Dtobr2(k,i-2)=0.0d0
3388             do l=1,2
3389               EUg(l,k,i-2)=0.0d0
3390               CUg(l,k,i-2)=0.0d0
3391               DUg(l,k,i-2)=0.0d0
3392               DtUg2(l,k,i-2)=0.0d0
3393             enddo
3394           enddo
3395         endif
3396         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3397         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3398         do k=1,2
3399           muder(k,i-2)=Ub2der(k,i-2)
3400         enddo
3401 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3402         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3403           if (itype(i-1).le.ntyp) then
3404             iti1 = itype2loc(itype(i-1))
3405           else
3406             iti1=nloctyp
3407           endif
3408         else
3409           iti1=nloctyp
3410         endif
3411         do k=1,2
3412           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3413         enddo
3414 #ifdef MUOUT
3415         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3416      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3417      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3418      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3419      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3420      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3421 #endif
3422 cd        write (iout,*) 'mu1',mu1(:,i-2)
3423 cd        write (iout,*) 'mu2',mu2(:,i-2)
3424         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3425      &  then
3426         if (calc_grad) then
3427         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3428         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3429         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3430         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3431         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3432         endif
3433 C Vectors and matrices dependent on a single virtual-bond dihedral.
3434         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3435         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3436         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3437         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3438         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3439         if (calc_grad) then
3440         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3441         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3442         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3443         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3444         endif
3445         endif
3446       enddo
3447 C Matrices dependent on two consecutive virtual-bond dihedrals.
3448 C The order of matrices is from left to right.
3449       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3450      &then
3451       do i=2,nres-1
3452         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3453         if (calc_grad) then
3454         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3455         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3456         endif
3457         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3458         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3459         if (calc_grad) then
3460         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3461         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3462         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3463         endif
3464       enddo
3465       endif
3466       return
3467       end
3468 C--------------------------------------------------------------------------
3469       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3470 C
3471 C This subroutine calculates the average interaction energy and its gradient
3472 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3473 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3474 C The potential depends both on the distance of peptide-group centers and on
3475 C the orientation of the CA-CA virtual bonds.
3476 C
3477       implicit real*8 (a-h,o-z)
3478 #ifdef MPI
3479       include 'mpif.h'
3480 #endif
3481       include 'DIMENSIONS'
3482       include 'DIMENSIONS.ZSCOPT'
3483       include 'COMMON.CONTROL'
3484       include 'COMMON.IOUNITS'
3485       include 'COMMON.GEO'
3486       include 'COMMON.VAR'
3487       include 'COMMON.LOCAL'
3488       include 'COMMON.CHAIN'
3489       include 'COMMON.DERIV'
3490       include 'COMMON.INTERACT'
3491       include 'COMMON.CONTACTS'
3492       include 'COMMON.TORSION'
3493       include 'COMMON.VECTORS'
3494       include 'COMMON.FFIELD'
3495       include 'COMMON.TIME1'
3496       include 'COMMON.SPLITELE'
3497       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3498      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3499       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3500      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3501       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3502      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3503      &    num_conti,j1,j2
3504 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3505 #ifdef MOMENT
3506       double precision scal_el /1.0d0/
3507 #else
3508       double precision scal_el /0.5d0/
3509 #endif
3510 C 12/13/98
3511 C 13-go grudnia roku pamietnego...
3512       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3513      &                   0.0d0,1.0d0,0.0d0,
3514      &                   0.0d0,0.0d0,1.0d0/
3515 cd      write(iout,*) 'In EELEC'
3516 cd      do i=1,nloctyp
3517 cd        write(iout,*) 'Type',i
3518 cd        write(iout,*) 'B1',B1(:,i)
3519 cd        write(iout,*) 'B2',B2(:,i)
3520 cd        write(iout,*) 'CC',CC(:,:,i)
3521 cd        write(iout,*) 'DD',DD(:,:,i)
3522 cd        write(iout,*) 'EE',EE(:,:,i)
3523 cd      enddo
3524 cd      call check_vecgrad
3525 cd      stop
3526       if (icheckgrad.eq.1) then
3527         do i=1,nres-1
3528           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3529           do k=1,3
3530             dc_norm(k,i)=dc(k,i)*fac
3531           enddo
3532 c          write (iout,*) 'i',i,' fac',fac
3533         enddo
3534       endif
3535       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3536      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3537      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3538 c        call vec_and_deriv
3539 #ifdef TIMING
3540         time01=MPI_Wtime()
3541 #endif
3542         call set_matrices
3543 #ifdef TIMING
3544         time_mat=time_mat+MPI_Wtime()-time01
3545 #endif
3546       endif
3547 cd      do i=1,nres-1
3548 cd        write (iout,*) 'i=',i
3549 cd        do k=1,3
3550 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3551 cd        enddo
3552 cd        do k=1,3
3553 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3554 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3555 cd        enddo
3556 cd      enddo
3557       t_eelecij=0.0d0
3558       ees=0.0D0
3559       evdw1=0.0D0
3560       eel_loc=0.0d0
3561       eello_turn3=0.0d0
3562       eello_turn4=0.0d0
3563       ind=0
3564       do i=1,nres
3565         num_cont_hb(i)=0
3566       enddo
3567 cd      print '(a)','Enter EELEC'
3568 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3569       do i=1,nres
3570         gel_loc_loc(i)=0.0d0
3571         gcorr_loc(i)=0.0d0
3572       enddo
3573 c
3574 c
3575 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3576 C
3577 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3578 C
3579 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3580       do i=iturn3_start,iturn3_end
3581 c        if (i.le.1) cycle
3582 C        write(iout,*) "tu jest i",i
3583         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3584 C changes suggested by Ana to avoid out of bounds
3585 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3586 c     & .or.((i+4).gt.nres)
3587 c     & .or.((i-1).le.0)
3588 C end of changes by Ana
3589 C dobra zmiana wycofana
3590      &  .or. itype(i+2).eq.ntyp1
3591      &  .or. itype(i+3).eq.ntyp1) cycle
3592 C Adam: Instructions below will switch off existing interactions
3593 c        if(i.gt.1)then
3594 c          if(itype(i-1).eq.ntyp1)cycle
3595 c        end if
3596 c        if(i.LT.nres-3)then
3597 c          if (itype(i+4).eq.ntyp1) cycle
3598 c        end if
3599         dxi=dc(1,i)
3600         dyi=dc(2,i)
3601         dzi=dc(3,i)
3602         dx_normi=dc_norm(1,i)
3603         dy_normi=dc_norm(2,i)
3604         dz_normi=dc_norm(3,i)
3605         xmedi=c(1,i)+0.5d0*dxi
3606         ymedi=c(2,i)+0.5d0*dyi
3607         zmedi=c(3,i)+0.5d0*dzi
3608           xmedi=mod(xmedi,boxxsize)
3609           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3610           ymedi=mod(ymedi,boxysize)
3611           if (ymedi.lt.0) ymedi=ymedi+boxysize
3612           zmedi=mod(zmedi,boxzsize)
3613           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3614         num_conti=0
3615         call eelecij(i,i+2,ees,evdw1,eel_loc)
3616         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3617         num_cont_hb(i)=num_conti
3618       enddo
3619       do i=iturn4_start,iturn4_end
3620         if (i.lt.1) cycle
3621         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3622 C changes suggested by Ana to avoid out of bounds
3623 c     & .or.((i+5).gt.nres)
3624 c     & .or.((i-1).le.0)
3625 C end of changes suggested by Ana
3626      &    .or. itype(i+3).eq.ntyp1
3627      &    .or. itype(i+4).eq.ntyp1
3628 c     &    .or. itype(i+5).eq.ntyp1
3629 c     &    .or. itype(i).eq.ntyp1
3630 c     &    .or. itype(i-1).eq.ntyp1
3631      &                             ) cycle
3632         dxi=dc(1,i)
3633         dyi=dc(2,i)
3634         dzi=dc(3,i)
3635         dx_normi=dc_norm(1,i)
3636         dy_normi=dc_norm(2,i)
3637         dz_normi=dc_norm(3,i)
3638         xmedi=c(1,i)+0.5d0*dxi
3639         ymedi=c(2,i)+0.5d0*dyi
3640         zmedi=c(3,i)+0.5d0*dzi
3641 C Return atom into box, boxxsize is size of box in x dimension
3642 c  194   continue
3643 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3644 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3645 C Condition for being inside the proper box
3646 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3647 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3648 c        go to 194
3649 c        endif
3650 c  195   continue
3651 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3652 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3653 C Condition for being inside the proper box
3654 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3655 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3656 c        go to 195
3657 c        endif
3658 c  196   continue
3659 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3660 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3661 C Condition for being inside the proper box
3662 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3663 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3664 c        go to 196
3665 c        endif
3666           xmedi=mod(xmedi,boxxsize)
3667           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3668           ymedi=mod(ymedi,boxysize)
3669           if (ymedi.lt.0) ymedi=ymedi+boxysize
3670           zmedi=mod(zmedi,boxzsize)
3671           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3672
3673         num_conti=num_cont_hb(i)
3674 c        write(iout,*) "JESTEM W PETLI"
3675         call eelecij(i,i+3,ees,evdw1,eel_loc)
3676         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3677      &   call eturn4(i,eello_turn4)
3678         num_cont_hb(i)=num_conti
3679       enddo   ! i
3680 C Loop over all neighbouring boxes
3681 C      do xshift=-1,1
3682 C      do yshift=-1,1
3683 C      do zshift=-1,1
3684 c
3685 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3686 c
3687 CTU KURWA
3688       do i=iatel_s,iatel_e
3689 C        do i=75,75
3690 c        if (i.le.1) cycle
3691         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3692 C changes suggested by Ana to avoid out of bounds
3693 c     & .or.((i+2).gt.nres)
3694 c     & .or.((i-1).le.0)
3695 C end of changes by Ana
3696 c     &  .or. itype(i+2).eq.ntyp1
3697 c     &  .or. itype(i-1).eq.ntyp1
3698      &                ) cycle
3699         dxi=dc(1,i)
3700         dyi=dc(2,i)
3701         dzi=dc(3,i)
3702         dx_normi=dc_norm(1,i)
3703         dy_normi=dc_norm(2,i)
3704         dz_normi=dc_norm(3,i)
3705         xmedi=c(1,i)+0.5d0*dxi
3706         ymedi=c(2,i)+0.5d0*dyi
3707         zmedi=c(3,i)+0.5d0*dzi
3708           xmedi=mod(xmedi,boxxsize)
3709           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3710           ymedi=mod(ymedi,boxysize)
3711           if (ymedi.lt.0) ymedi=ymedi+boxysize
3712           zmedi=mod(zmedi,boxzsize)
3713           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3714 C          xmedi=xmedi+xshift*boxxsize
3715 C          ymedi=ymedi+yshift*boxysize
3716 C          zmedi=zmedi+zshift*boxzsize
3717
3718 C Return tom into box, boxxsize is size of box in x dimension
3719 c  164   continue
3720 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3721 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3722 C Condition for being inside the proper box
3723 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3724 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3725 c        go to 164
3726 c        endif
3727 c  165   continue
3728 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3729 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3730 C Condition for being inside the proper box
3731 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3732 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3733 c        go to 165
3734 c        endif
3735 c  166   continue
3736 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3737 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3738 cC Condition for being inside the proper box
3739 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3740 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3741 c        go to 166
3742 c        endif
3743
3744 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3745         num_conti=num_cont_hb(i)
3746 C I TU KURWA
3747         do j=ielstart(i),ielend(i)
3748 C          do j=16,17
3749 C          write (iout,*) i,j
3750 C         if (j.le.1) cycle
3751           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3752 C changes suggested by Ana to avoid out of bounds
3753 c     & .or.((j+2).gt.nres)
3754 c     & .or.((j-1).le.0)
3755 C end of changes by Ana
3756 c     & .or.itype(j+2).eq.ntyp1
3757 c     & .or.itype(j-1).eq.ntyp1
3758      &) cycle
3759           call eelecij(i,j,ees,evdw1,eel_loc)
3760         enddo ! j
3761         num_cont_hb(i)=num_conti
3762       enddo   ! i
3763 C     enddo   ! zshift
3764 C      enddo   ! yshift
3765 C      enddo   ! xshift
3766
3767 c      write (iout,*) "Number of loop steps in EELEC:",ind
3768 cd      do i=1,nres
3769 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3770 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3771 cd      enddo
3772 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3773 ccc      eel_loc=eel_loc+eello_turn3
3774 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3775       return
3776       end
3777 C-------------------------------------------------------------------------------
3778       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3779       implicit real*8 (a-h,o-z)
3780       include 'DIMENSIONS'
3781       include 'DIMENSIONS.ZSCOPT'
3782 #ifdef MPI
3783       include "mpif.h"
3784 #endif
3785       include 'COMMON.CONTROL'
3786       include 'COMMON.IOUNITS'
3787       include 'COMMON.GEO'
3788       include 'COMMON.VAR'
3789       include 'COMMON.LOCAL'
3790       include 'COMMON.CHAIN'
3791       include 'COMMON.DERIV'
3792       include 'COMMON.INTERACT'
3793       include 'COMMON.CONTACTS'
3794       include 'COMMON.TORSION'
3795       include 'COMMON.VECTORS'
3796       include 'COMMON.FFIELD'
3797       include 'COMMON.TIME1'
3798       include 'COMMON.SPLITELE'
3799       include 'COMMON.SHIELD'
3800       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3801      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3802       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3803      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3804      &    gmuij2(4),gmuji2(4)
3805       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3806      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3807      &    num_conti,j1,j2
3808 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3809 #ifdef MOMENT
3810       double precision scal_el /1.0d0/
3811 #else
3812       double precision scal_el /0.5d0/
3813 #endif
3814 C 12/13/98
3815 C 13-go grudnia roku pamietnego...
3816       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3817      &                   0.0d0,1.0d0,0.0d0,
3818      &                   0.0d0,0.0d0,1.0d0/
3819        integer xshift,yshift,zshift
3820 c          time00=MPI_Wtime()
3821 cd      write (iout,*) "eelecij",i,j
3822 c          ind=ind+1
3823           iteli=itel(i)
3824           itelj=itel(j)
3825           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3826           aaa=app(iteli,itelj)
3827           bbb=bpp(iteli,itelj)
3828           ael6i=ael6(iteli,itelj)
3829           ael3i=ael3(iteli,itelj)
3830           dxj=dc(1,j)
3831           dyj=dc(2,j)
3832           dzj=dc(3,j)
3833           dx_normj=dc_norm(1,j)
3834           dy_normj=dc_norm(2,j)
3835           dz_normj=dc_norm(3,j)
3836 C          xj=c(1,j)+0.5D0*dxj-xmedi
3837 C          yj=c(2,j)+0.5D0*dyj-ymedi
3838 C          zj=c(3,j)+0.5D0*dzj-zmedi
3839           xj=c(1,j)+0.5D0*dxj
3840           yj=c(2,j)+0.5D0*dyj
3841           zj=c(3,j)+0.5D0*dzj
3842           xj=mod(xj,boxxsize)
3843           if (xj.lt.0) xj=xj+boxxsize
3844           yj=mod(yj,boxysize)
3845           if (yj.lt.0) yj=yj+boxysize
3846           zj=mod(zj,boxzsize)
3847           if (zj.lt.0) zj=zj+boxzsize
3848           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3849       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3850       xj_safe=xj
3851       yj_safe=yj
3852       zj_safe=zj
3853       isubchap=0
3854       do xshift=-1,1
3855       do yshift=-1,1
3856       do zshift=-1,1
3857           xj=xj_safe+xshift*boxxsize
3858           yj=yj_safe+yshift*boxysize
3859           zj=zj_safe+zshift*boxzsize
3860           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3861           if(dist_temp.lt.dist_init) then
3862             dist_init=dist_temp
3863             xj_temp=xj
3864             yj_temp=yj
3865             zj_temp=zj
3866             isubchap=1
3867           endif
3868        enddo
3869        enddo
3870        enddo
3871        if (isubchap.eq.1) then
3872           xj=xj_temp-xmedi
3873           yj=yj_temp-ymedi
3874           zj=zj_temp-zmedi
3875        else
3876           xj=xj_safe-xmedi
3877           yj=yj_safe-ymedi
3878           zj=zj_safe-zmedi
3879        endif
3880 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3881 c  174   continue
3882 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3883 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3884 C Condition for being inside the proper box
3885 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3886 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3887 c        go to 174
3888 c        endif
3889 c  175   continue
3890 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3891 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3892 C Condition for being inside the proper box
3893 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3894 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3895 c        go to 175
3896 c        endif
3897 c  176   continue
3898 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3899 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3900 C Condition for being inside the proper box
3901 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3902 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3903 c        go to 176
3904 c        endif
3905 C        endif !endPBC condintion
3906 C        xj=xj-xmedi
3907 C        yj=yj-ymedi
3908 C        zj=zj-zmedi
3909           rij=xj*xj+yj*yj+zj*zj
3910
3911             sss=sscale(sqrt(rij))
3912             sssgrad=sscagrad(sqrt(rij))
3913 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3914 c     &       " rlamb",rlamb," sss",sss
3915 c            if (sss.gt.0.0d0) then
3916           rrmij=1.0D0/rij
3917           rij=dsqrt(rij)
3918           rmij=1.0D0/rij
3919           r3ij=rrmij*rmij
3920           r6ij=r3ij*r3ij
3921           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3922           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3923           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3924           fac=cosa-3.0D0*cosb*cosg
3925           ev1=aaa*r6ij*r6ij
3926 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3927           if (j.eq.i+2) ev1=scal_el*ev1
3928           ev2=bbb*r6ij
3929           fac3=ael6i*r6ij
3930           fac4=ael3i*r3ij
3931           evdwij=(ev1+ev2)
3932           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3933           el2=fac4*fac
3934 C MARYSIA
3935 C          eesij=(el1+el2)
3936 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3937           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3938           if (shield_mode.gt.0) then
3939 C          fac_shield(i)=0.4
3940 C          fac_shield(j)=0.6
3941           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3942           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3943           eesij=(el1+el2)
3944           ees=ees+eesij
3945           else
3946           fac_shield(i)=1.0
3947           fac_shield(j)=1.0
3948           eesij=(el1+el2)
3949           ees=ees+eesij
3950           endif
3951           evdw1=evdw1+evdwij*sss
3952 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3953 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3954 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3955 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3956
3957           if (energy_dec) then
3958               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3959      &'evdw1',i,j,evdwij
3960      &,iteli,itelj,aaa,evdw1,sss
3961               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3962      &fac_shield(i),fac_shield(j)
3963           endif
3964
3965 C
3966 C Calculate contributions to the Cartesian gradient.
3967 C
3968 #ifdef SPLITELE
3969           facvdw=-6*rrmij*(ev1+evdwij)*sss
3970           facel=-3*rrmij*(el1+eesij)
3971           fac1=fac
3972           erij(1)=xj*rmij
3973           erij(2)=yj*rmij
3974           erij(3)=zj*rmij
3975
3976 *
3977 * Radial derivatives. First process both termini of the fragment (i,j)
3978 *
3979           if (calc_grad) then
3980           ggg(1)=facel*xj
3981           ggg(2)=facel*yj
3982           ggg(3)=facel*zj
3983           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3984      &  (shield_mode.gt.0)) then
3985 C          print *,i,j
3986           do ilist=1,ishield_list(i)
3987            iresshield=shield_list(ilist,i)
3988            do k=1,3
3989            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3990      &      *2.0
3991            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3992      &              rlocshield
3993      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3994             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3995 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3996 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3997 C             if (iresshield.gt.i) then
3998 C               do ishi=i+1,iresshield-1
3999 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4000 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4001 C
4002 C              enddo
4003 C             else
4004 C               do ishi=iresshield,i
4005 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4006 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4007 C
4008 C               enddo
4009 C              endif
4010            enddo
4011           enddo
4012           do ilist=1,ishield_list(j)
4013            iresshield=shield_list(ilist,j)
4014            do k=1,3
4015            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4016      &     *2.0
4017            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4018      &              rlocshield
4019      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4020            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4021
4022 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4023 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4024 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4025 C             if (iresshield.gt.j) then
4026 C               do ishi=j+1,iresshield-1
4027 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4028 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4029 C
4030 C               enddo
4031 C            else
4032 C               do ishi=iresshield,j
4033 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4034 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4035 C               enddo
4036 C              endif
4037            enddo
4038           enddo
4039
4040           do k=1,3
4041             gshieldc(k,i)=gshieldc(k,i)+
4042      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4043             gshieldc(k,j)=gshieldc(k,j)+
4044      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4045             gshieldc(k,i-1)=gshieldc(k,i-1)+
4046      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4047             gshieldc(k,j-1)=gshieldc(k,j-1)+
4048      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4049
4050            enddo
4051            endif
4052 c          do k=1,3
4053 c            ghalf=0.5D0*ggg(k)
4054 c            gelc(k,i)=gelc(k,i)+ghalf
4055 c            gelc(k,j)=gelc(k,j)+ghalf
4056 c          enddo
4057 c 9/28/08 AL Gradient compotents will be summed only at the end
4058 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4059           do k=1,3
4060             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4061 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4062             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4063 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4064 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4065 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4066 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4067 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4068           enddo
4069 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4070
4071 *
4072 * Loop over residues i+1 thru j-1.
4073 *
4074 cgrad          do k=i+1,j-1
4075 cgrad            do l=1,3
4076 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4077 cgrad            enddo
4078 cgrad          enddo
4079           if (sss.gt.0.0) then
4080           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4081           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4082           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4083           else
4084           ggg(1)=0.0
4085           ggg(2)=0.0
4086           ggg(3)=0.0
4087           endif
4088 c          do k=1,3
4089 c            ghalf=0.5D0*ggg(k)
4090 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4091 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4092 c          enddo
4093 c 9/28/08 AL Gradient compotents will be summed only at the end
4094           do k=1,3
4095             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4096             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4097           enddo
4098 *
4099 * Loop over residues i+1 thru j-1.
4100 *
4101 cgrad          do k=i+1,j-1
4102 cgrad            do l=1,3
4103 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4104 cgrad            enddo
4105 cgrad          enddo
4106           endif ! calc_grad
4107 #else
4108 C MARYSIA
4109           facvdw=(ev1+evdwij)*sss
4110           facel=(el1+eesij)
4111           fac1=fac
4112           fac=-3*rrmij*(facvdw+facvdw+facel)
4113           erij(1)=xj*rmij
4114           erij(2)=yj*rmij
4115           erij(3)=zj*rmij
4116 *
4117 * Radial derivatives. First process both termini of the fragment (i,j)
4118 *
4119           if (calc_grad) then
4120           ggg(1)=fac*xj
4121 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4122           ggg(2)=fac*yj
4123 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4124           ggg(3)=fac*zj
4125 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4126 c          do k=1,3
4127 c            ghalf=0.5D0*ggg(k)
4128 c            gelc(k,i)=gelc(k,i)+ghalf
4129 c            gelc(k,j)=gelc(k,j)+ghalf
4130 c          enddo
4131 c 9/28/08 AL Gradient compotents will be summed only at the end
4132           do k=1,3
4133             gelc_long(k,j)=gelc(k,j)+ggg(k)
4134             gelc_long(k,i)=gelc(k,i)-ggg(k)
4135           enddo
4136 *
4137 * Loop over residues i+1 thru j-1.
4138 *
4139 cgrad          do k=i+1,j-1
4140 cgrad            do l=1,3
4141 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4142 cgrad            enddo
4143 cgrad          enddo
4144 c 9/28/08 AL Gradient compotents will be summed only at the end
4145           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4146           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4147           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4148           do k=1,3
4149             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4150             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4151           enddo
4152           endif ! calc_grad
4153 #endif
4154 *
4155 * Angular part
4156 *
4157           if (calc_grad) then
4158           ecosa=2.0D0*fac3*fac1+fac4
4159           fac4=-3.0D0*fac4
4160           fac3=-6.0D0*fac3
4161           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4162           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4163           do k=1,3
4164             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4165             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4166           enddo
4167 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4168 cd   &          (dcosg(k),k=1,3)
4169           do k=1,3
4170             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4171      &      fac_shield(i)**2*fac_shield(j)**2
4172           enddo
4173 c          do k=1,3
4174 c            ghalf=0.5D0*ggg(k)
4175 c            gelc(k,i)=gelc(k,i)+ghalf
4176 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4177 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4178 c            gelc(k,j)=gelc(k,j)+ghalf
4179 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4180 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4181 c          enddo
4182 cgrad          do k=i+1,j-1
4183 cgrad            do l=1,3
4184 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4185 cgrad            enddo
4186 cgrad          enddo
4187 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4188           do k=1,3
4189             gelc(k,i)=gelc(k,i)
4190      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4191      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4192      &           *fac_shield(i)**2*fac_shield(j)**2
4193             gelc(k,j)=gelc(k,j)
4194      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4195      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4196      &           *fac_shield(i)**2*fac_shield(j)**2
4197             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4198             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4199           enddo
4200 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4201
4202 C MARYSIA
4203 c          endif !sscale
4204           endif ! calc_grad
4205           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4206      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4207      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4208 C
4209 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4210 C   energy of a peptide unit is assumed in the form of a second-order
4211 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4212 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4213 C   are computed for EVERY pair of non-contiguous peptide groups.
4214 C
4215
4216           if (j.lt.nres-1) then
4217             j1=j+1
4218             j2=j-1
4219           else
4220             j1=j-1
4221             j2=j-2
4222           endif
4223           kkk=0
4224           lll=0
4225           do k=1,2
4226             do l=1,2
4227               kkk=kkk+1
4228               muij(kkk)=mu(k,i)*mu(l,j)
4229 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4230 #ifdef NEWCORR
4231              if (calc_grad) then
4232              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4233 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4234              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4235              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4236 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4237              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4238              endif
4239 #endif
4240             enddo
4241           enddo
4242 #ifdef DEBUG
4243           write (iout,*) 'EELEC: i',i,' j',j
4244           write (iout,*) 'j',j,' j1',j1,' j2',j2
4245           write(iout,*) 'muij',muij
4246           write (iout,*) "uy",uy(:,i)
4247           write (iout,*) "uz",uz(:,j)
4248           write (iout,*) "erij",erij
4249 #endif
4250           ury=scalar(uy(1,i),erij)
4251           urz=scalar(uz(1,i),erij)
4252           vry=scalar(uy(1,j),erij)
4253           vrz=scalar(uz(1,j),erij)
4254           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4255           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4256           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4257           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4258           fac=dsqrt(-ael6i)*r3ij
4259           a22=a22*fac
4260           a23=a23*fac
4261           a32=a32*fac
4262           a33=a33*fac
4263 cd          write (iout,'(4i5,4f10.5)')
4264 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4265 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4266 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4267 cd     &      uy(:,j),uz(:,j)
4268 cd          write (iout,'(4f10.5)')
4269 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4270 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4271 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4272 cd           write (iout,'(9f10.5/)')
4273 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4274 C Derivatives of the elements of A in virtual-bond vectors
4275           if (calc_grad) then
4276           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4277           do k=1,3
4278             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4279             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4280             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4281             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4282             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4283             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4284             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4285             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4286             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4287             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4288             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4289             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4290           enddo
4291 C Compute radial contributions to the gradient
4292           facr=-3.0d0*rrmij
4293           a22der=a22*facr
4294           a23der=a23*facr
4295           a32der=a32*facr
4296           a33der=a33*facr
4297           agg(1,1)=a22der*xj
4298           agg(2,1)=a22der*yj
4299           agg(3,1)=a22der*zj
4300           agg(1,2)=a23der*xj
4301           agg(2,2)=a23der*yj
4302           agg(3,2)=a23der*zj
4303           agg(1,3)=a32der*xj
4304           agg(2,3)=a32der*yj
4305           agg(3,3)=a32der*zj
4306           agg(1,4)=a33der*xj
4307           agg(2,4)=a33der*yj
4308           agg(3,4)=a33der*zj
4309 C Add the contributions coming from er
4310           fac3=-3.0d0*fac
4311           do k=1,3
4312             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4313             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4314             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4315             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4316           enddo
4317           do k=1,3
4318 C Derivatives in DC(i)
4319 cgrad            ghalf1=0.5d0*agg(k,1)
4320 cgrad            ghalf2=0.5d0*agg(k,2)
4321 cgrad            ghalf3=0.5d0*agg(k,3)
4322 cgrad            ghalf4=0.5d0*agg(k,4)
4323             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4324      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4325             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4326      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4327             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4328      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4329             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4330      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4331 C Derivatives in DC(i+1)
4332             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4333      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4334             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4335      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4336             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4337      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4338             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4339      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4340 C Derivatives in DC(j)
4341             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4342      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4343             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4344      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4345             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4346      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4347             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4348      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4349 C Derivatives in DC(j+1) or DC(nres-1)
4350             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4351      &      -3.0d0*vryg(k,3)*ury)
4352             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4353      &      -3.0d0*vrzg(k,3)*ury)
4354             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4355      &      -3.0d0*vryg(k,3)*urz)
4356             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4357      &      -3.0d0*vrzg(k,3)*urz)
4358 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4359 cgrad              do l=1,4
4360 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4361 cgrad              enddo
4362 cgrad            endif
4363           enddo
4364           endif ! calc_grad
4365           acipa(1,1)=a22
4366           acipa(1,2)=a23
4367           acipa(2,1)=a32
4368           acipa(2,2)=a33
4369           a22=-a22
4370           a23=-a23
4371           if (calc_grad) then
4372           do l=1,2
4373             do k=1,3
4374               agg(k,l)=-agg(k,l)
4375               aggi(k,l)=-aggi(k,l)
4376               aggi1(k,l)=-aggi1(k,l)
4377               aggj(k,l)=-aggj(k,l)
4378               aggj1(k,l)=-aggj1(k,l)
4379             enddo
4380           enddo
4381           endif ! calc_grad
4382           if (j.lt.nres-1) then
4383             a22=-a22
4384             a32=-a32
4385             do l=1,3,2
4386               do k=1,3
4387                 agg(k,l)=-agg(k,l)
4388                 aggi(k,l)=-aggi(k,l)
4389                 aggi1(k,l)=-aggi1(k,l)
4390                 aggj(k,l)=-aggj(k,l)
4391                 aggj1(k,l)=-aggj1(k,l)
4392               enddo
4393             enddo
4394           else
4395             a22=-a22
4396             a23=-a23
4397             a32=-a32
4398             a33=-a33
4399             do l=1,4
4400               do k=1,3
4401                 agg(k,l)=-agg(k,l)
4402                 aggi(k,l)=-aggi(k,l)
4403                 aggi1(k,l)=-aggi1(k,l)
4404                 aggj(k,l)=-aggj(k,l)
4405                 aggj1(k,l)=-aggj1(k,l)
4406               enddo
4407             enddo
4408           endif
4409           ENDIF ! WCORR
4410           IF (wel_loc.gt.0.0d0) THEN
4411 C Contribution to the local-electrostatic energy coming from the i-j pair
4412           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4413      &     +a33*muij(4)
4414 #ifdef DEBUG
4415           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4416      &     " a33",a33
4417           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4418      &     " wel_loc",wel_loc
4419 #endif
4420           if (shield_mode.eq.0) then
4421            fac_shield(i)=1.0
4422            fac_shield(j)=1.0
4423 C          else
4424 C           fac_shield(i)=0.4
4425 C           fac_shield(j)=0.6
4426           endif
4427           eel_loc_ij=eel_loc_ij
4428      &    *fac_shield(i)*fac_shield(j)
4429           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4430      &            'eelloc',i,j,eel_loc_ij
4431 c           if (eel_loc_ij.ne.0)
4432 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4433 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4434
4435           eel_loc=eel_loc+eel_loc_ij
4436 C Now derivative over eel_loc
4437           if (calc_grad) then
4438           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4439      &  (shield_mode.gt.0)) then
4440 C          print *,i,j
4441
4442           do ilist=1,ishield_list(i)
4443            iresshield=shield_list(ilist,i)
4444            do k=1,3
4445            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4446      &                                          /fac_shield(i)
4447 C     &      *2.0
4448            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4449      &              rlocshield
4450      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4451             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4452      &      +rlocshield
4453            enddo
4454           enddo
4455           do ilist=1,ishield_list(j)
4456            iresshield=shield_list(ilist,j)
4457            do k=1,3
4458            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4459      &                                       /fac_shield(j)
4460 C     &     *2.0
4461            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4462      &              rlocshield
4463      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4464            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4465      &             +rlocshield
4466
4467            enddo
4468           enddo
4469
4470           do k=1,3
4471             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4472      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4473             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4474      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4475             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4476      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4477             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4478      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4479            enddo
4480            endif
4481
4482
4483 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4484 c     &                     ' eel_loc_ij',eel_loc_ij
4485 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4486 C Calculate patrial derivative for theta angle
4487 #ifdef NEWCORR
4488          geel_loc_ij=(a22*gmuij1(1)
4489      &     +a23*gmuij1(2)
4490      &     +a32*gmuij1(3)
4491      &     +a33*gmuij1(4))
4492      &    *fac_shield(i)*fac_shield(j)
4493 c         write(iout,*) "derivative over thatai"
4494 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4495 c     &   a33*gmuij1(4)
4496          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4497      &      geel_loc_ij*wel_loc
4498 c         write(iout,*) "derivative over thatai-1"
4499 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4500 c     &   a33*gmuij2(4)
4501          geel_loc_ij=
4502      &     a22*gmuij2(1)
4503      &     +a23*gmuij2(2)
4504      &     +a32*gmuij2(3)
4505      &     +a33*gmuij2(4)
4506          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4507      &      geel_loc_ij*wel_loc
4508      &    *fac_shield(i)*fac_shield(j)
4509
4510 c  Derivative over j residue
4511          geel_loc_ji=a22*gmuji1(1)
4512      &     +a23*gmuji1(2)
4513      &     +a32*gmuji1(3)
4514      &     +a33*gmuji1(4)
4515 c         write(iout,*) "derivative over thataj"
4516 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4517 c     &   a33*gmuji1(4)
4518
4519         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4520      &      geel_loc_ji*wel_loc
4521      &    *fac_shield(i)*fac_shield(j)
4522
4523          geel_loc_ji=
4524      &     +a22*gmuji2(1)
4525      &     +a23*gmuji2(2)
4526      &     +a32*gmuji2(3)
4527      &     +a33*gmuji2(4)
4528 c         write(iout,*) "derivative over thataj-1"
4529 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4530 c     &   a33*gmuji2(4)
4531          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4532      &      geel_loc_ji*wel_loc
4533      &    *fac_shield(i)*fac_shield(j)
4534 #endif
4535 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4536
4537 C Partial derivatives in virtual-bond dihedral angles gamma
4538           if (i.gt.1)
4539      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4540      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4541      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4542      &    *fac_shield(i)*fac_shield(j)
4543
4544           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4545      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4546      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4547      &    *fac_shield(i)*fac_shield(j)
4548 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4549           do l=1,3
4550             ggg(l)=(agg(l,1)*muij(1)+
4551      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4552      &    *fac_shield(i)*fac_shield(j)
4553             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4554             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4555 cgrad            ghalf=0.5d0*ggg(l)
4556 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4557 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4558           enddo
4559 cgrad          do k=i+1,j2
4560 cgrad            do l=1,3
4561 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4562 cgrad            enddo
4563 cgrad          enddo
4564 C Remaining derivatives of eello
4565           do l=1,3
4566             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4567      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4568      &    *fac_shield(i)*fac_shield(j)
4569
4570             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4571      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4572      &    *fac_shield(i)*fac_shield(j)
4573
4574             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4575      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4576      &    *fac_shield(i)*fac_shield(j)
4577
4578             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4579      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4580      &    *fac_shield(i)*fac_shield(j)
4581
4582           enddo
4583           endif ! calc_grad
4584           ENDIF
4585
4586
4587 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4588 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4589           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4590      &       .and. num_conti.le.maxconts) then
4591 c            write (iout,*) i,j," entered corr"
4592 C
4593 C Calculate the contact function. The ith column of the array JCONT will
4594 C contain the numbers of atoms that make contacts with the atom I (of numbers
4595 C greater than I). The arrays FACONT and GACONT will contain the values of
4596 C the contact function and its derivative.
4597 c           r0ij=1.02D0*rpp(iteli,itelj)
4598 c           r0ij=1.11D0*rpp(iteli,itelj)
4599             r0ij=2.20D0*rpp(iteli,itelj)
4600 c           r0ij=1.55D0*rpp(iteli,itelj)
4601             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4602             if (fcont.gt.0.0D0) then
4603               num_conti=num_conti+1
4604               if (num_conti.gt.maxconts) then
4605                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4606      &                         ' will skip next contacts for this conf.'
4607               else
4608                 jcont_hb(num_conti,i)=j
4609 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4610 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4611                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4612      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4613 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4614 C  terms.
4615                 d_cont(num_conti,i)=rij
4616 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4617 C     --- Electrostatic-interaction matrix ---
4618                 a_chuj(1,1,num_conti,i)=a22
4619                 a_chuj(1,2,num_conti,i)=a23
4620                 a_chuj(2,1,num_conti,i)=a32
4621                 a_chuj(2,2,num_conti,i)=a33
4622 C     --- Gradient of rij
4623                 if (calc_grad) then
4624                 do kkk=1,3
4625                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4626                 enddo
4627                 kkll=0
4628                 do k=1,2
4629                   do l=1,2
4630                     kkll=kkll+1
4631                     do m=1,3
4632                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4633                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4634                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4635                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4636                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4637                     enddo
4638                   enddo
4639                 enddo
4640                 endif ! calc_grad
4641                 ENDIF
4642                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4643 C Calculate contact energies
4644                 cosa4=4.0D0*cosa
4645                 wij=cosa-3.0D0*cosb*cosg
4646                 cosbg1=cosb+cosg
4647                 cosbg2=cosb-cosg
4648 c               fac3=dsqrt(-ael6i)/r0ij**3
4649                 fac3=dsqrt(-ael6i)*r3ij
4650 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4651                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4652                 if (ees0tmp.gt.0) then
4653                   ees0pij=dsqrt(ees0tmp)
4654                 else
4655                   ees0pij=0
4656                 endif
4657 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4658                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4659                 if (ees0tmp.gt.0) then
4660                   ees0mij=dsqrt(ees0tmp)
4661                 else
4662                   ees0mij=0
4663                 endif
4664 c               ees0mij=0.0D0
4665                 if (shield_mode.eq.0) then
4666                 fac_shield(i)=1.0d0
4667                 fac_shield(j)=1.0d0
4668                 else
4669                 ees0plist(num_conti,i)=j
4670 C                fac_shield(i)=0.4d0
4671 C                fac_shield(j)=0.6d0
4672                 endif
4673                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4674      &          *fac_shield(i)*fac_shield(j)
4675                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4676      &          *fac_shield(i)*fac_shield(j)
4677 C Diagnostics. Comment out or remove after debugging!
4678 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4679 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4680 c               ees0m(num_conti,i)=0.0D0
4681 C End diagnostics.
4682 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4683 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4684 C Angular derivatives of the contact function
4685
4686                 ees0pij1=fac3/ees0pij
4687                 ees0mij1=fac3/ees0mij
4688                 fac3p=-3.0D0*fac3*rrmij
4689                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4690                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4691 c               ees0mij1=0.0D0
4692                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4693                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4694                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4695                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4696                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4697                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4698                 ecosap=ecosa1+ecosa2
4699                 ecosbp=ecosb1+ecosb2
4700                 ecosgp=ecosg1+ecosg2
4701                 ecosam=ecosa1-ecosa2
4702                 ecosbm=ecosb1-ecosb2
4703                 ecosgm=ecosg1-ecosg2
4704 C Diagnostics
4705 c               ecosap=ecosa1
4706 c               ecosbp=ecosb1
4707 c               ecosgp=ecosg1
4708 c               ecosam=0.0D0
4709 c               ecosbm=0.0D0
4710 c               ecosgm=0.0D0
4711 C End diagnostics
4712                 facont_hb(num_conti,i)=fcont
4713
4714                 if (calc_grad) then
4715                 fprimcont=fprimcont/rij
4716 cd              facont_hb(num_conti,i)=1.0D0
4717 C Following line is for diagnostics.
4718 cd              fprimcont=0.0D0
4719                 do k=1,3
4720                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4721                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4722                 enddo
4723                 do k=1,3
4724                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4725                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4726                 enddo
4727                 gggp(1)=gggp(1)+ees0pijp*xj
4728                 gggp(2)=gggp(2)+ees0pijp*yj
4729                 gggp(3)=gggp(3)+ees0pijp*zj
4730                 gggm(1)=gggm(1)+ees0mijp*xj
4731                 gggm(2)=gggm(2)+ees0mijp*yj
4732                 gggm(3)=gggm(3)+ees0mijp*zj
4733 C Derivatives due to the contact function
4734                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4735                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4736                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4737                 do k=1,3
4738 c
4739 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4740 c          following the change of gradient-summation algorithm.
4741 c
4742 cgrad                  ghalfp=0.5D0*gggp(k)
4743 cgrad                  ghalfm=0.5D0*gggm(k)
4744                   gacontp_hb1(k,num_conti,i)=!ghalfp
4745      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4746      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4747      &          *fac_shield(i)*fac_shield(j)
4748
4749                   gacontp_hb2(k,num_conti,i)=!ghalfp
4750      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4751      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4752      &          *fac_shield(i)*fac_shield(j)
4753
4754                   gacontp_hb3(k,num_conti,i)=gggp(k)
4755      &          *fac_shield(i)*fac_shield(j)
4756
4757                   gacontm_hb1(k,num_conti,i)=!ghalfm
4758      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4759      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4760      &          *fac_shield(i)*fac_shield(j)
4761
4762                   gacontm_hb2(k,num_conti,i)=!ghalfm
4763      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4764      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4765      &          *fac_shield(i)*fac_shield(j)
4766
4767                   gacontm_hb3(k,num_conti,i)=gggm(k)
4768      &          *fac_shield(i)*fac_shield(j)
4769
4770                 enddo
4771 C Diagnostics. Comment out or remove after debugging!
4772 cdiag           do k=1,3
4773 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4774 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4775 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4776 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4777 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4778 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4779 cdiag           enddo
4780
4781                  endif ! calc_grad
4782
4783               ENDIF ! wcorr
4784               endif  ! num_conti.le.maxconts
4785             endif  ! fcont.gt.0
4786           endif    ! j.gt.i+1
4787           if (calc_grad) then
4788           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4789             do k=1,4
4790               do l=1,3
4791                 ghalf=0.5d0*agg(l,k)
4792                 aggi(l,k)=aggi(l,k)+ghalf
4793                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4794                 aggj(l,k)=aggj(l,k)+ghalf
4795               enddo
4796             enddo
4797             if (j.eq.nres-1 .and. i.lt.j-2) then
4798               do k=1,4
4799                 do l=1,3
4800                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4801                 enddo
4802               enddo
4803             endif
4804           endif
4805           endif ! calc_grad
4806 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4807       return
4808       end
4809 C-----------------------------------------------------------------------------
4810       subroutine eturn3(i,eello_turn3)
4811 C Third- and fourth-order contributions from turns
4812       implicit real*8 (a-h,o-z)
4813       include 'DIMENSIONS'
4814       include 'DIMENSIONS.ZSCOPT'
4815       include 'COMMON.IOUNITS'
4816       include 'COMMON.GEO'
4817       include 'COMMON.VAR'
4818       include 'COMMON.LOCAL'
4819       include 'COMMON.CHAIN'
4820       include 'COMMON.DERIV'
4821       include 'COMMON.INTERACT'
4822       include 'COMMON.CONTACTS'
4823       include 'COMMON.TORSION'
4824       include 'COMMON.VECTORS'
4825       include 'COMMON.FFIELD'
4826       include 'COMMON.CONTROL'
4827       include 'COMMON.SHIELD'
4828       dimension ggg(3)
4829       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4830      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4831      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4832      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4833      &  auxgmat2(2,2),auxgmatt2(2,2)
4834       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4835      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4836       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4837      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4838      &    num_conti,j1,j2
4839       j=i+2
4840 c      write (iout,*) "eturn3",i,j,j1,j2
4841       a_temp(1,1)=a22
4842       a_temp(1,2)=a23
4843       a_temp(2,1)=a32
4844       a_temp(2,2)=a33
4845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4846 C
4847 C               Third-order contributions
4848 C
4849 C                 (i+2)o----(i+3)
4850 C                      | |
4851 C                      | |
4852 C                 (i+1)o----i
4853 C
4854 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4855 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4856         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4857 c auxalary matices for theta gradient
4858 c auxalary matrix for i+1 and constant i+2
4859         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4860 c auxalary matrix for i+2 and constant i+1
4861         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4862         call transpose2(auxmat(1,1),auxmat1(1,1))
4863         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4864         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4865         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4866         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4867         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4868         if (shield_mode.eq.0) then
4869         fac_shield(i)=1.0
4870         fac_shield(j)=1.0
4871 C        else
4872 C        fac_shield(i)=0.4
4873 C        fac_shield(j)=0.6
4874         endif
4875         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4876      &  *fac_shield(i)*fac_shield(j)
4877         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4878      &  *fac_shield(i)*fac_shield(j)
4879         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4880      &    eello_t3
4881         if (calc_grad) then
4882 C#ifdef NEWCORR
4883 C Derivatives in theta
4884         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4885      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4886      &   *fac_shield(i)*fac_shield(j)
4887         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4888      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4889      &   *fac_shield(i)*fac_shield(j)
4890 C#endif
4891
4892 C Derivatives in shield mode
4893           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4894      &  (shield_mode.gt.0)) then
4895 C          print *,i,j
4896
4897           do ilist=1,ishield_list(i)
4898            iresshield=shield_list(ilist,i)
4899            do k=1,3
4900            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4901 C     &      *2.0
4902            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4903      &              rlocshield
4904      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4905             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4906      &      +rlocshield
4907            enddo
4908           enddo
4909           do ilist=1,ishield_list(j)
4910            iresshield=shield_list(ilist,j)
4911            do k=1,3
4912            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4913 C     &     *2.0
4914            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4915      &              rlocshield
4916      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4917            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4918      &             +rlocshield
4919
4920            enddo
4921           enddo
4922
4923           do k=1,3
4924             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4925      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4926             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4927      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4928             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4929      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4930             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4931      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4932            enddo
4933            endif
4934
4935 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4936 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4937 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4938 cd     &    ' eello_turn3_num',4*eello_turn3_num
4939 C Derivatives in gamma(i)
4940         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4941         call transpose2(auxmat2(1,1),auxmat3(1,1))
4942         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4943         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4944      &   *fac_shield(i)*fac_shield(j)
4945 C Derivatives in gamma(i+1)
4946         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4947         call transpose2(auxmat2(1,1),auxmat3(1,1))
4948         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4949         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4950      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4951      &   *fac_shield(i)*fac_shield(j)
4952 C Cartesian derivatives
4953         do l=1,3
4954 c            ghalf1=0.5d0*agg(l,1)
4955 c            ghalf2=0.5d0*agg(l,2)
4956 c            ghalf3=0.5d0*agg(l,3)
4957 c            ghalf4=0.5d0*agg(l,4)
4958           a_temp(1,1)=aggi(l,1)!+ghalf1
4959           a_temp(1,2)=aggi(l,2)!+ghalf2
4960           a_temp(2,1)=aggi(l,3)!+ghalf3
4961           a_temp(2,2)=aggi(l,4)!+ghalf4
4962           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4963           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4964      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4965      &   *fac_shield(i)*fac_shield(j)
4966
4967           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4968           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4969           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4970           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4971           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4972           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4973      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4974      &   *fac_shield(i)*fac_shield(j)
4975           a_temp(1,1)=aggj(l,1)!+ghalf1
4976           a_temp(1,2)=aggj(l,2)!+ghalf2
4977           a_temp(2,1)=aggj(l,3)!+ghalf3
4978           a_temp(2,2)=aggj(l,4)!+ghalf4
4979           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4980           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4981      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4982      &   *fac_shield(i)*fac_shield(j)
4983           a_temp(1,1)=aggj1(l,1)
4984           a_temp(1,2)=aggj1(l,2)
4985           a_temp(2,1)=aggj1(l,3)
4986           a_temp(2,2)=aggj1(l,4)
4987           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4988           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4989      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4990      &   *fac_shield(i)*fac_shield(j)
4991         enddo
4992
4993         endif ! calc_grad
4994
4995       return
4996       end
4997 C-------------------------------------------------------------------------------
4998       subroutine eturn4(i,eello_turn4)
4999 C Third- and fourth-order contributions from turns
5000       implicit real*8 (a-h,o-z)
5001       include 'DIMENSIONS'
5002       include 'DIMENSIONS.ZSCOPT'
5003       include 'COMMON.IOUNITS'
5004       include 'COMMON.GEO'
5005       include 'COMMON.VAR'
5006       include 'COMMON.LOCAL'
5007       include 'COMMON.CHAIN'
5008       include 'COMMON.DERIV'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.CONTACTS'
5011       include 'COMMON.TORSION'
5012       include 'COMMON.VECTORS'
5013       include 'COMMON.FFIELD'
5014       include 'COMMON.CONTROL'
5015       include 'COMMON.SHIELD'
5016       dimension ggg(3)
5017       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5018      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5019      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5020      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5021      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5022      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5023      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5024       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5025      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5026       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5027      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5028      &    num_conti,j1,j2
5029       j=i+3
5030 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5031 C
5032 C               Fourth-order contributions
5033 C
5034 C                 (i+3)o----(i+4)
5035 C                     /  |
5036 C               (i+2)o   |
5037 C                     \  |
5038 C                 (i+1)o----i
5039 C
5040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5041 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5042 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5043 c        write(iout,*)"WCHODZE W PROGRAM"
5044         a_temp(1,1)=a22
5045         a_temp(1,2)=a23
5046         a_temp(2,1)=a32
5047         a_temp(2,2)=a33
5048         iti1=itype2loc(itype(i+1))
5049         iti2=itype2loc(itype(i+2))
5050         iti3=itype2loc(itype(i+3))
5051 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5052         call transpose2(EUg(1,1,i+1),e1t(1,1))
5053         call transpose2(Eug(1,1,i+2),e2t(1,1))
5054         call transpose2(Eug(1,1,i+3),e3t(1,1))
5055 C Ematrix derivative in theta
5056         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5057         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5058         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5059         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5060 c       eta1 in derivative theta
5061         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5062         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5063 c       auxgvec is derivative of Ub2 so i+3 theta
5064         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5065 c       auxalary matrix of E i+1
5066         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5067 c        s1=0.0
5068 c        gs1=0.0
5069         s1=scalar2(b1(1,i+2),auxvec(1))
5070 c derivative of theta i+2 with constant i+3
5071         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5072 c derivative of theta i+2 with constant i+2
5073         gs32=scalar2(b1(1,i+2),auxgvec(1))
5074 c derivative of E matix in theta of i+1
5075         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5076
5077         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5078 c       ea31 in derivative theta
5079         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5080         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5081 c auxilary matrix auxgvec of Ub2 with constant E matirx
5082         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5083 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5084         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5085
5086 c        s2=0.0
5087 c        gs2=0.0
5088         s2=scalar2(b1(1,i+1),auxvec(1))
5089 c derivative of theta i+1 with constant i+3
5090         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5091 c derivative of theta i+2 with constant i+1
5092         gs21=scalar2(b1(1,i+1),auxgvec(1))
5093 c derivative of theta i+3 with constant i+1
5094         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5095 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5096 c     &  gtb1(1,i+1)
5097         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5098 c two derivatives over diffetent matrices
5099 c gtae3e2 is derivative over i+3
5100         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5101 c ae3gte2 is derivative over i+2
5102         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5103         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5104 c three possible derivative over theta E matices
5105 c i+1
5106         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5107 c i+2
5108         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5109 c i+3
5110         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5111         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5112
5113         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5114         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5115         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5116         if (shield_mode.eq.0) then
5117         fac_shield(i)=1.0
5118         fac_shield(j)=1.0
5119 C        else
5120 C        fac_shield(i)=0.6
5121 C        fac_shield(j)=0.4
5122         endif
5123         eello_turn4=eello_turn4-(s1+s2+s3)
5124      &  *fac_shield(i)*fac_shield(j)
5125         eello_t4=-(s1+s2+s3)
5126      &  *fac_shield(i)*fac_shield(j)
5127 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5128         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5129      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5130 C Now derivative over shield:
5131           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5132      &  (shield_mode.gt.0)) then
5133 C          print *,i,j
5134
5135           do ilist=1,ishield_list(i)
5136            iresshield=shield_list(ilist,i)
5137            do k=1,3
5138            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5139 C     &      *2.0
5140            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5141      &              rlocshield
5142      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5143             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5144      &      +rlocshield
5145            enddo
5146           enddo
5147           do ilist=1,ishield_list(j)
5148            iresshield=shield_list(ilist,j)
5149            do k=1,3
5150            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5151 C     &     *2.0
5152            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5153      &              rlocshield
5154      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5155            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5156      &             +rlocshield
5157
5158            enddo
5159           enddo
5160
5161           do k=1,3
5162             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5163      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5164             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5165      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5166             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5167      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5168             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5169      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5170            enddo
5171            endif
5172 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5173 cd     &    ' eello_turn4_num',8*eello_turn4_num
5174 #ifdef NEWCORR
5175         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5176      &                  -(gs13+gsE13+gsEE1)*wturn4
5177      &  *fac_shield(i)*fac_shield(j)
5178         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5179      &                    -(gs23+gs21+gsEE2)*wturn4
5180      &  *fac_shield(i)*fac_shield(j)
5181
5182         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5183      &                    -(gs32+gsE31+gsEE3)*wturn4
5184      &  *fac_shield(i)*fac_shield(j)
5185
5186 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5187 c     &   gs2
5188 #endif
5189         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5190      &      'eturn4',i,j,-(s1+s2+s3)
5191 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5192 c     &    ' eello_turn4_num',8*eello_turn4_num
5193 C Derivatives in gamma(i)
5194         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5195         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5196         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5197         s1=scalar2(b1(1,i+2),auxvec(1))
5198         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5199         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5200         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5201      &  *fac_shield(i)*fac_shield(j)
5202 C Derivatives in gamma(i+1)
5203         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5204         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5205         s2=scalar2(b1(1,i+1),auxvec(1))
5206         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5207         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5208         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5209         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5210      &  *fac_shield(i)*fac_shield(j)
5211 C Derivatives in gamma(i+2)
5212         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5213         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5214         s1=scalar2(b1(1,i+2),auxvec(1))
5215         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5216         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5217         s2=scalar2(b1(1,i+1),auxvec(1))
5218         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5219         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5220         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5221         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5222      &  *fac_shield(i)*fac_shield(j)
5223         if (calc_grad) then
5224 C Cartesian derivatives
5225 C Derivatives of this turn contributions in DC(i+2)
5226         if (j.lt.nres-1) then
5227           do l=1,3
5228             a_temp(1,1)=agg(l,1)
5229             a_temp(1,2)=agg(l,2)
5230             a_temp(2,1)=agg(l,3)
5231             a_temp(2,2)=agg(l,4)
5232             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5233             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234             s1=scalar2(b1(1,i+2),auxvec(1))
5235             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5236             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237             s2=scalar2(b1(1,i+1),auxvec(1))
5238             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5239             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5240             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5241             ggg(l)=-(s1+s2+s3)
5242             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5243      &  *fac_shield(i)*fac_shield(j)
5244           enddo
5245         endif
5246 C Remaining derivatives of this turn contribution
5247         do l=1,3
5248           a_temp(1,1)=aggi(l,1)
5249           a_temp(1,2)=aggi(l,2)
5250           a_temp(2,1)=aggi(l,3)
5251           a_temp(2,2)=aggi(l,4)
5252           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5253           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5254           s1=scalar2(b1(1,i+2),auxvec(1))
5255           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5256           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5257           s2=scalar2(b1(1,i+1),auxvec(1))
5258           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5259           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5261           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5262      &  *fac_shield(i)*fac_shield(j)
5263           a_temp(1,1)=aggi1(l,1)
5264           a_temp(1,2)=aggi1(l,2)
5265           a_temp(2,1)=aggi1(l,3)
5266           a_temp(2,2)=aggi1(l,4)
5267           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5268           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5269           s1=scalar2(b1(1,i+2),auxvec(1))
5270           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5271           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5272           s2=scalar2(b1(1,i+1),auxvec(1))
5273           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5274           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5275           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5276           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5277      &  *fac_shield(i)*fac_shield(j)
5278           a_temp(1,1)=aggj(l,1)
5279           a_temp(1,2)=aggj(l,2)
5280           a_temp(2,1)=aggj(l,3)
5281           a_temp(2,2)=aggj(l,4)
5282           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5283           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5284           s1=scalar2(b1(1,i+2),auxvec(1))
5285           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5286           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5287           s2=scalar2(b1(1,i+1),auxvec(1))
5288           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5289           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5290           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5291           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5292      &  *fac_shield(i)*fac_shield(j)
5293           a_temp(1,1)=aggj1(l,1)
5294           a_temp(1,2)=aggj1(l,2)
5295           a_temp(2,1)=aggj1(l,3)
5296           a_temp(2,2)=aggj1(l,4)
5297           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5298           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5299           s1=scalar2(b1(1,i+2),auxvec(1))
5300           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5301           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5302           s2=scalar2(b1(1,i+1),auxvec(1))
5303           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5304           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5305           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5306 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5307           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5308      &  *fac_shield(i)*fac_shield(j)
5309         enddo
5310
5311         endif ! calc_grad
5312
5313       return
5314       end
5315 C-----------------------------------------------------------------------------
5316       subroutine vecpr(u,v,w)
5317       implicit real*8(a-h,o-z)
5318       dimension u(3),v(3),w(3)
5319       w(1)=u(2)*v(3)-u(3)*v(2)
5320       w(2)=-u(1)*v(3)+u(3)*v(1)
5321       w(3)=u(1)*v(2)-u(2)*v(1)
5322       return
5323       end
5324 C-----------------------------------------------------------------------------
5325       subroutine unormderiv(u,ugrad,unorm,ungrad)
5326 C This subroutine computes the derivatives of a normalized vector u, given
5327 C the derivatives computed without normalization conditions, ugrad. Returns
5328 C ungrad.
5329       implicit none
5330       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5331       double precision vec(3)
5332       double precision scalar
5333       integer i,j
5334 c      write (2,*) 'ugrad',ugrad
5335 c      write (2,*) 'u',u
5336       do i=1,3
5337         vec(i)=scalar(ugrad(1,i),u(1))
5338       enddo
5339 c      write (2,*) 'vec',vec
5340       do i=1,3
5341         do j=1,3
5342           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5343         enddo
5344       enddo
5345 c      write (2,*) 'ungrad',ungrad
5346       return
5347       end
5348 C-----------------------------------------------------------------------------
5349       subroutine escp(evdw2,evdw2_14)
5350 C
5351 C This subroutine calculates the excluded-volume interaction energy between
5352 C peptide-group centers and side chains and its gradient in virtual-bond and
5353 C side-chain vectors.
5354 C
5355       implicit real*8 (a-h,o-z)
5356       include 'DIMENSIONS'
5357       include 'DIMENSIONS.ZSCOPT'
5358       include 'COMMON.GEO'
5359       include 'COMMON.VAR'
5360       include 'COMMON.LOCAL'
5361       include 'COMMON.CHAIN'
5362       include 'COMMON.DERIV'
5363       include 'COMMON.INTERACT'
5364       include 'COMMON.FFIELD'
5365       include 'COMMON.IOUNITS'
5366       dimension ggg(3)
5367       evdw2=0.0D0
5368       evdw2_14=0.0d0
5369 cd    print '(a)','Enter ESCP'
5370 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5371 c     &  ' scal14',scal14
5372       do i=iatscp_s,iatscp_e
5373         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5374         iteli=itel(i)
5375 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5376 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5377         if (iteli.eq.0) goto 1225
5378         xi=0.5D0*(c(1,i)+c(1,i+1))
5379         yi=0.5D0*(c(2,i)+c(2,i+1))
5380         zi=0.5D0*(c(3,i)+c(3,i+1))
5381 C Returning the ith atom to box
5382           xi=mod(xi,boxxsize)
5383           if (xi.lt.0) xi=xi+boxxsize
5384           yi=mod(yi,boxysize)
5385           if (yi.lt.0) yi=yi+boxysize
5386           zi=mod(zi,boxzsize)
5387           if (zi.lt.0) zi=zi+boxzsize
5388         do iint=1,nscp_gr(i)
5389
5390         do j=iscpstart(i,iint),iscpend(i,iint)
5391           itypj=iabs(itype(j))
5392           if (itypj.eq.ntyp1) cycle
5393 C Uncomment following three lines for SC-p interactions
5394 c         xj=c(1,nres+j)-xi
5395 c         yj=c(2,nres+j)-yi
5396 c         zj=c(3,nres+j)-zi
5397 C Uncomment following three lines for Ca-p interactions
5398           xj=c(1,j)
5399           yj=c(2,j)
5400           zj=c(3,j)
5401 C returning the jth atom to box
5402           xj=mod(xj,boxxsize)
5403           if (xj.lt.0) xj=xj+boxxsize
5404           yj=mod(yj,boxysize)
5405           if (yj.lt.0) yj=yj+boxysize
5406           zj=mod(zj,boxzsize)
5407           if (zj.lt.0) zj=zj+boxzsize
5408       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5409       xj_safe=xj
5410       yj_safe=yj
5411       zj_safe=zj
5412       subchap=0
5413 C Finding the closest jth atom
5414       do xshift=-1,1
5415       do yshift=-1,1
5416       do zshift=-1,1
5417           xj=xj_safe+xshift*boxxsize
5418           yj=yj_safe+yshift*boxysize
5419           zj=zj_safe+zshift*boxzsize
5420           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5421           if(dist_temp.lt.dist_init) then
5422             dist_init=dist_temp
5423             xj_temp=xj
5424             yj_temp=yj
5425             zj_temp=zj
5426             subchap=1
5427           endif
5428        enddo
5429        enddo
5430        enddo
5431        if (subchap.eq.1) then
5432           xj=xj_temp-xi
5433           yj=yj_temp-yi
5434           zj=zj_temp-zi
5435        else
5436           xj=xj_safe-xi
5437           yj=yj_safe-yi
5438           zj=zj_safe-zi
5439        endif
5440           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5441 C sss is scaling function for smoothing the cutoff gradient otherwise
5442 C the gradient would not be continuouse
5443           sss=sscale(1.0d0/(dsqrt(rrij)))
5444           if (sss.le.0.0d0) cycle
5445           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5446           fac=rrij**expon2
5447           e1=fac*fac*aad(itypj,iteli)
5448           e2=fac*bad(itypj,iteli)
5449           if (iabs(j-i) .le. 2) then
5450             e1=scal14*e1
5451             e2=scal14*e2
5452             evdw2_14=evdw2_14+(e1+e2)*sss
5453           endif
5454           evdwij=e1+e2
5455 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5456 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5457 c     &       bad(itypj,iteli)
5458           evdw2=evdw2+evdwij*sss
5459           if (calc_grad) then
5460 C
5461 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5462 C
5463           fac=-(evdwij+e1)*rrij*sss
5464           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5465           ggg(1)=xj*fac
5466           ggg(2)=yj*fac
5467           ggg(3)=zj*fac
5468           if (j.lt.i) then
5469 cd          write (iout,*) 'j<i'
5470 C Uncomment following three lines for SC-p interactions
5471 c           do k=1,3
5472 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5473 c           enddo
5474           else
5475 cd          write (iout,*) 'j>i'
5476             do k=1,3
5477               ggg(k)=-ggg(k)
5478 C Uncomment following line for SC-p interactions
5479 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5480             enddo
5481           endif
5482           do k=1,3
5483             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5484           enddo
5485           kstart=min0(i+1,j)
5486           kend=max0(i-1,j-1)
5487 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5488 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5489           do k=kstart,kend
5490             do l=1,3
5491               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5492             enddo
5493           enddo
5494           endif ! calc_grad
5495         enddo
5496         enddo ! iint
5497  1225   continue
5498       enddo ! i
5499       do i=1,nct
5500         do j=1,3
5501           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5502           gradx_scp(j,i)=expon*gradx_scp(j,i)
5503         enddo
5504       enddo
5505 C******************************************************************************
5506 C
5507 C                              N O T E !!!
5508 C
5509 C To save time the factor EXPON has been extracted from ALL components
5510 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5511 C use!
5512 C
5513 C******************************************************************************
5514       return
5515       end
5516 C--------------------------------------------------------------------------
5517       subroutine edis(ehpb)
5518 C
5519 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5520 C
5521       implicit real*8 (a-h,o-z)
5522       include 'DIMENSIONS'
5523       include 'DIMENSIONS.ZSCOPT'
5524       include 'COMMON.SBRIDGE'
5525       include 'COMMON.CHAIN'
5526       include 'COMMON.DERIV'
5527       include 'COMMON.VAR'
5528       include 'COMMON.INTERACT'
5529       include 'COMMON.CONTROL'
5530       include 'COMMON.IOUNITS'
5531       dimension ggg(3)
5532       ehpb=0.0D0
5533 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5534 cd    print *,'link_start=',link_start,' link_end=',link_end
5535 C      write(iout,*) link_end, "link_end"
5536       if (link_end.eq.0) return
5537       do i=link_start,link_end
5538 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5539 C CA-CA distance used in regularization of structure.
5540         ii=ihpb(i)
5541         jj=jhpb(i)
5542 C iii and jjj point to the residues for which the distance is assigned.
5543         if (ii.gt.nres) then
5544           iii=ii-nres
5545           jjj=jj-nres
5546         else
5547           iii=ii
5548           jjj=jj
5549         endif
5550 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5551 C    distance and angle dependent SS bond potential.
5552 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5553 C     & iabs(itype(jjj)).eq.1) then
5554 C       write(iout,*) constr_dist,"const"
5555        if (.not.dyn_ss .and. i.le.nss) then
5556          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5557      & iabs(itype(jjj)).eq.1) then
5558           call ssbond_ene(iii,jjj,eij)
5559           ehpb=ehpb+2*eij
5560            endif !ii.gt.neres
5561         else if (ii.gt.nres .and. jj.gt.nres) then
5562 c Restraints from contact prediction
5563           dd=dist(ii,jj)
5564           if (constr_dist.eq.11) then
5565 C            ehpb=ehpb+fordepth(i)**4.0d0
5566 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5567             ehpb=ehpb+fordepth(i)**4.0d0
5568      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5569             fac=fordepth(i)**4.0d0
5570      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5571 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5572 C     &    ehpb,fordepth(i),dd
5573 C            write(iout,*) ehpb,"atu?"
5574 C            ehpb,"tu?"
5575 C            fac=fordepth(i)**4.0d0
5576 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5577            else
5578           if (dhpb1(i).gt.0.0d0) then
5579             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5580             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5581 c            write (iout,*) "beta nmr",
5582 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5583           else
5584             dd=dist(ii,jj)
5585             rdis=dd-dhpb(i)
5586 C Get the force constant corresponding to this distance.
5587             waga=forcon(i)
5588 C Calculate the contribution to energy.
5589             ehpb=ehpb+waga*rdis*rdis
5590 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5591 C
5592 C Evaluate gradient.
5593 C
5594             fac=waga*rdis/dd
5595           endif !end dhpb1(i).gt.0
5596           endif !end const_dist=11
5597           do j=1,3
5598             ggg(j)=fac*(c(j,jj)-c(j,ii))
5599           enddo
5600           do j=1,3
5601             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5602             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5603           enddo
5604           do k=1,3
5605             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5606             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5607           enddo
5608         else !ii.gt.nres
5609 C          write(iout,*) "before"
5610           dd=dist(ii,jj)
5611 C          write(iout,*) "after",dd
5612           if (constr_dist.eq.11) then
5613             ehpb=ehpb+fordepth(i)**4.0d0
5614      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5615             fac=fordepth(i)**4.0d0
5616      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5617 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5618 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5619 C            print *,ehpb,"tu?"
5620 C            write(iout,*) ehpb,"btu?",
5621 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5622 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5623 C     &    ehpb,fordepth(i),dd
5624            else
5625           if (dhpb1(i).gt.0.0d0) then
5626             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5627             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5628 c            write (iout,*) "alph nmr",
5629 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5630           else
5631             rdis=dd-dhpb(i)
5632 C Get the force constant corresponding to this distance.
5633             waga=forcon(i)
5634 C Calculate the contribution to energy.
5635             ehpb=ehpb+waga*rdis*rdis
5636 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5637 C
5638 C Evaluate gradient.
5639 C
5640             fac=waga*rdis/dd
5641           endif
5642           endif
5643
5644         do j=1,3
5645           ggg(j)=fac*(c(j,jj)-c(j,ii))
5646         enddo
5647 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5648 C If this is a SC-SC distance, we need to calculate the contributions to the
5649 C Cartesian gradient in the SC vectors (ghpbx).
5650         if (iii.lt.ii) then
5651           do j=1,3
5652             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5653             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5654           enddo
5655         endif
5656         do j=iii,jjj-1
5657           do k=1,3
5658             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5659           enddo
5660         enddo
5661         endif
5662       enddo
5663       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5664       return
5665       end
5666 C--------------------------------------------------------------------------
5667       subroutine ssbond_ene(i,j,eij)
5668 C
5669 C Calculate the distance and angle dependent SS-bond potential energy
5670 C using a free-energy function derived based on RHF/6-31G** ab initio
5671 C calculations of diethyl disulfide.
5672 C
5673 C A. Liwo and U. Kozlowska, 11/24/03
5674 C
5675       implicit real*8 (a-h,o-z)
5676       include 'DIMENSIONS'
5677       include 'DIMENSIONS.ZSCOPT'
5678       include 'COMMON.SBRIDGE'
5679       include 'COMMON.CHAIN'
5680       include 'COMMON.DERIV'
5681       include 'COMMON.LOCAL'
5682       include 'COMMON.INTERACT'
5683       include 'COMMON.VAR'
5684       include 'COMMON.IOUNITS'
5685       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5686       itypi=iabs(itype(i))
5687       xi=c(1,nres+i)
5688       yi=c(2,nres+i)
5689       zi=c(3,nres+i)
5690       dxi=dc_norm(1,nres+i)
5691       dyi=dc_norm(2,nres+i)
5692       dzi=dc_norm(3,nres+i)
5693       dsci_inv=dsc_inv(itypi)
5694       itypj=iabs(itype(j))
5695       dscj_inv=dsc_inv(itypj)
5696       xj=c(1,nres+j)-xi
5697       yj=c(2,nres+j)-yi
5698       zj=c(3,nres+j)-zi
5699       dxj=dc_norm(1,nres+j)
5700       dyj=dc_norm(2,nres+j)
5701       dzj=dc_norm(3,nres+j)
5702       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5703       rij=dsqrt(rrij)
5704       erij(1)=xj*rij
5705       erij(2)=yj*rij
5706       erij(3)=zj*rij
5707       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5708       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5709       om12=dxi*dxj+dyi*dyj+dzi*dzj
5710       do k=1,3
5711         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5712         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5713       enddo
5714       rij=1.0d0/rij
5715       deltad=rij-d0cm
5716       deltat1=1.0d0-om1
5717       deltat2=1.0d0+om2
5718       deltat12=om2-om1+2.0d0
5719       cosphi=om12-om1*om2
5720       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5721      &  +akct*deltad*deltat12
5722      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5723 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5724 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5725 c     &  " deltat12",deltat12," eij",eij
5726       ed=2*akcm*deltad+akct*deltat12
5727       pom1=akct*deltad
5728       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5729       eom1=-2*akth*deltat1-pom1-om2*pom2
5730       eom2= 2*akth*deltat2+pom1-om1*pom2
5731       eom12=pom2
5732       do k=1,3
5733         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5734       enddo
5735       do k=1,3
5736         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5737      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5738         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5739      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5740       enddo
5741 C
5742 C Calculate the components of the gradient in DC and X
5743 C
5744       do k=i,j-1
5745         do l=1,3
5746           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5747         enddo
5748       enddo
5749       return
5750       end
5751 C--------------------------------------------------------------------------
5752       subroutine ebond(estr)
5753 c
5754 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5755 c
5756       implicit real*8 (a-h,o-z)
5757       include 'DIMENSIONS'
5758       include 'DIMENSIONS.ZSCOPT'
5759       include 'COMMON.LOCAL'
5760       include 'COMMON.GEO'
5761       include 'COMMON.INTERACT'
5762       include 'COMMON.DERIV'
5763       include 'COMMON.VAR'
5764       include 'COMMON.CHAIN'
5765       include 'COMMON.IOUNITS'
5766       include 'COMMON.NAMES'
5767       include 'COMMON.FFIELD'
5768       include 'COMMON.CONTROL'
5769       double precision u(3),ud(3)
5770       estr=0.0d0
5771       estr1=0.0d0
5772 c      write (iout,*) "distchainmax",distchainmax
5773       do i=nnt+1,nct
5774         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5775 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5776 C          do j=1,3
5777 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5778 C     &      *dc(j,i-1)/vbld(i)
5779 C          enddo
5780 C          if (energy_dec) write(iout,*)
5781 C     &       "estr1",i,vbld(i),distchainmax,
5782 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5783 C        else
5784          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5785         diff = vbld(i)-vbldpDUM
5786 C         write(iout,*) i,diff
5787          else
5788           diff = vbld(i)-vbldp0
5789 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5790          endif
5791           estr=estr+diff*diff
5792           do j=1,3
5793             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5794           enddo
5795 C        endif
5796 C        write (iout,'(a7,i5,4f7.3)')
5797 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5798       enddo
5799       estr=0.5d0*AKP*estr+estr1
5800 c
5801 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5802 c
5803       do i=nnt,nct
5804         iti=iabs(itype(i))
5805         if (iti.ne.10 .and. iti.ne.ntyp1) then
5806           nbi=nbondterm(iti)
5807           if (nbi.eq.1) then
5808             diff=vbld(i+nres)-vbldsc0(1,iti)
5809 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5810 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5811             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5812             do j=1,3
5813               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5814             enddo
5815           else
5816             do j=1,nbi
5817               diff=vbld(i+nres)-vbldsc0(j,iti)
5818               ud(j)=aksc(j,iti)*diff
5819               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5820             enddo
5821             uprod=u(1)
5822             do j=2,nbi
5823               uprod=uprod*u(j)
5824             enddo
5825             usum=0.0d0
5826             usumsqder=0.0d0
5827             do j=1,nbi
5828               uprod1=1.0d0
5829               uprod2=1.0d0
5830               do k=1,nbi
5831                 if (k.ne.j) then
5832                   uprod1=uprod1*u(k)
5833                   uprod2=uprod2*u(k)*u(k)
5834                 endif
5835               enddo
5836               usum=usum+uprod1
5837               usumsqder=usumsqder+ud(j)*uprod2
5838             enddo
5839 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5840 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5841             estr=estr+uprod/usum
5842             do j=1,3
5843              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5844             enddo
5845           endif
5846         endif
5847       enddo
5848       return
5849       end
5850 #ifdef CRYST_THETA
5851 C--------------------------------------------------------------------------
5852       subroutine ebend(etheta,ethetacnstr)
5853 C
5854 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5855 C angles gamma and its derivatives in consecutive thetas and gammas.
5856 C
5857       implicit real*8 (a-h,o-z)
5858       include 'DIMENSIONS'
5859       include 'DIMENSIONS.ZSCOPT'
5860       include 'COMMON.LOCAL'
5861       include 'COMMON.GEO'
5862       include 'COMMON.INTERACT'
5863       include 'COMMON.DERIV'
5864       include 'COMMON.VAR'
5865       include 'COMMON.CHAIN'
5866       include 'COMMON.IOUNITS'
5867       include 'COMMON.NAMES'
5868       include 'COMMON.FFIELD'
5869       include 'COMMON.TORCNSTR'
5870       common /calcthet/ term1,term2,termm,diffak,ratak,
5871      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5872      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5873       double precision y(2),z(2)
5874       delta=0.02d0*pi
5875 c      time11=dexp(-2*time)
5876 c      time12=1.0d0
5877       etheta=0.0D0
5878 c      write (iout,*) "nres",nres
5879 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5880 c      write (iout,*) ithet_start,ithet_end
5881       do i=ithet_start,ithet_end
5882 C        if (itype(i-1).eq.ntyp1) cycle
5883         if (i.le.2) cycle
5884         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5885      &  .or.itype(i).eq.ntyp1) cycle
5886 C Zero the energy function and its derivative at 0 or pi.
5887         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5888         it=itype(i-1)
5889         ichir1=isign(1,itype(i-2))
5890         ichir2=isign(1,itype(i))
5891          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5892          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5893          if (itype(i-1).eq.10) then
5894           itype1=isign(10,itype(i-2))
5895           ichir11=isign(1,itype(i-2))
5896           ichir12=isign(1,itype(i-2))
5897           itype2=isign(10,itype(i))
5898           ichir21=isign(1,itype(i))
5899           ichir22=isign(1,itype(i))
5900          endif
5901          if (i.eq.3) then
5902           y(1)=0.0D0
5903           y(2)=0.0D0
5904           else
5905
5906         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5907 #ifdef OSF
5908           phii=phi(i)
5909 c          icrc=0
5910 c          call proc_proc(phii,icrc)
5911           if (icrc.eq.1) phii=150.0
5912 #else
5913           phii=phi(i)
5914 #endif
5915           y(1)=dcos(phii)
5916           y(2)=dsin(phii)
5917         else
5918           y(1)=0.0D0
5919           y(2)=0.0D0
5920         endif
5921         endif
5922         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5923 #ifdef OSF
5924           phii1=phi(i+1)
5925 c          icrc=0
5926 c          call proc_proc(phii1,icrc)
5927           if (icrc.eq.1) phii1=150.0
5928           phii1=pinorm(phii1)
5929           z(1)=cos(phii1)
5930 #else
5931           phii1=phi(i+1)
5932           z(1)=dcos(phii1)
5933 #endif
5934           z(2)=dsin(phii1)
5935         else
5936           z(1)=0.0D0
5937           z(2)=0.0D0
5938         endif
5939 C Calculate the "mean" value of theta from the part of the distribution
5940 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5941 C In following comments this theta will be referred to as t_c.
5942         thet_pred_mean=0.0d0
5943         do k=1,2
5944             athetk=athet(k,it,ichir1,ichir2)
5945             bthetk=bthet(k,it,ichir1,ichir2)
5946           if (it.eq.10) then
5947              athetk=athet(k,itype1,ichir11,ichir12)
5948              bthetk=bthet(k,itype2,ichir21,ichir22)
5949           endif
5950           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5951         enddo
5952 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5953         dthett=thet_pred_mean*ssd
5954         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5955 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5956 C Derivatives of the "mean" values in gamma1 and gamma2.
5957         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5958      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5959          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5960      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5961          if (it.eq.10) then
5962       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5963      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5964         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5965      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5966          endif
5967         if (theta(i).gt.pi-delta) then
5968           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5969      &         E_tc0)
5970           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5971           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5972           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5973      &        E_theta)
5974           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5975      &        E_tc)
5976         else if (theta(i).lt.delta) then
5977           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5978           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5979           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5980      &        E_theta)
5981           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5982           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5983      &        E_tc)
5984         else
5985           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5986      &        E_theta,E_tc)
5987         endif
5988         etheta=etheta+ethetai
5989 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5990 c     &      'ebend',i,ethetai,theta(i),itype(i)
5991 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5992 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5993         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5994         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5995         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5996 c 1215   continue
5997       enddo
5998       ethetacnstr=0.0d0
5999 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6000       do i=1,ntheta_constr
6001         itheta=itheta_constr(i)
6002         thetiii=theta(itheta)
6003         difi=pinorm(thetiii-theta_constr0(i))
6004         if (difi.gt.theta_drange(i)) then
6005           difi=difi-theta_drange(i)
6006           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6007           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6008      &    +for_thet_constr(i)*difi**3
6009         else if (difi.lt.-drange(i)) then
6010           difi=difi+drange(i)
6011           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6012           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6013      &    +for_thet_constr(i)*difi**3
6014         else
6015           difi=0.0
6016         endif
6017 C       if (energy_dec) then
6018 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6019 C     &    i,itheta,rad2deg*thetiii,
6020 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6021 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6022 C     &    gloc(itheta+nphi-2,icg)
6023 C        endif
6024       enddo
6025 C Ufff.... We've done all this!!!
6026       return
6027       end
6028 C---------------------------------------------------------------------------
6029       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6030      &     E_tc)
6031       implicit real*8 (a-h,o-z)
6032       include 'DIMENSIONS'
6033       include 'COMMON.LOCAL'
6034       include 'COMMON.IOUNITS'
6035       common /calcthet/ term1,term2,termm,diffak,ratak,
6036      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6037      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6038 C Calculate the contributions to both Gaussian lobes.
6039 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6040 C The "polynomial part" of the "standard deviation" of this part of
6041 C the distribution.
6042         sig=polthet(3,it)
6043         do j=2,0,-1
6044           sig=sig*thet_pred_mean+polthet(j,it)
6045         enddo
6046 C Derivative of the "interior part" of the "standard deviation of the"
6047 C gamma-dependent Gaussian lobe in t_c.
6048         sigtc=3*polthet(3,it)
6049         do j=2,1,-1
6050           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6051         enddo
6052         sigtc=sig*sigtc
6053 C Set the parameters of both Gaussian lobes of the distribution.
6054 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6055         fac=sig*sig+sigc0(it)
6056         sigcsq=fac+fac
6057         sigc=1.0D0/sigcsq
6058 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6059         sigsqtc=-4.0D0*sigcsq*sigtc
6060 c       print *,i,sig,sigtc,sigsqtc
6061 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6062         sigtc=-sigtc/(fac*fac)
6063 C Following variable is sigma(t_c)**(-2)
6064         sigcsq=sigcsq*sigcsq
6065         sig0i=sig0(it)
6066         sig0inv=1.0D0/sig0i**2
6067         delthec=thetai-thet_pred_mean
6068         delthe0=thetai-theta0i
6069         term1=-0.5D0*sigcsq*delthec*delthec
6070         term2=-0.5D0*sig0inv*delthe0*delthe0
6071 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6072 C NaNs in taking the logarithm. We extract the largest exponent which is added
6073 C to the energy (this being the log of the distribution) at the end of energy
6074 C term evaluation for this virtual-bond angle.
6075         if (term1.gt.term2) then
6076           termm=term1
6077           term2=dexp(term2-termm)
6078           term1=1.0d0
6079         else
6080           termm=term2
6081           term1=dexp(term1-termm)
6082           term2=1.0d0
6083         endif
6084 C The ratio between the gamma-independent and gamma-dependent lobes of
6085 C the distribution is a Gaussian function of thet_pred_mean too.
6086         diffak=gthet(2,it)-thet_pred_mean
6087         ratak=diffak/gthet(3,it)**2
6088         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6089 C Let's differentiate it in thet_pred_mean NOW.
6090         aktc=ak*ratak
6091 C Now put together the distribution terms to make complete distribution.
6092         termexp=term1+ak*term2
6093         termpre=sigc+ak*sig0i
6094 C Contribution of the bending energy from this theta is just the -log of
6095 C the sum of the contributions from the two lobes and the pre-exponential
6096 C factor. Simple enough, isn't it?
6097         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6098 C NOW the derivatives!!!
6099 C 6/6/97 Take into account the deformation.
6100         E_theta=(delthec*sigcsq*term1
6101      &       +ak*delthe0*sig0inv*term2)/termexp
6102         E_tc=((sigtc+aktc*sig0i)/termpre
6103      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6104      &       aktc*term2)/termexp)
6105       return
6106       end
6107 c-----------------------------------------------------------------------------
6108       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6109       implicit real*8 (a-h,o-z)
6110       include 'DIMENSIONS'
6111       include 'COMMON.LOCAL'
6112       include 'COMMON.IOUNITS'
6113       common /calcthet/ term1,term2,termm,diffak,ratak,
6114      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6115      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6116       delthec=thetai-thet_pred_mean
6117       delthe0=thetai-theta0i
6118 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6119       t3 = thetai-thet_pred_mean
6120       t6 = t3**2
6121       t9 = term1
6122       t12 = t3*sigcsq
6123       t14 = t12+t6*sigsqtc
6124       t16 = 1.0d0
6125       t21 = thetai-theta0i
6126       t23 = t21**2
6127       t26 = term2
6128       t27 = t21*t26
6129       t32 = termexp
6130       t40 = t32**2
6131       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6132      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6133      & *(-t12*t9-ak*sig0inv*t27)
6134       return
6135       end
6136 #else
6137 C--------------------------------------------------------------------------
6138       subroutine ebend(etheta)
6139 C
6140 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6141 C angles gamma and its derivatives in consecutive thetas and gammas.
6142 C ab initio-derived potentials from
6143 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6144 C
6145       implicit real*8 (a-h,o-z)
6146       include 'DIMENSIONS'
6147       include 'DIMENSIONS.ZSCOPT'
6148       include 'COMMON.LOCAL'
6149       include 'COMMON.GEO'
6150       include 'COMMON.INTERACT'
6151       include 'COMMON.DERIV'
6152       include 'COMMON.VAR'
6153       include 'COMMON.CHAIN'
6154       include 'COMMON.IOUNITS'
6155       include 'COMMON.NAMES'
6156       include 'COMMON.FFIELD'
6157       include 'COMMON.CONTROL'
6158       include 'COMMON.TORCNSTR'
6159       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6160      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6161      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6162      & sinph1ph2(maxdouble,maxdouble)
6163       logical lprn /.false./, lprn1 /.false./
6164       etheta=0.0D0
6165 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6166       do i=ithet_start,ithet_end
6167 C         if (i.eq.2) cycle
6168 C        if (itype(i-1).eq.ntyp1) cycle
6169         if (i.le.2) cycle
6170         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6171      &  .or.itype(i).eq.ntyp1) cycle
6172         if (iabs(itype(i+1)).eq.20) iblock=2
6173         if (iabs(itype(i+1)).ne.20) iblock=1
6174         dethetai=0.0d0
6175         dephii=0.0d0
6176         dephii1=0.0d0
6177         theti2=0.5d0*theta(i)
6178         ityp2=ithetyp((itype(i-1)))
6179         do k=1,nntheterm
6180           coskt(k)=dcos(k*theti2)
6181           sinkt(k)=dsin(k*theti2)
6182         enddo
6183         if (i.eq.3) then
6184           phii=0.0d0
6185           ityp1=nthetyp+1
6186           do k=1,nsingle
6187             cosph1(k)=0.0d0
6188             sinph1(k)=0.0d0
6189           enddo
6190         else
6191         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6192 #ifdef OSF
6193           phii=phi(i)
6194           if (phii.ne.phii) phii=150.0
6195 #else
6196           phii=phi(i)
6197 #endif
6198           ityp1=ithetyp((itype(i-2)))
6199           do k=1,nsingle
6200             cosph1(k)=dcos(k*phii)
6201             sinph1(k)=dsin(k*phii)
6202           enddo
6203         else
6204           phii=0.0d0
6205 c          ityp1=nthetyp+1
6206           do k=1,nsingle
6207             ityp1=ithetyp((itype(i-2)))
6208             cosph1(k)=0.0d0
6209             sinph1(k)=0.0d0
6210           enddo
6211         endif
6212         endif
6213         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6214 #ifdef OSF
6215           phii1=phi(i+1)
6216           if (phii1.ne.phii1) phii1=150.0
6217           phii1=pinorm(phii1)
6218 #else
6219           phii1=phi(i+1)
6220 #endif
6221           ityp3=ithetyp((itype(i)))
6222           do k=1,nsingle
6223             cosph2(k)=dcos(k*phii1)
6224             sinph2(k)=dsin(k*phii1)
6225           enddo
6226         else
6227           phii1=0.0d0
6228 c          ityp3=nthetyp+1
6229           ityp3=ithetyp((itype(i)))
6230           do k=1,nsingle
6231             cosph2(k)=0.0d0
6232             sinph2(k)=0.0d0
6233           enddo
6234         endif
6235 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6236 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6237 c        call flush(iout)
6238         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6239         do k=1,ndouble
6240           do l=1,k-1
6241             ccl=cosph1(l)*cosph2(k-l)
6242             ssl=sinph1(l)*sinph2(k-l)
6243             scl=sinph1(l)*cosph2(k-l)
6244             csl=cosph1(l)*sinph2(k-l)
6245             cosph1ph2(l,k)=ccl-ssl
6246             cosph1ph2(k,l)=ccl+ssl
6247             sinph1ph2(l,k)=scl+csl
6248             sinph1ph2(k,l)=scl-csl
6249           enddo
6250         enddo
6251         if (lprn) then
6252         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6253      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6254         write (iout,*) "coskt and sinkt"
6255         do k=1,nntheterm
6256           write (iout,*) k,coskt(k),sinkt(k)
6257         enddo
6258         endif
6259         do k=1,ntheterm
6260           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6261           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6262      &      *coskt(k)
6263           if (lprn)
6264      &    write (iout,*) "k",k,"
6265      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6266      &     " ethetai",ethetai
6267         enddo
6268         if (lprn) then
6269         write (iout,*) "cosph and sinph"
6270         do k=1,nsingle
6271           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6272         enddo
6273         write (iout,*) "cosph1ph2 and sinph2ph2"
6274         do k=2,ndouble
6275           do l=1,k-1
6276             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6277      &         sinph1ph2(l,k),sinph1ph2(k,l)
6278           enddo
6279         enddo
6280         write(iout,*) "ethetai",ethetai
6281         endif
6282         do m=1,ntheterm2
6283           do k=1,nsingle
6284             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6285      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6286      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6287      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6288             ethetai=ethetai+sinkt(m)*aux
6289             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6290             dephii=dephii+k*sinkt(m)*(
6291      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6292      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6293             dephii1=dephii1+k*sinkt(m)*(
6294      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6295      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6296             if (lprn)
6297      &      write (iout,*) "m",m," k",k," bbthet",
6298      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6299      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6300      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6301      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6302           enddo
6303         enddo
6304         if (lprn)
6305      &  write(iout,*) "ethetai",ethetai
6306         do m=1,ntheterm3
6307           do k=2,ndouble
6308             do l=1,k-1
6309               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6310      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6311      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6312      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6313               ethetai=ethetai+sinkt(m)*aux
6314               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6315               dephii=dephii+l*sinkt(m)*(
6316      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6317      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6318      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6319      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6320               dephii1=dephii1+(k-l)*sinkt(m)*(
6321      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6322      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6323      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6324      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6325               if (lprn) then
6326               write (iout,*) "m",m," k",k," l",l," ffthet",
6327      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6328      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6329      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6330      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6331      &            " ethetai",ethetai
6332               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6333      &            cosph1ph2(k,l)*sinkt(m),
6334      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6335               endif
6336             enddo
6337           enddo
6338         enddo
6339 10      continue
6340         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6341      &   i,theta(i)*rad2deg,phii*rad2deg,
6342      &   phii1*rad2deg,ethetai
6343         etheta=etheta+ethetai
6344         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6345         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6346 c        gloc(nphi+i-2,icg)=wang*dethetai
6347         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6348       enddo
6349       return
6350       end
6351 #endif
6352 #ifdef CRYST_SC
6353 c-----------------------------------------------------------------------------
6354       subroutine esc(escloc)
6355 C Calculate the local energy of a side chain and its derivatives in the
6356 C corresponding virtual-bond valence angles THETA and the spherical angles
6357 C ALPHA and OMEGA.
6358       implicit real*8 (a-h,o-z)
6359       include 'DIMENSIONS'
6360       include 'DIMENSIONS.ZSCOPT'
6361       include 'COMMON.GEO'
6362       include 'COMMON.LOCAL'
6363       include 'COMMON.VAR'
6364       include 'COMMON.INTERACT'
6365       include 'COMMON.DERIV'
6366       include 'COMMON.CHAIN'
6367       include 'COMMON.IOUNITS'
6368       include 'COMMON.NAMES'
6369       include 'COMMON.FFIELD'
6370       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6371      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6372       common /sccalc/ time11,time12,time112,theti,it,nlobit
6373       delta=0.02d0*pi
6374       escloc=0.0D0
6375 C      write (iout,*) 'ESC'
6376       do i=loc_start,loc_end
6377         it=itype(i)
6378         if (it.eq.ntyp1) cycle
6379         if (it.eq.10) goto 1
6380         nlobit=nlob(iabs(it))
6381 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6382 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6383         theti=theta(i+1)-pipol
6384         x(1)=dtan(theti)
6385         x(2)=alph(i)
6386         x(3)=omeg(i)
6387 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6388
6389         if (x(2).gt.pi-delta) then
6390           xtemp(1)=x(1)
6391           xtemp(2)=pi-delta
6392           xtemp(3)=x(3)
6393           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6394           xtemp(2)=pi
6395           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6396           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6397      &        escloci,dersc(2))
6398           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6399      &        ddersc0(1),dersc(1))
6400           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6401      &        ddersc0(3),dersc(3))
6402           xtemp(2)=pi-delta
6403           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6404           xtemp(2)=pi
6405           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6406           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6407      &            dersc0(2),esclocbi,dersc02)
6408           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6409      &            dersc12,dersc01)
6410           call splinthet(x(2),0.5d0*delta,ss,ssd)
6411           dersc0(1)=dersc01
6412           dersc0(2)=dersc02
6413           dersc0(3)=0.0d0
6414           do k=1,3
6415             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6416           enddo
6417           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6418           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6419      &             esclocbi,ss,ssd
6420           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6421 c         escloci=esclocbi
6422 c         write (iout,*) escloci
6423         else if (x(2).lt.delta) then
6424           xtemp(1)=x(1)
6425           xtemp(2)=delta
6426           xtemp(3)=x(3)
6427           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6428           xtemp(2)=0.0d0
6429           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6430           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6431      &        escloci,dersc(2))
6432           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6433      &        ddersc0(1),dersc(1))
6434           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6435      &        ddersc0(3),dersc(3))
6436           xtemp(2)=delta
6437           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6438           xtemp(2)=0.0d0
6439           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6440           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6441      &            dersc0(2),esclocbi,dersc02)
6442           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6443      &            dersc12,dersc01)
6444           dersc0(1)=dersc01
6445           dersc0(2)=dersc02
6446           dersc0(3)=0.0d0
6447           call splinthet(x(2),0.5d0*delta,ss,ssd)
6448           do k=1,3
6449             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6450           enddo
6451           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6452 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6453 c     &             esclocbi,ss,ssd
6454           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6455 C         write (iout,*) 'i=',i, escloci
6456         else
6457           call enesc(x,escloci,dersc,ddummy,.false.)
6458         endif
6459
6460         escloc=escloc+escloci
6461 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6462             write (iout,'(a6,i5,0pf7.3)')
6463      &     'escloc',i,escloci
6464
6465         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6466      &   wscloc*dersc(1)
6467         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6468         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6469     1   continue
6470       enddo
6471       return
6472       end
6473 C---------------------------------------------------------------------------
6474       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6475       implicit real*8 (a-h,o-z)
6476       include 'DIMENSIONS'
6477       include 'COMMON.GEO'
6478       include 'COMMON.LOCAL'
6479       include 'COMMON.IOUNITS'
6480       common /sccalc/ time11,time12,time112,theti,it,nlobit
6481       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6482       double precision contr(maxlob,-1:1)
6483       logical mixed
6484 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6485         escloc_i=0.0D0
6486         do j=1,3
6487           dersc(j)=0.0D0
6488           if (mixed) ddersc(j)=0.0d0
6489         enddo
6490         x3=x(3)
6491
6492 C Because of periodicity of the dependence of the SC energy in omega we have
6493 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6494 C To avoid underflows, first compute & store the exponents.
6495
6496         do iii=-1,1
6497
6498           x(3)=x3+iii*dwapi
6499
6500           do j=1,nlobit
6501             do k=1,3
6502               z(k)=x(k)-censc(k,j,it)
6503             enddo
6504             do k=1,3
6505               Axk=0.0D0
6506               do l=1,3
6507                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6508               enddo
6509               Ax(k,j,iii)=Axk
6510             enddo
6511             expfac=0.0D0
6512             do k=1,3
6513               expfac=expfac+Ax(k,j,iii)*z(k)
6514             enddo
6515             contr(j,iii)=expfac
6516           enddo ! j
6517
6518         enddo ! iii
6519
6520         x(3)=x3
6521 C As in the case of ebend, we want to avoid underflows in exponentiation and
6522 C subsequent NaNs and INFs in energy calculation.
6523 C Find the largest exponent
6524         emin=contr(1,-1)
6525         do iii=-1,1
6526           do j=1,nlobit
6527             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6528           enddo
6529         enddo
6530         emin=0.5D0*emin
6531 cd      print *,'it=',it,' emin=',emin
6532
6533 C Compute the contribution to SC energy and derivatives
6534         do iii=-1,1
6535
6536           do j=1,nlobit
6537             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6538 cd          print *,'j=',j,' expfac=',expfac
6539             escloc_i=escloc_i+expfac
6540             do k=1,3
6541               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6542             enddo
6543             if (mixed) then
6544               do k=1,3,2
6545                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6546      &            +gaussc(k,2,j,it))*expfac
6547               enddo
6548             endif
6549           enddo
6550
6551         enddo ! iii
6552
6553         dersc(1)=dersc(1)/cos(theti)**2
6554         ddersc(1)=ddersc(1)/cos(theti)**2
6555         ddersc(3)=ddersc(3)
6556
6557         escloci=-(dlog(escloc_i)-emin)
6558         do j=1,3
6559           dersc(j)=dersc(j)/escloc_i
6560         enddo
6561         if (mixed) then
6562           do j=1,3,2
6563             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6564           enddo
6565         endif
6566       return
6567       end
6568 C------------------------------------------------------------------------------
6569       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6570       implicit real*8 (a-h,o-z)
6571       include 'DIMENSIONS'
6572       include 'COMMON.GEO'
6573       include 'COMMON.LOCAL'
6574       include 'COMMON.IOUNITS'
6575       common /sccalc/ time11,time12,time112,theti,it,nlobit
6576       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6577       double precision contr(maxlob)
6578       logical mixed
6579
6580       escloc_i=0.0D0
6581
6582       do j=1,3
6583         dersc(j)=0.0D0
6584       enddo
6585
6586       do j=1,nlobit
6587         do k=1,2
6588           z(k)=x(k)-censc(k,j,it)
6589         enddo
6590         z(3)=dwapi
6591         do k=1,3
6592           Axk=0.0D0
6593           do l=1,3
6594             Axk=Axk+gaussc(l,k,j,it)*z(l)
6595           enddo
6596           Ax(k,j)=Axk
6597         enddo
6598         expfac=0.0D0
6599         do k=1,3
6600           expfac=expfac+Ax(k,j)*z(k)
6601         enddo
6602         contr(j)=expfac
6603       enddo ! j
6604
6605 C As in the case of ebend, we want to avoid underflows in exponentiation and
6606 C subsequent NaNs and INFs in energy calculation.
6607 C Find the largest exponent
6608       emin=contr(1)
6609       do j=1,nlobit
6610         if (emin.gt.contr(j)) emin=contr(j)
6611       enddo
6612       emin=0.5D0*emin
6613
6614 C Compute the contribution to SC energy and derivatives
6615
6616       dersc12=0.0d0
6617       do j=1,nlobit
6618         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6619         escloc_i=escloc_i+expfac
6620         do k=1,2
6621           dersc(k)=dersc(k)+Ax(k,j)*expfac
6622         enddo
6623         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6624      &            +gaussc(1,2,j,it))*expfac
6625         dersc(3)=0.0d0
6626       enddo
6627
6628       dersc(1)=dersc(1)/cos(theti)**2
6629       dersc12=dersc12/cos(theti)**2
6630       escloci=-(dlog(escloc_i)-emin)
6631       do j=1,2
6632         dersc(j)=dersc(j)/escloc_i
6633       enddo
6634       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6635       return
6636       end
6637 #else
6638 c----------------------------------------------------------------------------------
6639       subroutine esc(escloc)
6640 C Calculate the local energy of a side chain and its derivatives in the
6641 C corresponding virtual-bond valence angles THETA and the spherical angles
6642 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6643 C added by Urszula Kozlowska. 07/11/2007
6644 C
6645       implicit real*8 (a-h,o-z)
6646       include 'DIMENSIONS'
6647       include 'DIMENSIONS.ZSCOPT'
6648       include 'COMMON.GEO'
6649       include 'COMMON.LOCAL'
6650       include 'COMMON.VAR'
6651       include 'COMMON.SCROT'
6652       include 'COMMON.INTERACT'
6653       include 'COMMON.DERIV'
6654       include 'COMMON.CHAIN'
6655       include 'COMMON.IOUNITS'
6656       include 'COMMON.NAMES'
6657       include 'COMMON.FFIELD'
6658       include 'COMMON.CONTROL'
6659       include 'COMMON.VECTORS'
6660       double precision x_prime(3),y_prime(3),z_prime(3)
6661      &    , sumene,dsc_i,dp2_i,x(65),
6662      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6663      &    de_dxx,de_dyy,de_dzz,de_dt
6664       double precision s1_t,s1_6_t,s2_t,s2_6_t
6665       double precision
6666      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6667      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6668      & dt_dCi(3),dt_dCi1(3)
6669       common /sccalc/ time11,time12,time112,theti,it,nlobit
6670       delta=0.02d0*pi
6671       escloc=0.0D0
6672       do i=loc_start,loc_end
6673         if (itype(i).eq.ntyp1) cycle
6674         costtab(i+1) =dcos(theta(i+1))
6675         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6676         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6677         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6678         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6679         cosfac=dsqrt(cosfac2)
6680         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6681         sinfac=dsqrt(sinfac2)
6682         it=iabs(itype(i))
6683         if (it.eq.10) goto 1
6684 c
6685 C  Compute the axes of tghe local cartesian coordinates system; store in
6686 c   x_prime, y_prime and z_prime
6687 c
6688         do j=1,3
6689           x_prime(j) = 0.00
6690           y_prime(j) = 0.00
6691           z_prime(j) = 0.00
6692         enddo
6693 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6694 C     &   dc_norm(3,i+nres)
6695         do j = 1,3
6696           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6697           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6698         enddo
6699         do j = 1,3
6700           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6701         enddo
6702 c       write (2,*) "i",i
6703 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6704 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6705 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6706 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6707 c      & " xy",scalar(x_prime(1),y_prime(1)),
6708 c      & " xz",scalar(x_prime(1),z_prime(1)),
6709 c      & " yy",scalar(y_prime(1),y_prime(1)),
6710 c      & " yz",scalar(y_prime(1),z_prime(1)),
6711 c      & " zz",scalar(z_prime(1),z_prime(1))
6712 c
6713 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6714 C to local coordinate system. Store in xx, yy, zz.
6715 c
6716         xx=0.0d0
6717         yy=0.0d0
6718         zz=0.0d0
6719         do j = 1,3
6720           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6721           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6722           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6723         enddo
6724
6725         xxtab(i)=xx
6726         yytab(i)=yy
6727         zztab(i)=zz
6728 C
6729 C Compute the energy of the ith side cbain
6730 C
6731 c        write (2,*) "xx",xx," yy",yy," zz",zz
6732         it=iabs(itype(i))
6733         do j = 1,65
6734           x(j) = sc_parmin(j,it)
6735         enddo
6736 #ifdef CHECK_COORD
6737 Cc diagnostics - remove later
6738         xx1 = dcos(alph(2))
6739         yy1 = dsin(alph(2))*dcos(omeg(2))
6740         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6741         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6742      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6743      &    xx1,yy1,zz1
6744 C,"  --- ", xx_w,yy_w,zz_w
6745 c end diagnostics
6746 #endif
6747         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6748      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6749      &   + x(10)*yy*zz
6750         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6751      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6752      & + x(20)*yy*zz
6753         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6754      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6755      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6756      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6757      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6758      &  +x(40)*xx*yy*zz
6759         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6760      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6761      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6762      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6763      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6764      &  +x(60)*xx*yy*zz
6765         dsc_i   = 0.743d0+x(61)
6766         dp2_i   = 1.9d0+x(62)
6767         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6768      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6769         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6770      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6771         s1=(1+x(63))/(0.1d0 + dscp1)
6772         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6773         s2=(1+x(65))/(0.1d0 + dscp2)
6774         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6775         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6776      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6777 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6778 c     &   sumene4,
6779 c     &   dscp1,dscp2,sumene
6780 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6781         escloc = escloc + sumene
6782 c        write (2,*) "escloc",escloc
6783 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6784 c     &  zz,xx,yy
6785         if (.not. calc_grad) goto 1
6786 #ifdef DEBUG
6787 C
6788 C This section to check the numerical derivatives of the energy of ith side
6789 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6790 C #define DEBUG in the code to turn it on.
6791 C
6792         write (2,*) "sumene               =",sumene
6793         aincr=1.0d-7
6794         xxsave=xx
6795         xx=xx+aincr
6796         write (2,*) xx,yy,zz
6797         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6798         de_dxx_num=(sumenep-sumene)/aincr
6799         xx=xxsave
6800         write (2,*) "xx+ sumene from enesc=",sumenep
6801         yysave=yy
6802         yy=yy+aincr
6803         write (2,*) xx,yy,zz
6804         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6805         de_dyy_num=(sumenep-sumene)/aincr
6806         yy=yysave
6807         write (2,*) "yy+ sumene from enesc=",sumenep
6808         zzsave=zz
6809         zz=zz+aincr
6810         write (2,*) xx,yy,zz
6811         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6812         de_dzz_num=(sumenep-sumene)/aincr
6813         zz=zzsave
6814         write (2,*) "zz+ sumene from enesc=",sumenep
6815         costsave=cost2tab(i+1)
6816         sintsave=sint2tab(i+1)
6817         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6818         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6819         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6820         de_dt_num=(sumenep-sumene)/aincr
6821         write (2,*) " t+ sumene from enesc=",sumenep
6822         cost2tab(i+1)=costsave
6823         sint2tab(i+1)=sintsave
6824 C End of diagnostics section.
6825 #endif
6826 C
6827 C Compute the gradient of esc
6828 C
6829         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6830         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6831         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6832         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6833         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6834         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6835         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6836         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6837         pom1=(sumene3*sint2tab(i+1)+sumene1)
6838      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6839         pom2=(sumene4*cost2tab(i+1)+sumene2)
6840      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6841         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6842         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6843      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6844      &  +x(40)*yy*zz
6845         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6846         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6847      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6848      &  +x(60)*yy*zz
6849         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6850      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6851      &        +(pom1+pom2)*pom_dx
6852 #ifdef DEBUG
6853         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6854 #endif
6855 C
6856         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6857         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6858      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6859      &  +x(40)*xx*zz
6860         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6861         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6862      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6863      &  +x(59)*zz**2 +x(60)*xx*zz
6864         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6865      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6866      &        +(pom1-pom2)*pom_dy
6867 #ifdef DEBUG
6868         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6869 #endif
6870 C
6871         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6872      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6873      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6874      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6875      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6876      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6877      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6878      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6879 #ifdef DEBUG
6880         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6881 #endif
6882 C
6883         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6884      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6885      &  +pom1*pom_dt1+pom2*pom_dt2
6886 #ifdef DEBUG
6887         write(2,*), "de_dt = ", de_dt,de_dt_num
6888 #endif
6889 c
6890 C
6891        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6892        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6893        cosfac2xx=cosfac2*xx
6894        sinfac2yy=sinfac2*yy
6895        do k = 1,3
6896          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6897      &      vbld_inv(i+1)
6898          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6899      &      vbld_inv(i)
6900          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6901          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6902 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6903 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6904 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6905 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6906          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6907          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6908          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6909          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6910          dZZ_Ci1(k)=0.0d0
6911          dZZ_Ci(k)=0.0d0
6912          do j=1,3
6913            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6914      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6915            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6916      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6917          enddo
6918
6919          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6920          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6921          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6922 c
6923          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6924          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6925        enddo
6926
6927        do k=1,3
6928          dXX_Ctab(k,i)=dXX_Ci(k)
6929          dXX_C1tab(k,i)=dXX_Ci1(k)
6930          dYY_Ctab(k,i)=dYY_Ci(k)
6931          dYY_C1tab(k,i)=dYY_Ci1(k)
6932          dZZ_Ctab(k,i)=dZZ_Ci(k)
6933          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6934          dXX_XYZtab(k,i)=dXX_XYZ(k)
6935          dYY_XYZtab(k,i)=dYY_XYZ(k)
6936          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6937        enddo
6938
6939        do k = 1,3
6940 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6941 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6942 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6943 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6944 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6945 c     &    dt_dci(k)
6946 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6947 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6948          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6949      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6950          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6951      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6952          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6953      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6954        enddo
6955 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6956 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6957
6958 C to check gradient call subroutine check_grad
6959
6960     1 continue
6961       enddo
6962       return
6963       end
6964 #endif
6965 c------------------------------------------------------------------------------
6966       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6967 C
6968 C This procedure calculates two-body contact function g(rij) and its derivative:
6969 C
6970 C           eps0ij                                     !       x < -1
6971 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6972 C            0                                         !       x > 1
6973 C
6974 C where x=(rij-r0ij)/delta
6975 C
6976 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6977 C
6978       implicit none
6979       double precision rij,r0ij,eps0ij,fcont,fprimcont
6980       double precision x,x2,x4,delta
6981 c     delta=0.02D0*r0ij
6982 c      delta=0.2D0*r0ij
6983       x=(rij-r0ij)/delta
6984       if (x.lt.-1.0D0) then
6985         fcont=eps0ij
6986         fprimcont=0.0D0
6987       else if (x.le.1.0D0) then
6988         x2=x*x
6989         x4=x2*x2
6990         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6991         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6992       else
6993         fcont=0.0D0
6994         fprimcont=0.0D0
6995       endif
6996       return
6997       end
6998 c------------------------------------------------------------------------------
6999       subroutine splinthet(theti,delta,ss,ssder)
7000       implicit real*8 (a-h,o-z)
7001       include 'DIMENSIONS'
7002       include 'DIMENSIONS.ZSCOPT'
7003       include 'COMMON.VAR'
7004       include 'COMMON.GEO'
7005       thetup=pi-delta
7006       thetlow=delta
7007       if (theti.gt.pipol) then
7008         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7009       else
7010         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7011         ssder=-ssder
7012       endif
7013       return
7014       end
7015 c------------------------------------------------------------------------------
7016       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7017       implicit none
7018       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7019       double precision ksi,ksi2,ksi3,a1,a2,a3
7020       a1=fprim0*delta/(f1-f0)
7021       a2=3.0d0-2.0d0*a1
7022       a3=a1-2.0d0
7023       ksi=(x-x0)/delta
7024       ksi2=ksi*ksi
7025       ksi3=ksi2*ksi
7026       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7027       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7028       return
7029       end
7030 c------------------------------------------------------------------------------
7031       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7032       implicit none
7033       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7034       double precision ksi,ksi2,ksi3,a1,a2,a3
7035       ksi=(x-x0)/delta
7036       ksi2=ksi*ksi
7037       ksi3=ksi2*ksi
7038       a1=fprim0x*delta
7039       a2=3*(f1x-f0x)-2*fprim0x*delta
7040       a3=fprim0x*delta-2*(f1x-f0x)
7041       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7042       return
7043       end
7044 C-----------------------------------------------------------------------------
7045 #ifdef CRYST_TOR
7046 C-----------------------------------------------------------------------------
7047       subroutine etor(etors)
7048       implicit real*8 (a-h,o-z)
7049       include 'DIMENSIONS'
7050       include 'DIMENSIONS.ZSCOPT'
7051       include 'COMMON.VAR'
7052       include 'COMMON.GEO'
7053       include 'COMMON.LOCAL'
7054       include 'COMMON.TORSION'
7055       include 'COMMON.INTERACT'
7056       include 'COMMON.DERIV'
7057       include 'COMMON.CHAIN'
7058       include 'COMMON.NAMES'
7059       include 'COMMON.IOUNITS'
7060       include 'COMMON.FFIELD'
7061       include 'COMMON.TORCNSTR'
7062       logical lprn
7063 C Set lprn=.true. for debugging
7064       lprn=.false.
7065 c      lprn=.true.
7066       etors=0.0D0
7067       do i=iphi_start,iphi_end
7068         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7069      &      .or. itype(i).eq.ntyp1) cycle
7070         itori=itortyp(itype(i-2))
7071         itori1=itortyp(itype(i-1))
7072         phii=phi(i)
7073         gloci=0.0D0
7074 C Proline-Proline pair is a special case...
7075         if (itori.eq.3 .and. itori1.eq.3) then
7076           if (phii.gt.-dwapi3) then
7077             cosphi=dcos(3*phii)
7078             fac=1.0D0/(1.0D0-cosphi)
7079             etorsi=v1(1,3,3)*fac
7080             etorsi=etorsi+etorsi
7081             etors=etors+etorsi-v1(1,3,3)
7082             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7083           endif
7084           do j=1,3
7085             v1ij=v1(j+1,itori,itori1)
7086             v2ij=v2(j+1,itori,itori1)
7087             cosphi=dcos(j*phii)
7088             sinphi=dsin(j*phii)
7089             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7090             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7091           enddo
7092         else
7093           do j=1,nterm_old
7094             v1ij=v1(j,itori,itori1)
7095             v2ij=v2(j,itori,itori1)
7096             cosphi=dcos(j*phii)
7097             sinphi=dsin(j*phii)
7098             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7099             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7100           enddo
7101         endif
7102         if (lprn)
7103      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7104      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7105      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7106         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7107 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7108       enddo
7109       return
7110       end
7111 c------------------------------------------------------------------------------
7112 #else
7113       subroutine etor(etors)
7114       implicit real*8 (a-h,o-z)
7115       include 'DIMENSIONS'
7116       include 'DIMENSIONS.ZSCOPT'
7117       include 'COMMON.VAR'
7118       include 'COMMON.GEO'
7119       include 'COMMON.LOCAL'
7120       include 'COMMON.TORSION'
7121       include 'COMMON.INTERACT'
7122       include 'COMMON.DERIV'
7123       include 'COMMON.CHAIN'
7124       include 'COMMON.NAMES'
7125       include 'COMMON.IOUNITS'
7126       include 'COMMON.FFIELD'
7127       include 'COMMON.TORCNSTR'
7128       include 'COMMON.WEIGHTS'
7129       include 'COMMON.WEIGHTDER'
7130       logical lprn
7131 C Set lprn=.true. for debugging
7132       lprn=.false.
7133 c      lprn=.true.
7134       etors=0.0D0
7135       do iblock=1,2
7136       do i=-ntyp+1,ntyp-1
7137         do j=-ntyp+1,ntyp-1
7138           do k=0,3
7139             do l=0,2*maxterm
7140               etor_temp(l,k,j,i,iblock)=0.0d0
7141             enddo
7142           enddo
7143         enddo
7144       enddo
7145       enddo
7146       do i=iphi_start,iphi_end
7147         if (i.le.2) cycle
7148         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7149      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7150         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7151         if (iabs(itype(i)).eq.20) then
7152           iblock=2
7153         else
7154           iblock=1
7155         endif
7156         itori=itortyp(itype(i-2))
7157         itori1=itortyp(itype(i-1))
7158         weitori=weitor(0,itori,itori1,iblock)
7159         phii=phi(i)
7160         gloci=0.0D0
7161         etori=0.0d0
7162 C Regular cosine and sine terms
7163         do j=1,nterm(itori,itori1,iblock)
7164           v1ij=v1(j,itori,itori1,iblock)
7165           v2ij=v2(j,itori,itori1,iblock)
7166           cosphi=dcos(j*phii)
7167           sinphi=dsin(j*phii)
7168           etori=etori+v1ij*cosphi+v2ij*sinphi
7169           etor_temp(j,0,itori,itori1,iblock)=
7170      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7171           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7172      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7173      &      sinphi*ww(13)
7174           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7175         enddo
7176 C Lorentz terms
7177 C                         v1
7178 C  E = SUM ----------------------------------- - v1
7179 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7180 C
7181         cosphi=dcos(0.5d0*phii)
7182         sinphi=dsin(0.5d0*phii)
7183         do j=1,nlor(itori,itori1,iblock)
7184           vl1ij=vlor1(j,itori,itori1)
7185           vl2ij=vlor2(j,itori,itori1)
7186           vl3ij=vlor3(j,itori,itori1)
7187           pom=vl2ij*cosphi+vl3ij*sinphi
7188           pom1=1.0d0/(pom*pom+1.0d0)
7189           etori=etori+vl1ij*pom1
7190           pom=-pom*pom1*pom1
7191           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7192         enddo
7193 C Subtract the constant term
7194         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7195         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7196      &    (etori-v0(itori,itori1,iblock))*ww(13)
7197
7198         if (lprn) then
7199         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7200      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7201      &  weitori,v0(itori,itori1,iblock)*weitori,
7202      &  (v1(j,itori,itori1,iblock)*weitori,
7203      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7204         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7205      &    iloctyp(itori1)," etor_temp",
7206      &    etor_temp(0,0,itori,itori1,1)
7207         call flush(iout)
7208         endif
7209         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7210 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7211  1215   continue
7212       enddo
7213       return
7214       end
7215 c----------------------------------------------------------------------------
7216       subroutine etor_d(etors_d)
7217 C 6/23/01 Compute double torsional energy
7218       implicit real*8 (a-h,o-z)
7219       include 'DIMENSIONS'
7220       include 'DIMENSIONS.ZSCOPT'
7221       include 'COMMON.VAR'
7222       include 'COMMON.GEO'
7223       include 'COMMON.LOCAL'
7224       include 'COMMON.TORSION'
7225       include 'COMMON.INTERACT'
7226       include 'COMMON.DERIV'
7227       include 'COMMON.CHAIN'
7228       include 'COMMON.NAMES'
7229       include 'COMMON.IOUNITS'
7230       include 'COMMON.FFIELD'
7231       include 'COMMON.TORCNSTR'
7232       logical lprn
7233 C Set lprn=.true. for debugging
7234       lprn=.false.
7235 c     lprn=.true.
7236       etors_d=0.0D0
7237       do i=iphi_start,iphi_end-1
7238         if (i.le.3) cycle
7239 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7240 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7241          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7242      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7243      &  (itype(i+1).eq.ntyp1)) cycle
7244         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7245      &     goto 1215
7246         itori=itortyp(itype(i-2))
7247         itori1=itortyp(itype(i-1))
7248         itori2=itortyp(itype(i))
7249         phii=phi(i)
7250         phii1=phi(i+1)
7251         gloci1=0.0D0
7252         gloci2=0.0D0
7253         iblock=1
7254         if (iabs(itype(i+1)).eq.20) iblock=2
7255 C Regular cosine and sine terms
7256         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7257           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7258           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7259           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7260           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7261           cosphi1=dcos(j*phii)
7262           sinphi1=dsin(j*phii)
7263           cosphi2=dcos(j*phii1)
7264           sinphi2=dsin(j*phii1)
7265           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7266      &     v2cij*cosphi2+v2sij*sinphi2
7267           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7268           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7269         enddo
7270         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7271           do l=1,k-1
7272             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7273             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7274             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7275             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7276             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7277             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7278             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7279             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7280             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7281      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7282             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7283      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7284             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7285      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7286           enddo
7287         enddo
7288         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7289         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7290  1215   continue
7291       enddo
7292       return
7293       end
7294 #endif
7295 c---------------------------------------------------------------------------
7296 C The rigorous attempt to derive energy function
7297       subroutine etor_kcc(etors)
7298       implicit real*8 (a-h,o-z)
7299       include 'DIMENSIONS'
7300       include 'DIMENSIONS.ZSCOPT'
7301       include 'COMMON.VAR'
7302       include 'COMMON.GEO'
7303       include 'COMMON.LOCAL'
7304       include 'COMMON.TORSION'
7305       include 'COMMON.INTERACT'
7306       include 'COMMON.DERIV'
7307       include 'COMMON.CHAIN'
7308       include 'COMMON.NAMES'
7309       include 'COMMON.IOUNITS'
7310       include 'COMMON.FFIELD'
7311       include 'COMMON.TORCNSTR'
7312       include 'COMMON.CONTROL'
7313       include 'COMMON.WEIGHTS'
7314       include 'COMMON.WEIGHTDER'
7315       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7316       logical lprn
7317 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7318 C Set lprn=.true. for debugging
7319       lprn=energy_dec
7320 c      lprn=.true.
7321       if (lprn) write (iout,*)"ETOR_KCC"
7322       do iblock=1,2
7323       do i=-ntyp+1,ntyp-1
7324         do j=-ntyp+1,ntyp-1
7325           do k=0,3
7326             do l=0,2*maxterm
7327               etor_temp(l,k,j,i,iblock)=0.0d0
7328             enddo
7329           enddo
7330         enddo
7331       enddo
7332       enddo
7333       do i=-ntyp+1,ntyp-1
7334         do j=-ntyp+1,ntyp-1
7335           do k=0,2*maxtor_kcc
7336             do l=1,maxval_kcc
7337               do ll=1,maxval_kcc
7338                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7339               enddo
7340             enddo
7341           enddo
7342         enddo
7343       enddo
7344       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7345       etors=0.0D0
7346       do i=iphi_start,iphi_end
7347 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7348 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7349 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7350 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7351         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7352      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7353         itori=itortyp(itype(i-2))
7354         itori1=itortyp(itype(i-1))
7355         weitori=weitor(0,itori,itori1,1)
7356         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7357         phii=phi(i)
7358         glocig=0.0D0
7359         glocit1=0.0d0
7360         glocit2=0.0d0
7361 C to avoid multiple devision by 2
7362 c        theti22=0.5d0*theta(i)
7363 C theta 12 is the theta_1 /2
7364 C theta 22 is theta_2 /2
7365 c        theti12=0.5d0*theta(i-1)
7366 C and appropriate sinus function
7367         sinthet1=dsin(theta(i-1))
7368         sinthet2=dsin(theta(i))
7369         costhet1=dcos(theta(i-1))
7370         costhet2=dcos(theta(i))
7371 C to speed up lets store its mutliplication
7372         sint1t2=sinthet2*sinthet1
7373         sint1t2n=1.0d0
7374 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7375 C +d_n*sin(n*gamma)) *
7376 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7377 C we have two sum 1) Non-Chebyshev which is with n and gamma
7378         nval=nterm_kcc_Tb(itori,itori1)
7379         c1(0)=0.0d0
7380         c2(0)=0.0d0
7381         c1(1)=1.0d0
7382         c2(1)=1.0d0
7383         do j=2,nval
7384           c1(j)=c1(j-1)*costhet1
7385           c2(j)=c2(j-1)*costhet2
7386         enddo
7387         etori=0.0d0
7388         do j=1,nterm_kcc(itori,itori1)
7389           cosphi=dcos(j*phii)
7390           sinphi=dsin(j*phii)
7391           sint1t2n1=sint1t2n
7392           sint1t2n=sint1t2n*sint1t2
7393           sumvalc=0.0d0
7394           gradvalct1=0.0d0
7395           gradvalct2=0.0d0
7396           do k=1,nval
7397             do l=1,nval
7398               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7399               etor_temp_kcc(l,k,j,itori,itori1)=
7400      &           etor_temp_kcc(l,k,j,itori,itori1)+
7401      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7402               gradvalct1=gradvalct1+
7403      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7404               gradvalct2=gradvalct2+
7405      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7406             enddo
7407           enddo
7408           gradvalct1=-gradvalct1*sinthet1
7409           gradvalct2=-gradvalct2*sinthet2
7410           sumvals=0.0d0
7411           gradvalst1=0.0d0
7412           gradvalst2=0.0d0
7413           do k=1,nval
7414             do l=1,nval
7415               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7416               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7417      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7418      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7419               gradvalst1=gradvalst1+
7420      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7421               gradvalst2=gradvalst2+
7422      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7423             enddo
7424           enddo
7425           gradvalst1=-gradvalst1*sinthet1
7426           gradvalst2=-gradvalst2*sinthet2
7427           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7428           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7429      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7430 C glocig is the gradient local i site in gamma
7431           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7432 C now gradient over theta_1
7433           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7434      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7435           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7436      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7437         enddo ! j
7438         etors=etors+etori*weitori
7439 C derivative over gamma
7440         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7441 C derivative over theta1
7442         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7443 C now derivative over theta2
7444         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7445         if (lprn)
7446      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7447      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7448       enddo
7449       return
7450       end
7451 c---------------------------------------------------------------------------------------------
7452       subroutine etor_constr(edihcnstr)
7453       implicit real*8 (a-h,o-z)
7454       include 'DIMENSIONS'
7455       include 'DIMENSIONS.ZSCOPT'
7456       include 'COMMON.VAR'
7457       include 'COMMON.GEO'
7458       include 'COMMON.LOCAL'
7459       include 'COMMON.TORSION'
7460       include 'COMMON.INTERACT'
7461       include 'COMMON.DERIV'
7462       include 'COMMON.CHAIN'
7463       include 'COMMON.NAMES'
7464       include 'COMMON.IOUNITS'
7465       include 'COMMON.FFIELD'
7466       include 'COMMON.TORCNSTR'
7467       include 'COMMON.CONTROL'
7468 ! 6/20/98 - dihedral angle constraints
7469       edihcnstr=0.0d0
7470 c      do i=1,ndih_constr
7471 c      write (iout,*) "idihconstr_start",idihconstr_start,
7472 c     &  " idihconstr_end",idihconstr_end
7473       do i=idihconstr_start,idihconstr_end
7474         itori=idih_constr(i)
7475         phii=phi(itori)
7476         difi=pinorm(phii-phi0(i))
7477         if (difi.gt.drange(i)) then
7478           difi=difi-drange(i)
7479           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7480           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7481         else if (difi.lt.-drange(i)) then
7482           difi=difi+drange(i)
7483           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7484           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7485         else
7486           difi=0.0
7487         endif
7488       enddo
7489       return
7490       end
7491 c----------------------------------------------------------------------------
7492 C The rigorous attempt to derive energy function
7493       subroutine ebend_kcc(etheta)
7494
7495       implicit real*8 (a-h,o-z)
7496       include 'DIMENSIONS'
7497       include 'DIMENSIONS.ZSCOPT'
7498       include 'COMMON.VAR'
7499       include 'COMMON.GEO'
7500       include 'COMMON.LOCAL'
7501       include 'COMMON.TORSION'
7502       include 'COMMON.INTERACT'
7503       include 'COMMON.DERIV'
7504       include 'COMMON.CHAIN'
7505       include 'COMMON.NAMES'
7506       include 'COMMON.IOUNITS'
7507       include 'COMMON.FFIELD'
7508       include 'COMMON.TORCNSTR'
7509       include 'COMMON.CONTROL'
7510       include 'COMMON.WEIGHTDER'
7511       logical lprn
7512       double precision thybt1(maxang_kcc)
7513 C Set lprn=.true. for debugging
7514       lprn=energy_dec
7515 c     lprn=.true.
7516 C      print *,"wchodze kcc"
7517       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7518       do i=0,ntyp
7519         do j=1,maxang_kcc
7520           ebend_temp_kcc(j,i)=0.0d0
7521         enddo
7522       enddo
7523       etheta=0.0D0
7524       do i=ithet_start,ithet_end
7525 c        print *,i,itype(i-1),itype(i),itype(i-2)
7526         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7527      &  .or.itype(i).eq.ntyp1) cycle
7528         iti=iabs(itortyp(itype(i-1)))
7529         sinthet=dsin(theta(i))
7530         costhet=dcos(theta(i))
7531         do j=1,nbend_kcc_Tb(iti)
7532           thybt1(j)=v1bend_chyb(j,iti)
7533           ebend_temp_kcc(j,iabs(iti))=
7534      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7535         enddo
7536         sumth1thyb=v1bend_chyb(0,iti)+
7537      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7538         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7539      &    sumth1thyb
7540         ihelp=nbend_kcc_Tb(iti)-1
7541         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7542         etheta=etheta+sumth1thyb
7543 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7544         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7545       enddo
7546       return
7547       end
7548 c-------------------------------------------------------------------------------------
7549       subroutine etheta_constr(ethetacnstr)
7550
7551       implicit real*8 (a-h,o-z)
7552       include 'DIMENSIONS'
7553       include 'DIMENSIONS.ZSCOPT'
7554       include 'COMMON.VAR'
7555       include 'COMMON.GEO'
7556       include 'COMMON.LOCAL'
7557       include 'COMMON.TORSION'
7558       include 'COMMON.INTERACT'
7559       include 'COMMON.DERIV'
7560       include 'COMMON.CHAIN'
7561       include 'COMMON.NAMES'
7562       include 'COMMON.IOUNITS'
7563       include 'COMMON.FFIELD'
7564       include 'COMMON.TORCNSTR'
7565       include 'COMMON.CONTROL'
7566       ethetacnstr=0.0d0
7567 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7568       do i=ithetaconstr_start,ithetaconstr_end
7569         itheta=itheta_constr(i)
7570         thetiii=theta(itheta)
7571         difi=pinorm(thetiii-theta_constr0(i))
7572         if (difi.gt.theta_drange(i)) then
7573           difi=difi-theta_drange(i)
7574           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7575           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7576      &    +for_thet_constr(i)*difi**3
7577         else if (difi.lt.-drange(i)) then
7578           difi=difi+drange(i)
7579           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7580           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7581      &    +for_thet_constr(i)*difi**3
7582         else
7583           difi=0.0
7584         endif
7585        if (energy_dec) then
7586         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7587      &    i,itheta,rad2deg*thetiii,
7588      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7589      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7590      &    gloc(itheta+nphi-2,icg)
7591         endif
7592       enddo
7593       return
7594       end
7595 c------------------------------------------------------------------------------
7596       subroutine eback_sc_corr(esccor)
7597 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7598 c        conformational states; temporarily implemented as differences
7599 c        between UNRES torsional potentials (dependent on three types of
7600 c        residues) and the torsional potentials dependent on all 20 types
7601 c        of residues computed from AM1 energy surfaces of terminally-blocked
7602 c        amino-acid residues.
7603       implicit real*8 (a-h,o-z)
7604       include 'DIMENSIONS'
7605       include 'DIMENSIONS.ZSCOPT'
7606       include 'COMMON.VAR'
7607       include 'COMMON.GEO'
7608       include 'COMMON.LOCAL'
7609       include 'COMMON.TORSION'
7610       include 'COMMON.SCCOR'
7611       include 'COMMON.INTERACT'
7612       include 'COMMON.DERIV'
7613       include 'COMMON.CHAIN'
7614       include 'COMMON.NAMES'
7615       include 'COMMON.IOUNITS'
7616       include 'COMMON.FFIELD'
7617       include 'COMMON.CONTROL'
7618       logical lprn
7619 C Set lprn=.true. for debugging
7620       lprn=.false.
7621 c      lprn=.true.
7622 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7623       esccor=0.0D0
7624       do i=itau_start,itau_end
7625         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7626         esccor_ii=0.0D0
7627         isccori=isccortyp(itype(i-2))
7628         isccori1=isccortyp(itype(i-1))
7629         phii=phi(i)
7630         do intertyp=1,3 !intertyp
7631 cc Added 09 May 2012 (Adasko)
7632 cc  Intertyp means interaction type of backbone mainchain correlation:
7633 c   1 = SC...Ca...Ca...Ca
7634 c   2 = Ca...Ca...Ca...SC
7635 c   3 = SC...Ca...Ca...SCi
7636         gloci=0.0D0
7637         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7638      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7639      &      (itype(i-1).eq.ntyp1)))
7640      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7641      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7642      &     .or.(itype(i).eq.ntyp1)))
7643      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7644      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7645      &      (itype(i-3).eq.ntyp1)))) cycle
7646         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7647         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7648      & cycle
7649        do j=1,nterm_sccor(isccori,isccori1)
7650           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7651           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7652           cosphi=dcos(j*tauangle(intertyp,i))
7653           sinphi=dsin(j*tauangle(intertyp,i))
7654            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7655            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7656          enddo
7657 C      write (iout,*)"EBACK_SC_COR",esccor,i
7658 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7659 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7660 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7661         if (lprn)
7662      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7663      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7664      &  (v1sccor(j,1,itori,itori1),j=1,6)
7665      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7666 c        gsccor_loc(i-3)=gloci
7667        enddo !intertyp
7668       enddo
7669       return
7670       end
7671 c------------------------------------------------------------------------------
7672       subroutine multibody(ecorr)
7673 C This subroutine calculates multi-body contributions to energy following
7674 C the idea of Skolnick et al. If side chains I and J make a contact and
7675 C at the same time side chains I+1 and J+1 make a contact, an extra
7676 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7677       implicit real*8 (a-h,o-z)
7678       include 'DIMENSIONS'
7679       include 'DIMENSIONS.ZSCOPT'
7680       include 'COMMON.IOUNITS'
7681       include 'COMMON.DERIV'
7682       include 'COMMON.INTERACT'
7683       include 'COMMON.CONTACTS'
7684       double precision gx(3),gx1(3)
7685       logical lprn
7686
7687 C Set lprn=.true. for debugging
7688       lprn=.false.
7689
7690       if (lprn) then
7691         write (iout,'(a)') 'Contact function values:'
7692         do i=nnt,nct-2
7693           write (iout,'(i2,20(1x,i2,f10.5))')
7694      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7695         enddo
7696       endif
7697       ecorr=0.0D0
7698       do i=nnt,nct
7699         do j=1,3
7700           gradcorr(j,i)=0.0D0
7701           gradxorr(j,i)=0.0D0
7702         enddo
7703       enddo
7704       do i=nnt,nct-2
7705
7706         DO ISHIFT = 3,4
7707
7708         i1=i+ishift
7709         num_conti=num_cont(i)
7710         num_conti1=num_cont(i1)
7711         do jj=1,num_conti
7712           j=jcont(jj,i)
7713           do kk=1,num_conti1
7714             j1=jcont(kk,i1)
7715             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7716 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7717 cd   &                   ' ishift=',ishift
7718 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7719 C The system gains extra energy.
7720               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7721             endif   ! j1==j+-ishift
7722           enddo     ! kk
7723         enddo       ! jj
7724
7725         ENDDO ! ISHIFT
7726
7727       enddo         ! i
7728       return
7729       end
7730 c------------------------------------------------------------------------------
7731       double precision function esccorr(i,j,k,l,jj,kk)
7732       implicit real*8 (a-h,o-z)
7733       include 'DIMENSIONS'
7734       include 'DIMENSIONS.ZSCOPT'
7735       include 'COMMON.IOUNITS'
7736       include 'COMMON.DERIV'
7737       include 'COMMON.INTERACT'
7738       include 'COMMON.CONTACTS'
7739       double precision gx(3),gx1(3)
7740       logical lprn
7741       lprn=.false.
7742       eij=facont(jj,i)
7743       ekl=facont(kk,k)
7744 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7745 C Calculate the multi-body contribution to energy.
7746 C Calculate multi-body contributions to the gradient.
7747 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7748 cd   & k,l,(gacont(m,kk,k),m=1,3)
7749       do m=1,3
7750         gx(m) =ekl*gacont(m,jj,i)
7751         gx1(m)=eij*gacont(m,kk,k)
7752         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7753         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7754         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7755         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7756       enddo
7757       do m=i,j-1
7758         do ll=1,3
7759           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7760         enddo
7761       enddo
7762       do m=k,l-1
7763         do ll=1,3
7764           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7765         enddo
7766       enddo
7767       esccorr=-eij*ekl
7768       return
7769       end
7770 c------------------------------------------------------------------------------
7771       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7772 C This subroutine calculates multi-body contributions to hydrogen-bonding
7773       implicit real*8 (a-h,o-z)
7774       include 'DIMENSIONS'
7775       include 'DIMENSIONS.ZSCOPT'
7776       include 'COMMON.IOUNITS'
7777       include 'COMMON.FFIELD'
7778       include 'COMMON.DERIV'
7779       include 'COMMON.INTERACT'
7780       include 'COMMON.CONTACTS'
7781       double precision gx(3),gx1(3)
7782       logical lprn,ldone
7783
7784 C Set lprn=.true. for debugging
7785       lprn=.false.
7786       if (lprn) then
7787         write (iout,'(a)') 'Contact function values:'
7788         do i=nnt,nct-2
7789           write (iout,'(2i3,50(1x,i2,f5.2))')
7790      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7791      &    j=1,num_cont_hb(i))
7792         enddo
7793       endif
7794       ecorr=0.0D0
7795 C Remove the loop below after debugging !!!
7796       do i=nnt,nct
7797         do j=1,3
7798           gradcorr(j,i)=0.0D0
7799           gradxorr(j,i)=0.0D0
7800         enddo
7801       enddo
7802 C Calculate the local-electrostatic correlation terms
7803       do i=iatel_s,iatel_e+1
7804         i1=i+1
7805         num_conti=num_cont_hb(i)
7806         num_conti1=num_cont_hb(i+1)
7807         do jj=1,num_conti
7808           j=jcont_hb(jj,i)
7809           do kk=1,num_conti1
7810             j1=jcont_hb(kk,i1)
7811 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7812 c     &         ' jj=',jj,' kk=',kk
7813             if (j1.eq.j+1 .or. j1.eq.j-1) then
7814 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7815 C The system gains extra energy.
7816               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7817               n_corr=n_corr+1
7818             else if (j1.eq.j) then
7819 C Contacts I-J and I-(J+1) occur simultaneously.
7820 C The system loses extra energy.
7821 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7822             endif
7823           enddo ! kk
7824           do kk=1,num_conti
7825             j1=jcont_hb(kk,i)
7826 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7827 c    &         ' jj=',jj,' kk=',kk
7828             if (j1.eq.j+1) then
7829 C Contacts I-J and (I+1)-J occur simultaneously.
7830 C The system loses extra energy.
7831 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7832             endif ! j1==j+1
7833           enddo ! kk
7834         enddo ! jj
7835       enddo ! i
7836       return
7837       end
7838 c------------------------------------------------------------------------------
7839       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7840      &  n_corr1)
7841 C This subroutine calculates multi-body contributions to hydrogen-bonding
7842       implicit real*8 (a-h,o-z)
7843       include 'DIMENSIONS'
7844       include 'DIMENSIONS.ZSCOPT'
7845       include 'COMMON.IOUNITS'
7846 #ifdef MPI
7847       include "mpif.h"
7848 #endif
7849       include 'COMMON.FFIELD'
7850       include 'COMMON.DERIV'
7851       include 'COMMON.LOCAL'
7852       include 'COMMON.INTERACT'
7853       include 'COMMON.CONTACTS'
7854       include 'COMMON.CHAIN'
7855       include 'COMMON.CONTROL'
7856       include 'COMMON.SHIELD'
7857       double precision gx(3),gx1(3)
7858       integer num_cont_hb_old(maxres)
7859       logical lprn,ldone
7860       double precision eello4,eello5,eelo6,eello_turn6
7861       external eello4,eello5,eello6,eello_turn6
7862 C Set lprn=.true. for debugging
7863       lprn=.false.
7864       eturn6=0.0d0
7865       if (lprn) then
7866         write (iout,'(a)') 'Contact function values:'
7867         do i=nnt,nct-2
7868           write (iout,'(2i3,50(1x,i2,5f6.3))')
7869      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7870      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7871         enddo
7872       endif
7873       ecorr=0.0D0
7874       ecorr5=0.0d0
7875       ecorr6=0.0d0
7876 C Remove the loop below after debugging !!!
7877       do i=nnt,nct
7878         do j=1,3
7879           gradcorr(j,i)=0.0D0
7880           gradxorr(j,i)=0.0D0
7881         enddo
7882       enddo
7883 C Calculate the dipole-dipole interaction energies
7884       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7885       do i=iatel_s,iatel_e+1
7886         num_conti=num_cont_hb(i)
7887         do jj=1,num_conti
7888           j=jcont_hb(jj,i)
7889 #ifdef MOMENT
7890           call dipole(i,j,jj)
7891 #endif
7892         enddo
7893       enddo
7894       endif
7895 C Calculate the local-electrostatic correlation terms
7896 c                write (iout,*) "gradcorr5 in eello5 before loop"
7897 c                do iii=1,nres
7898 c                  write (iout,'(i5,3f10.5)')
7899 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7900 c                enddo
7901       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7902 c        write (iout,*) "corr loop i",i
7903         i1=i+1
7904         num_conti=num_cont_hb(i)
7905         num_conti1=num_cont_hb(i+1)
7906         do jj=1,num_conti
7907           j=jcont_hb(jj,i)
7908           jp=iabs(j)
7909           do kk=1,num_conti1
7910             j1=jcont_hb(kk,i1)
7911             jp1=iabs(j1)
7912 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7913 c     &         ' jj=',jj,' kk=',kk
7914 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7915             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7916      &          .or. j.lt.0 .and. j1.gt.0) .and.
7917      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7918 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7919 C The system gains extra energy.
7920               n_corr=n_corr+1
7921               sqd1=dsqrt(d_cont(jj,i))
7922               sqd2=dsqrt(d_cont(kk,i1))
7923               sred_geom = sqd1*sqd2
7924               IF (sred_geom.lt.cutoff_corr) THEN
7925                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7926      &            ekont,fprimcont)
7927 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7928 cd     &         ' jj=',jj,' kk=',kk
7929                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7930                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7931                 do l=1,3
7932                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7933                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7934                 enddo
7935                 n_corr1=n_corr1+1
7936 cd               write (iout,*) 'sred_geom=',sred_geom,
7937 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7938 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7939 cd               write (iout,*) "g_contij",g_contij
7940 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7941 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7942                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7943                 if (wcorr4.gt.0.0d0)
7944      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7945 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7946                   if (energy_dec.and.wcorr4.gt.0.0d0)
7947      1                 write (iout,'(a6,4i5,0pf7.3)')
7948      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7949 c                write (iout,*) "gradcorr5 before eello5"
7950 c                do iii=1,nres
7951 c                  write (iout,'(i5,3f10.5)')
7952 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7953 c                enddo
7954                 if (wcorr5.gt.0.0d0)
7955      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7956 c                write (iout,*) "gradcorr5 after eello5"
7957 c                do iii=1,nres
7958 c                  write (iout,'(i5,3f10.5)')
7959 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7960 c                enddo
7961                   if (energy_dec.and.wcorr5.gt.0.0d0)
7962      1                 write (iout,'(a6,4i5,0pf7.3)')
7963      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7964 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7965 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7966                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7967      &               .or. wturn6.eq.0.0d0))then
7968 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7969                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7970                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7971      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7972 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7973 cd     &            'ecorr6=',ecorr6
7974 cd                write (iout,'(4e15.5)') sred_geom,
7975 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7976 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7977 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7978                 else if (wturn6.gt.0.0d0
7979      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7980 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7981                   eturn6=eturn6+eello_turn6(i,jj,kk)
7982                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7983      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7984 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7985                 endif
7986               ENDIF
7987 1111          continue
7988             endif
7989           enddo ! kk
7990         enddo ! jj
7991       enddo ! i
7992       do i=1,nres
7993         num_cont_hb(i)=num_cont_hb_old(i)
7994       enddo
7995 c                write (iout,*) "gradcorr5 in eello5"
7996 c                do iii=1,nres
7997 c                  write (iout,'(i5,3f10.5)')
7998 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7999 c                enddo
8000       return
8001       end
8002 c------------------------------------------------------------------------------
8003       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8004       implicit real*8 (a-h,o-z)
8005       include 'DIMENSIONS'
8006       include 'DIMENSIONS.ZSCOPT'
8007       include 'COMMON.IOUNITS'
8008       include 'COMMON.DERIV'
8009       include 'COMMON.INTERACT'
8010       include 'COMMON.CONTACTS'
8011       include 'COMMON.SHIELD'
8012       include 'COMMON.CONTROL'
8013       double precision gx(3),gx1(3)
8014       logical lprn
8015       lprn=.false.
8016 C      print *,"wchodze",fac_shield(i),shield_mode
8017       eij=facont_hb(jj,i)
8018       ekl=facont_hb(kk,k)
8019       ees0pij=ees0p(jj,i)
8020       ees0pkl=ees0p(kk,k)
8021       ees0mij=ees0m(jj,i)
8022       ees0mkl=ees0m(kk,k)
8023       ekont=eij*ekl
8024       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8025 C*
8026 C     & fac_shield(i)**2*fac_shield(j)**2
8027 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8028 C Following 4 lines for diagnostics.
8029 cd    ees0pkl=0.0D0
8030 cd    ees0pij=1.0D0
8031 cd    ees0mkl=0.0D0
8032 cd    ees0mij=1.0D0
8033 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8034 c     & 'Contacts ',i,j,
8035 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8036 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8037 c     & 'gradcorr_long'
8038 C Calculate the multi-body contribution to energy.
8039 C      ecorr=ecorr+ekont*ees
8040 C Calculate multi-body contributions to the gradient.
8041       coeffpees0pij=coeffp*ees0pij
8042       coeffmees0mij=coeffm*ees0mij
8043       coeffpees0pkl=coeffp*ees0pkl
8044       coeffmees0mkl=coeffm*ees0mkl
8045       do ll=1,3
8046 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8047         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8048      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8049      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8050         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8051      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8052      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8053 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8054         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8055      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8056      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8057         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8058      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8059      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8060         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8061      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8062      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8063         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8064         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8065         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8066      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8067      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8068         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8069         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8070 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8071       enddo
8072 c      write (iout,*)
8073 cgrad      do m=i+1,j-1
8074 cgrad        do ll=1,3
8075 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8076 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8077 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8078 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8079 cgrad        enddo
8080 cgrad      enddo
8081 cgrad      do m=k+1,l-1
8082 cgrad        do ll=1,3
8083 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8084 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8085 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8086 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8087 cgrad        enddo
8088 cgrad      enddo
8089 c      write (iout,*) "ehbcorr",ekont*ees
8090 C      print *,ekont,ees,i,k
8091       ehbcorr=ekont*ees
8092 C now gradient over shielding
8093 C      return
8094       if (shield_mode.gt.0) then
8095        j=ees0plist(jj,i)
8096        l=ees0plist(kk,k)
8097 C        print *,i,j,fac_shield(i),fac_shield(j),
8098 C     &fac_shield(k),fac_shield(l)
8099         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8100      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8101           do ilist=1,ishield_list(i)
8102            iresshield=shield_list(ilist,i)
8103            do m=1,3
8104            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8105 C     &      *2.0
8106            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8107      &              rlocshield
8108      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8109             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8110      &+rlocshield
8111            enddo
8112           enddo
8113           do ilist=1,ishield_list(j)
8114            iresshield=shield_list(ilist,j)
8115            do m=1,3
8116            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8117 C     &     *2.0
8118            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8119      &              rlocshield
8120      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8121            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8122      &     +rlocshield
8123            enddo
8124           enddo
8125
8126           do ilist=1,ishield_list(k)
8127            iresshield=shield_list(ilist,k)
8128            do m=1,3
8129            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8130 C     &     *2.0
8131            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8132      &              rlocshield
8133      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8134            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8135      &     +rlocshield
8136            enddo
8137           enddo
8138           do ilist=1,ishield_list(l)
8139            iresshield=shield_list(ilist,l)
8140            do m=1,3
8141            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8142 C     &     *2.0
8143            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8144      &              rlocshield
8145      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8146            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8147      &     +rlocshield
8148            enddo
8149           enddo
8150 C          print *,gshieldx(m,iresshield)
8151           do m=1,3
8152             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8153      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8154             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8155      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8156             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8157      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8158             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8159      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8160
8161             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8162      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8163             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8164      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8165             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8166      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8167             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8168      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8169
8170            enddo
8171       endif
8172       endif
8173       return
8174       end
8175 #ifdef MOMENT
8176 C---------------------------------------------------------------------------
8177       subroutine dipole(i,j,jj)
8178       implicit real*8 (a-h,o-z)
8179       include 'DIMENSIONS'
8180       include 'DIMENSIONS.ZSCOPT'
8181       include 'COMMON.IOUNITS'
8182       include 'COMMON.CHAIN'
8183       include 'COMMON.FFIELD'
8184       include 'COMMON.DERIV'
8185       include 'COMMON.INTERACT'
8186       include 'COMMON.CONTACTS'
8187       include 'COMMON.TORSION'
8188       include 'COMMON.VAR'
8189       include 'COMMON.GEO'
8190       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8191      &  auxmat(2,2)
8192       iti1 = itortyp(itype(i+1))
8193       if (j.lt.nres-1) then
8194         itj1 = itype2loc(itype(j+1))
8195       else
8196         itj1=nloctyp
8197       endif
8198       do iii=1,2
8199         dipi(iii,1)=Ub2(iii,i)
8200         dipderi(iii)=Ub2der(iii,i)
8201         dipi(iii,2)=b1(iii,i+1)
8202         dipj(iii,1)=Ub2(iii,j)
8203         dipderj(iii)=Ub2der(iii,j)
8204         dipj(iii,2)=b1(iii,j+1)
8205       enddo
8206       kkk=0
8207       do iii=1,2
8208         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8209         do jjj=1,2
8210           kkk=kkk+1
8211           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8212         enddo
8213       enddo
8214       do kkk=1,5
8215         do lll=1,3
8216           mmm=0
8217           do iii=1,2
8218             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8219      &        auxvec(1))
8220             do jjj=1,2
8221               mmm=mmm+1
8222               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8223             enddo
8224           enddo
8225         enddo
8226       enddo
8227       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8228       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8229       do iii=1,2
8230         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8231       enddo
8232       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8233       do iii=1,2
8234         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8235       enddo
8236       return
8237       end
8238 #endif
8239 C---------------------------------------------------------------------------
8240       subroutine calc_eello(i,j,k,l,jj,kk)
8241 C
8242 C This subroutine computes matrices and vectors needed to calculate
8243 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8244 C
8245       implicit real*8 (a-h,o-z)
8246       include 'DIMENSIONS'
8247       include 'DIMENSIONS.ZSCOPT'
8248       include 'COMMON.IOUNITS'
8249       include 'COMMON.CHAIN'
8250       include 'COMMON.DERIV'
8251       include 'COMMON.INTERACT'
8252       include 'COMMON.CONTACTS'
8253       include 'COMMON.TORSION'
8254       include 'COMMON.VAR'
8255       include 'COMMON.GEO'
8256       include 'COMMON.FFIELD'
8257       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8258      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8259       logical lprn
8260       common /kutas/ lprn
8261 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8262 cd     & ' jj=',jj,' kk=',kk
8263 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8264 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8265 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8266       do iii=1,2
8267         do jjj=1,2
8268           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8269           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8270         enddo
8271       enddo
8272       call transpose2(aa1(1,1),aa1t(1,1))
8273       call transpose2(aa2(1,1),aa2t(1,1))
8274       do kkk=1,5
8275         do lll=1,3
8276           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8277      &      aa1tder(1,1,lll,kkk))
8278           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8279      &      aa2tder(1,1,lll,kkk))
8280         enddo
8281       enddo
8282       if (l.eq.j+1) then
8283 C parallel orientation of the two CA-CA-CA frames.
8284         if (i.gt.1) then
8285           iti=itype2loc(itype(i))
8286         else
8287           iti=nloctyp
8288         endif
8289         itk1=itype2loc(itype(k+1))
8290         itj=itype2loc(itype(j))
8291         if (l.lt.nres-1) then
8292           itl1=itype2loc(itype(l+1))
8293         else
8294           itl1=nloctyp
8295         endif
8296 C A1 kernel(j+1) A2T
8297 cd        do iii=1,2
8298 cd          write (iout,'(3f10.5,5x,3f10.5)')
8299 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8300 cd        enddo
8301         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8302      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8303      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8304 C Following matrices are needed only for 6-th order cumulants
8305         IF (wcorr6.gt.0.0d0) THEN
8306         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8307      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8308      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8310      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8311      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8312      &   ADtEAderx(1,1,1,1,1,1))
8313         lprn=.false.
8314         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8315      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8316      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8317      &   ADtEA1derx(1,1,1,1,1,1))
8318         ENDIF
8319 C End 6-th order cumulants
8320 cd        lprn=.false.
8321 cd        if (lprn) then
8322 cd        write (2,*) 'In calc_eello6'
8323 cd        do iii=1,2
8324 cd          write (2,*) 'iii=',iii
8325 cd          do kkk=1,5
8326 cd            write (2,*) 'kkk=',kkk
8327 cd            do jjj=1,2
8328 cd              write (2,'(3(2f10.5),5x)')
8329 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8330 cd            enddo
8331 cd          enddo
8332 cd        enddo
8333 cd        endif
8334         call transpose2(EUgder(1,1,k),auxmat(1,1))
8335         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8336         call transpose2(EUg(1,1,k),auxmat(1,1))
8337         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8338         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8339         do iii=1,2
8340           do kkk=1,5
8341             do lll=1,3
8342               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8343      &          EAEAderx(1,1,lll,kkk,iii,1))
8344             enddo
8345           enddo
8346         enddo
8347 C A1T kernel(i+1) A2
8348         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8349      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8350      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8351 C Following matrices are needed only for 6-th order cumulants
8352         IF (wcorr6.gt.0.0d0) THEN
8353         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8354      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8355      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8356         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8357      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8358      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8359      &   ADtEAderx(1,1,1,1,1,2))
8360         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8361      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8362      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8363      &   ADtEA1derx(1,1,1,1,1,2))
8364         ENDIF
8365 C End 6-th order cumulants
8366         call transpose2(EUgder(1,1,l),auxmat(1,1))
8367         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8368         call transpose2(EUg(1,1,l),auxmat(1,1))
8369         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8370         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8371         do iii=1,2
8372           do kkk=1,5
8373             do lll=1,3
8374               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8375      &          EAEAderx(1,1,lll,kkk,iii,2))
8376             enddo
8377           enddo
8378         enddo
8379 C AEAb1 and AEAb2
8380 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8381 C They are needed only when the fifth- or the sixth-order cumulants are
8382 C indluded.
8383         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8384         call transpose2(AEA(1,1,1),auxmat(1,1))
8385         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8386         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8387         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8388         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8389         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8390         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8391         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8392         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8393         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8394         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8395         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8396         call transpose2(AEA(1,1,2),auxmat(1,1))
8397         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8398         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8399         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8400         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8401         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8402         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8403         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8404         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8405         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8406         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8407         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8408 C Calculate the Cartesian derivatives of the vectors.
8409         do iii=1,2
8410           do kkk=1,5
8411             do lll=1,3
8412               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8413               call matvec2(auxmat(1,1),b1(1,i),
8414      &          AEAb1derx(1,lll,kkk,iii,1,1))
8415               call matvec2(auxmat(1,1),Ub2(1,i),
8416      &          AEAb2derx(1,lll,kkk,iii,1,1))
8417               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8418      &          AEAb1derx(1,lll,kkk,iii,2,1))
8419               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8420      &          AEAb2derx(1,lll,kkk,iii,2,1))
8421               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8422               call matvec2(auxmat(1,1),b1(1,j),
8423      &          AEAb1derx(1,lll,kkk,iii,1,2))
8424               call matvec2(auxmat(1,1),Ub2(1,j),
8425      &          AEAb2derx(1,lll,kkk,iii,1,2))
8426               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8427      &          AEAb1derx(1,lll,kkk,iii,2,2))
8428               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8429      &          AEAb2derx(1,lll,kkk,iii,2,2))
8430             enddo
8431           enddo
8432         enddo
8433         ENDIF
8434 C End vectors
8435       else
8436 C Antiparallel orientation of the two CA-CA-CA frames.
8437         if (i.gt.1) then
8438           iti=itype2loc(itype(i))
8439         else
8440           iti=nloctyp
8441         endif
8442         itk1=itype2loc(itype(k+1))
8443         itl=itype2loc(itype(l))
8444         itj=itype2loc(itype(j))
8445         if (j.lt.nres-1) then
8446           itj1=itype2loc(itype(j+1))
8447         else
8448           itj1=nloctyp
8449         endif
8450 C A2 kernel(j-1)T A1T
8451         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8452      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8453      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8454 C Following matrices are needed only for 6-th order cumulants
8455         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8456      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8457         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8458      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8459      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8460         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8461      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8462      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8463      &   ADtEAderx(1,1,1,1,1,1))
8464         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8465      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8466      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8467      &   ADtEA1derx(1,1,1,1,1,1))
8468         ENDIF
8469 C End 6-th order cumulants
8470         call transpose2(EUgder(1,1,k),auxmat(1,1))
8471         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8472         call transpose2(EUg(1,1,k),auxmat(1,1))
8473         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8474         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8475         do iii=1,2
8476           do kkk=1,5
8477             do lll=1,3
8478               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8479      &          EAEAderx(1,1,lll,kkk,iii,1))
8480             enddo
8481           enddo
8482         enddo
8483 C A2T kernel(i+1)T A1
8484         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8485      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8486      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8487 C Following matrices are needed only for 6-th order cumulants
8488         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8489      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8490         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8491      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8492      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8493         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8494      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8495      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8496      &   ADtEAderx(1,1,1,1,1,2))
8497         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8498      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8499      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8500      &   ADtEA1derx(1,1,1,1,1,2))
8501         ENDIF
8502 C End 6-th order cumulants
8503         call transpose2(EUgder(1,1,j),auxmat(1,1))
8504         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8505         call transpose2(EUg(1,1,j),auxmat(1,1))
8506         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8507         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8508         do iii=1,2
8509           do kkk=1,5
8510             do lll=1,3
8511               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8512      &          EAEAderx(1,1,lll,kkk,iii,2))
8513             enddo
8514           enddo
8515         enddo
8516 C AEAb1 and AEAb2
8517 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8518 C They are needed only when the fifth- or the sixth-order cumulants are
8519 C indluded.
8520         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8521      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8522         call transpose2(AEA(1,1,1),auxmat(1,1))
8523         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8524         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8525         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8526         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8527         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8528         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8529         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8530         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8531         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8532         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8533         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8534         call transpose2(AEA(1,1,2),auxmat(1,1))
8535         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8536         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8537         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8538         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8539         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8540         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8541         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8542         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8543         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8544         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8545         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8546 C Calculate the Cartesian derivatives of the vectors.
8547         do iii=1,2
8548           do kkk=1,5
8549             do lll=1,3
8550               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8551               call matvec2(auxmat(1,1),b1(1,i),
8552      &          AEAb1derx(1,lll,kkk,iii,1,1))
8553               call matvec2(auxmat(1,1),Ub2(1,i),
8554      &          AEAb2derx(1,lll,kkk,iii,1,1))
8555               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8556      &          AEAb1derx(1,lll,kkk,iii,2,1))
8557               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8558      &          AEAb2derx(1,lll,kkk,iii,2,1))
8559               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8560               call matvec2(auxmat(1,1),b1(1,l),
8561      &          AEAb1derx(1,lll,kkk,iii,1,2))
8562               call matvec2(auxmat(1,1),Ub2(1,l),
8563      &          AEAb2derx(1,lll,kkk,iii,1,2))
8564               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8565      &          AEAb1derx(1,lll,kkk,iii,2,2))
8566               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8567      &          AEAb2derx(1,lll,kkk,iii,2,2))
8568             enddo
8569           enddo
8570         enddo
8571         ENDIF
8572 C End vectors
8573       endif
8574       return
8575       end
8576 C---------------------------------------------------------------------------
8577       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8578      &  KK,KKderg,AKA,AKAderg,AKAderx)
8579       implicit none
8580       integer nderg
8581       logical transp
8582       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8583      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8584      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8585       integer iii,kkk,lll
8586       integer jjj,mmm
8587       logical lprn
8588       common /kutas/ lprn
8589       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8590       do iii=1,nderg
8591         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8592      &    AKAderg(1,1,iii))
8593       enddo
8594 cd      if (lprn) write (2,*) 'In kernel'
8595       do kkk=1,5
8596 cd        if (lprn) write (2,*) 'kkk=',kkk
8597         do lll=1,3
8598           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8599      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8600 cd          if (lprn) then
8601 cd            write (2,*) 'lll=',lll
8602 cd            write (2,*) 'iii=1'
8603 cd            do jjj=1,2
8604 cd              write (2,'(3(2f10.5),5x)')
8605 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8606 cd            enddo
8607 cd          endif
8608           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8609      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8610 cd          if (lprn) then
8611 cd            write (2,*) 'lll=',lll
8612 cd            write (2,*) 'iii=2'
8613 cd            do jjj=1,2
8614 cd              write (2,'(3(2f10.5),5x)')
8615 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8616 cd            enddo
8617 cd          endif
8618         enddo
8619       enddo
8620       return
8621       end
8622 C---------------------------------------------------------------------------
8623       double precision function eello4(i,j,k,l,jj,kk)
8624       implicit real*8 (a-h,o-z)
8625       include 'DIMENSIONS'
8626       include 'DIMENSIONS.ZSCOPT'
8627       include 'COMMON.IOUNITS'
8628       include 'COMMON.CHAIN'
8629       include 'COMMON.DERIV'
8630       include 'COMMON.INTERACT'
8631       include 'COMMON.CONTACTS'
8632       include 'COMMON.TORSION'
8633       include 'COMMON.VAR'
8634       include 'COMMON.GEO'
8635       double precision pizda(2,2),ggg1(3),ggg2(3)
8636 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8637 cd        eello4=0.0d0
8638 cd        return
8639 cd      endif
8640 cd      print *,'eello4:',i,j,k,l,jj,kk
8641 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8642 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8643 cold      eij=facont_hb(jj,i)
8644 cold      ekl=facont_hb(kk,k)
8645 cold      ekont=eij*ekl
8646       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8647       if (calc_grad) then
8648 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8649       gcorr_loc(k-1)=gcorr_loc(k-1)
8650      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8651       if (l.eq.j+1) then
8652         gcorr_loc(l-1)=gcorr_loc(l-1)
8653      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8654       else
8655         gcorr_loc(j-1)=gcorr_loc(j-1)
8656      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8657       endif
8658       do iii=1,2
8659         do kkk=1,5
8660           do lll=1,3
8661             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8662      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8663 cd            derx(lll,kkk,iii)=0.0d0
8664           enddo
8665         enddo
8666       enddo
8667 cd      gcorr_loc(l-1)=0.0d0
8668 cd      gcorr_loc(j-1)=0.0d0
8669 cd      gcorr_loc(k-1)=0.0d0
8670 cd      eel4=1.0d0
8671 cd      write (iout,*)'Contacts have occurred for peptide groups',
8672 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8673 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8674       if (j.lt.nres-1) then
8675         j1=j+1
8676         j2=j-1
8677       else
8678         j1=j-1
8679         j2=j-2
8680       endif
8681       if (l.lt.nres-1) then
8682         l1=l+1
8683         l2=l-1
8684       else
8685         l1=l-1
8686         l2=l-2
8687       endif
8688       do ll=1,3
8689 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8690 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8691         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8692         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8693 cgrad        ghalf=0.5d0*ggg1(ll)
8694         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8695         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8696         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8697         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8698         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8699         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8700 cgrad        ghalf=0.5d0*ggg2(ll)
8701         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8702         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8703         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8704         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8705         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8706         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8707       enddo
8708 cgrad      do m=i+1,j-1
8709 cgrad        do ll=1,3
8710 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8711 cgrad        enddo
8712 cgrad      enddo
8713 cgrad      do m=k+1,l-1
8714 cgrad        do ll=1,3
8715 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8716 cgrad        enddo
8717 cgrad      enddo
8718 cgrad      do m=i+2,j2
8719 cgrad        do ll=1,3
8720 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8721 cgrad        enddo
8722 cgrad      enddo
8723 cgrad      do m=k+2,l2
8724 cgrad        do ll=1,3
8725 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8726 cgrad        enddo
8727 cgrad      enddo
8728 cd      do iii=1,nres-3
8729 cd        write (2,*) iii,gcorr_loc(iii)
8730 cd      enddo
8731       endif ! calc_grad
8732       eello4=ekont*eel4
8733 cd      write (2,*) 'ekont',ekont
8734 cd      write (iout,*) 'eello4',ekont*eel4
8735       return
8736       end
8737 C---------------------------------------------------------------------------
8738       double precision function eello5(i,j,k,l,jj,kk)
8739       implicit real*8 (a-h,o-z)
8740       include 'DIMENSIONS'
8741       include 'DIMENSIONS.ZSCOPT'
8742       include 'COMMON.IOUNITS'
8743       include 'COMMON.CHAIN'
8744       include 'COMMON.DERIV'
8745       include 'COMMON.INTERACT'
8746       include 'COMMON.CONTACTS'
8747       include 'COMMON.TORSION'
8748       include 'COMMON.VAR'
8749       include 'COMMON.GEO'
8750       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8751       double precision ggg1(3),ggg2(3)
8752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8753 C                                                                              C
8754 C                            Parallel chains                                   C
8755 C                                                                              C
8756 C          o             o                   o             o                   C
8757 C         /l\           / \             \   / \           / \   /              C
8758 C        /   \         /   \             \ /   \         /   \ /               C
8759 C       j| o |l1       | o |              o| o |         | o |o                C
8760 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8761 C      \i/   \         /   \ /             /   \         /   \                 C
8762 C       o    k1             o                                                  C
8763 C         (I)          (II)                (III)          (IV)                 C
8764 C                                                                              C
8765 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8766 C                                                                              C
8767 C                            Antiparallel chains                               C
8768 C                                                                              C
8769 C          o             o                   o             o                   C
8770 C         /j\           / \             \   / \           / \   /              C
8771 C        /   \         /   \             \ /   \         /   \ /               C
8772 C      j1| o |l        | o |              o| o |         | o |o                C
8773 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8774 C      \i/   \         /   \ /             /   \         /   \                 C
8775 C       o     k1            o                                                  C
8776 C         (I)          (II)                (III)          (IV)                 C
8777 C                                                                              C
8778 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8779 C                                                                              C
8780 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8781 C                                                                              C
8782 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8783 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8784 cd        eello5=0.0d0
8785 cd        return
8786 cd      endif
8787 cd      write (iout,*)
8788 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8789 cd     &   ' and',k,l
8790       itk=itype2loc(itype(k))
8791       itl=itype2loc(itype(l))
8792       itj=itype2loc(itype(j))
8793       eello5_1=0.0d0
8794       eello5_2=0.0d0
8795       eello5_3=0.0d0
8796       eello5_4=0.0d0
8797 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8798 cd     &   eel5_3_num,eel5_4_num)
8799       do iii=1,2
8800         do kkk=1,5
8801           do lll=1,3
8802             derx(lll,kkk,iii)=0.0d0
8803           enddo
8804         enddo
8805       enddo
8806 cd      eij=facont_hb(jj,i)
8807 cd      ekl=facont_hb(kk,k)
8808 cd      ekont=eij*ekl
8809 cd      write (iout,*)'Contacts have occurred for peptide groups',
8810 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8811 cd      goto 1111
8812 C Contribution from the graph I.
8813 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8814 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8815       call transpose2(EUg(1,1,k),auxmat(1,1))
8816       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8817       vv(1)=pizda(1,1)-pizda(2,2)
8818       vv(2)=pizda(1,2)+pizda(2,1)
8819       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8820      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8821       if (calc_grad) then
8822 C Explicit gradient in virtual-dihedral angles.
8823       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8824      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8825      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8826       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8827       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8828       vv(1)=pizda(1,1)-pizda(2,2)
8829       vv(2)=pizda(1,2)+pizda(2,1)
8830       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8831      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8832      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8833       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8834       vv(1)=pizda(1,1)-pizda(2,2)
8835       vv(2)=pizda(1,2)+pizda(2,1)
8836       if (l.eq.j+1) then
8837         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8838      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8839      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8840       else
8841         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8842      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8843      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8844       endif
8845 C Cartesian gradient
8846       do iii=1,2
8847         do kkk=1,5
8848           do lll=1,3
8849             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8850      &        pizda(1,1))
8851             vv(1)=pizda(1,1)-pizda(2,2)
8852             vv(2)=pizda(1,2)+pizda(2,1)
8853             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8854      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8855      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8856           enddo
8857         enddo
8858       enddo
8859       endif ! calc_grad
8860 c      goto 1112
8861 c1111  continue
8862 C Contribution from graph II
8863       call transpose2(EE(1,1,k),auxmat(1,1))
8864       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8865       vv(1)=pizda(1,1)+pizda(2,2)
8866       vv(2)=pizda(2,1)-pizda(1,2)
8867       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8868      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8869       if (calc_grad) then
8870 C Explicit gradient in virtual-dihedral angles.
8871       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8872      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8873       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8874       vv(1)=pizda(1,1)+pizda(2,2)
8875       vv(2)=pizda(2,1)-pizda(1,2)
8876       if (l.eq.j+1) then
8877         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8878      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8879      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8880       else
8881         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8882      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8883      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8884       endif
8885 C Cartesian gradient
8886       do iii=1,2
8887         do kkk=1,5
8888           do lll=1,3
8889             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8890      &        pizda(1,1))
8891             vv(1)=pizda(1,1)+pizda(2,2)
8892             vv(2)=pizda(2,1)-pizda(1,2)
8893             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8894      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8895      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8896           enddo
8897         enddo
8898       enddo
8899       endif ! calc_grad
8900 cd      goto 1112
8901 cd1111  continue
8902       if (l.eq.j+1) then
8903 cd        goto 1110
8904 C Parallel orientation
8905 C Contribution from graph III
8906         call transpose2(EUg(1,1,l),auxmat(1,1))
8907         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8908         vv(1)=pizda(1,1)-pizda(2,2)
8909         vv(2)=pizda(1,2)+pizda(2,1)
8910         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8911      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8912         if (calc_grad) then
8913 C Explicit gradient in virtual-dihedral angles.
8914         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8915      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8916      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8917         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8918         vv(1)=pizda(1,1)-pizda(2,2)
8919         vv(2)=pizda(1,2)+pizda(2,1)
8920         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8921      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8922      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8923         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8924         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8925         vv(1)=pizda(1,1)-pizda(2,2)
8926         vv(2)=pizda(1,2)+pizda(2,1)
8927         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8928      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8929      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8930 C Cartesian gradient
8931         do iii=1,2
8932           do kkk=1,5
8933             do lll=1,3
8934               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8935      &          pizda(1,1))
8936               vv(1)=pizda(1,1)-pizda(2,2)
8937               vv(2)=pizda(1,2)+pizda(2,1)
8938               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8939      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8940      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8941             enddo
8942           enddo
8943         enddo
8944 cd        goto 1112
8945 C Contribution from graph IV
8946 cd1110    continue
8947         call transpose2(EE(1,1,l),auxmat(1,1))
8948         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8949         vv(1)=pizda(1,1)+pizda(2,2)
8950         vv(2)=pizda(2,1)-pizda(1,2)
8951         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8952      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8953 C Explicit gradient in virtual-dihedral angles.
8954         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8955      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8956         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8957         vv(1)=pizda(1,1)+pizda(2,2)
8958         vv(2)=pizda(2,1)-pizda(1,2)
8959         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8960      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8961      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8962 C Cartesian gradient
8963         do iii=1,2
8964           do kkk=1,5
8965             do lll=1,3
8966               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8967      &          pizda(1,1))
8968               vv(1)=pizda(1,1)+pizda(2,2)
8969               vv(2)=pizda(2,1)-pizda(1,2)
8970               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8971      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8972      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8973             enddo
8974           enddo
8975         enddo
8976         endif ! calc_grad
8977       else
8978 C Antiparallel orientation
8979 C Contribution from graph III
8980 c        goto 1110
8981         call transpose2(EUg(1,1,j),auxmat(1,1))
8982         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8983         vv(1)=pizda(1,1)-pizda(2,2)
8984         vv(2)=pizda(1,2)+pizda(2,1)
8985         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8986      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8987         if (calc_grad) then
8988 C Explicit gradient in virtual-dihedral angles.
8989         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8990      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8991      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8992         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8993         vv(1)=pizda(1,1)-pizda(2,2)
8994         vv(2)=pizda(1,2)+pizda(2,1)
8995         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8996      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8997      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8998         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8999         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9000         vv(1)=pizda(1,1)-pizda(2,2)
9001         vv(2)=pizda(1,2)+pizda(2,1)
9002         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9003      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9004      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9005 C Cartesian gradient
9006         do iii=1,2
9007           do kkk=1,5
9008             do lll=1,3
9009               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9010      &          pizda(1,1))
9011               vv(1)=pizda(1,1)-pizda(2,2)
9012               vv(2)=pizda(1,2)+pizda(2,1)
9013               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9014      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9015      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9016             enddo
9017           enddo
9018         enddo
9019         endif ! calc_grad
9020 cd        goto 1112
9021 C Contribution from graph IV
9022 1110    continue
9023         call transpose2(EE(1,1,j),auxmat(1,1))
9024         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9025         vv(1)=pizda(1,1)+pizda(2,2)
9026         vv(2)=pizda(2,1)-pizda(1,2)
9027         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9028      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9029         if (calc_grad) then
9030 C Explicit gradient in virtual-dihedral angles.
9031         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9032      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9033         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9034         vv(1)=pizda(1,1)+pizda(2,2)
9035         vv(2)=pizda(2,1)-pizda(1,2)
9036         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9037      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9038      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9039 C Cartesian gradient
9040         do iii=1,2
9041           do kkk=1,5
9042             do lll=1,3
9043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9044      &          pizda(1,1))
9045               vv(1)=pizda(1,1)+pizda(2,2)
9046               vv(2)=pizda(2,1)-pizda(1,2)
9047               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9048      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9049      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9050             enddo
9051           enddo
9052         enddo
9053         endif ! calc_grad
9054       endif
9055 1112  continue
9056       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9057 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9058 cd        write (2,*) 'ijkl',i,j,k,l
9059 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9060 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9061 cd      endif
9062 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9063 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9064 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9065 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9066       if (calc_grad) then
9067       if (j.lt.nres-1) then
9068         j1=j+1
9069         j2=j-1
9070       else
9071         j1=j-1
9072         j2=j-2
9073       endif
9074       if (l.lt.nres-1) then
9075         l1=l+1
9076         l2=l-1
9077       else
9078         l1=l-1
9079         l2=l-2
9080       endif
9081 cd      eij=1.0d0
9082 cd      ekl=1.0d0
9083 cd      ekont=1.0d0
9084 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9085 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9086 C        summed up outside the subrouine as for the other subroutines
9087 C        handling long-range interactions. The old code is commented out
9088 C        with "cgrad" to keep track of changes.
9089       do ll=1,3
9090 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9091 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9092         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9093         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9094 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9095 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9096 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9097 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9098 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9099 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9100 c     &   gradcorr5ij,
9101 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9102 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9103 cgrad        ghalf=0.5d0*ggg1(ll)
9104 cd        ghalf=0.0d0
9105         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9106         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9107         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9108         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9109         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9110         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9111 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9112 cgrad        ghalf=0.5d0*ggg2(ll)
9113 cd        ghalf=0.0d0
9114         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9115         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9116         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9117         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9118         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9119         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9120       enddo
9121       endif ! calc_grad
9122 cd      goto 1112
9123 cgrad      do m=i+1,j-1
9124 cgrad        do ll=1,3
9125 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9126 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9127 cgrad        enddo
9128 cgrad      enddo
9129 cgrad      do m=k+1,l-1
9130 cgrad        do ll=1,3
9131 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9132 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9133 cgrad        enddo
9134 cgrad      enddo
9135 c1112  continue
9136 cgrad      do m=i+2,j2
9137 cgrad        do ll=1,3
9138 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9139 cgrad        enddo
9140 cgrad      enddo
9141 cgrad      do m=k+2,l2
9142 cgrad        do ll=1,3
9143 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9144 cgrad        enddo
9145 cgrad      enddo
9146 cd      do iii=1,nres-3
9147 cd        write (2,*) iii,g_corr5_loc(iii)
9148 cd      enddo
9149       eello5=ekont*eel5
9150 cd      write (2,*) 'ekont',ekont
9151 cd      write (iout,*) 'eello5',ekont*eel5
9152       return
9153       end
9154 c--------------------------------------------------------------------------
9155       double precision function eello6(i,j,k,l,jj,kk)
9156       implicit real*8 (a-h,o-z)
9157       include 'DIMENSIONS'
9158       include 'DIMENSIONS.ZSCOPT'
9159       include 'COMMON.IOUNITS'
9160       include 'COMMON.CHAIN'
9161       include 'COMMON.DERIV'
9162       include 'COMMON.INTERACT'
9163       include 'COMMON.CONTACTS'
9164       include 'COMMON.TORSION'
9165       include 'COMMON.VAR'
9166       include 'COMMON.GEO'
9167       include 'COMMON.FFIELD'
9168       double precision ggg1(3),ggg2(3)
9169 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9170 cd        eello6=0.0d0
9171 cd        return
9172 cd      endif
9173 cd      write (iout,*)
9174 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9175 cd     &   ' and',k,l
9176       eello6_1=0.0d0
9177       eello6_2=0.0d0
9178       eello6_3=0.0d0
9179       eello6_4=0.0d0
9180       eello6_5=0.0d0
9181       eello6_6=0.0d0
9182 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9183 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9184       do iii=1,2
9185         do kkk=1,5
9186           do lll=1,3
9187             derx(lll,kkk,iii)=0.0d0
9188           enddo
9189         enddo
9190       enddo
9191 cd      eij=facont_hb(jj,i)
9192 cd      ekl=facont_hb(kk,k)
9193 cd      ekont=eij*ekl
9194 cd      eij=1.0d0
9195 cd      ekl=1.0d0
9196 cd      ekont=1.0d0
9197       if (l.eq.j+1) then
9198         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9199         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9200         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9201         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9202         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9203         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9204       else
9205         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9206         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9207         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9208         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9209         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9210           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9211         else
9212           eello6_5=0.0d0
9213         endif
9214         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9215       endif
9216 C If turn contributions are considered, they will be handled separately.
9217       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9218 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9219 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9220 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9221 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9222 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9223 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9224 cd      goto 1112
9225       if (calc_grad) then
9226       if (j.lt.nres-1) then
9227         j1=j+1
9228         j2=j-1
9229       else
9230         j1=j-1
9231         j2=j-2
9232       endif
9233       if (l.lt.nres-1) then
9234         l1=l+1
9235         l2=l-1
9236       else
9237         l1=l-1
9238         l2=l-2
9239       endif
9240       do ll=1,3
9241 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9242 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9243 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9244 cgrad        ghalf=0.5d0*ggg1(ll)
9245 cd        ghalf=0.0d0
9246         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9247         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9248         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9249         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9250         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9251         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9252         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9253         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9254 cgrad        ghalf=0.5d0*ggg2(ll)
9255 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9256 cd        ghalf=0.0d0
9257         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9258         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9259         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9260         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9261         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9262         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9263       enddo
9264       endif ! calc_grad
9265 cd      goto 1112
9266 cgrad      do m=i+1,j-1
9267 cgrad        do ll=1,3
9268 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9269 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9270 cgrad        enddo
9271 cgrad      enddo
9272 cgrad      do m=k+1,l-1
9273 cgrad        do ll=1,3
9274 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9275 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9276 cgrad        enddo
9277 cgrad      enddo
9278 cgrad1112  continue
9279 cgrad      do m=i+2,j2
9280 cgrad        do ll=1,3
9281 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9282 cgrad        enddo
9283 cgrad      enddo
9284 cgrad      do m=k+2,l2
9285 cgrad        do ll=1,3
9286 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9287 cgrad        enddo
9288 cgrad      enddo
9289 cd      do iii=1,nres-3
9290 cd        write (2,*) iii,g_corr6_loc(iii)
9291 cd      enddo
9292       eello6=ekont*eel6
9293 cd      write (2,*) 'ekont',ekont
9294 cd      write (iout,*) 'eello6',ekont*eel6
9295       return
9296       end
9297 c--------------------------------------------------------------------------
9298       double precision function eello6_graph1(i,j,k,l,imat,swap)
9299       implicit real*8 (a-h,o-z)
9300       include 'DIMENSIONS'
9301       include 'DIMENSIONS.ZSCOPT'
9302       include 'COMMON.IOUNITS'
9303       include 'COMMON.CHAIN'
9304       include 'COMMON.DERIV'
9305       include 'COMMON.INTERACT'
9306       include 'COMMON.CONTACTS'
9307       include 'COMMON.TORSION'
9308       include 'COMMON.VAR'
9309       include 'COMMON.GEO'
9310       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9311       logical swap
9312       logical lprn
9313       common /kutas/ lprn
9314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9315 C                                                                              C
9316 C      Parallel       Antiparallel                                             C
9317 C                                                                              C
9318 C          o             o                                                     C
9319 C         /l\           /j\                                                    C
9320 C        /   \         /   \                                                   C
9321 C       /| o |         | o |\                                                  C
9322 C     \ j|/k\|  /   \  |/k\|l /                                                C
9323 C      \ /   \ /     \ /   \ /                                                 C
9324 C       o     o       o     o                                                  C
9325 C       i             i                                                        C
9326 C                                                                              C
9327 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9328       itk=itype2loc(itype(k))
9329       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9330       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9331       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9332       call transpose2(EUgC(1,1,k),auxmat(1,1))
9333       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9334       vv1(1)=pizda1(1,1)-pizda1(2,2)
9335       vv1(2)=pizda1(1,2)+pizda1(2,1)
9336       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9337       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9338       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9339       s5=scalar2(vv(1),Dtobr2(1,i))
9340 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9341       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9342       if (calc_grad) then
9343       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9344      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9345      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9346      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9347      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9348      & +scalar2(vv(1),Dtobr2der(1,i)))
9349       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9350       vv1(1)=pizda1(1,1)-pizda1(2,2)
9351       vv1(2)=pizda1(1,2)+pizda1(2,1)
9352       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9353       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9354       if (l.eq.j+1) then
9355         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9356      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9357      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9358      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9359      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9360       else
9361         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9362      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9363      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9364      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9365      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9366       endif
9367       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9368       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9369       vv1(1)=pizda1(1,1)-pizda1(2,2)
9370       vv1(2)=pizda1(1,2)+pizda1(2,1)
9371       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9372      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9373      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9374      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9375       do iii=1,2
9376         if (swap) then
9377           ind=3-iii
9378         else
9379           ind=iii
9380         endif
9381         do kkk=1,5
9382           do lll=1,3
9383             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9384             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9385             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9386             call transpose2(EUgC(1,1,k),auxmat(1,1))
9387             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9388      &        pizda1(1,1))
9389             vv1(1)=pizda1(1,1)-pizda1(2,2)
9390             vv1(2)=pizda1(1,2)+pizda1(2,1)
9391             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9392             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9393      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9394             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9395      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9396             s5=scalar2(vv(1),Dtobr2(1,i))
9397             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9398           enddo
9399         enddo
9400       enddo
9401       endif ! calc_grad
9402       return
9403       end
9404 c----------------------------------------------------------------------------
9405       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9406       implicit real*8 (a-h,o-z)
9407       include 'DIMENSIONS'
9408       include 'DIMENSIONS.ZSCOPT'
9409       include 'COMMON.IOUNITS'
9410       include 'COMMON.CHAIN'
9411       include 'COMMON.DERIV'
9412       include 'COMMON.INTERACT'
9413       include 'COMMON.CONTACTS'
9414       include 'COMMON.TORSION'
9415       include 'COMMON.VAR'
9416       include 'COMMON.GEO'
9417       logical swap
9418       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9419      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9420       logical lprn
9421       common /kutas/ lprn
9422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9423 C                                                                              C
9424 C      Parallel       Antiparallel                                             C
9425 C                                                                              C
9426 C          o             o                                                     C
9427 C     \   /l\           /j\   /                                                C
9428 C      \ /   \         /   \ /                                                 C
9429 C       o| o |         | o |o                                                  C
9430 C     \ j|/k\|      \  |/k\|l                                                  C
9431 C      \ /   \       \ /   \                                                   C
9432 C       o             o                                                        C
9433 C       i             i                                                        C
9434 C                                                                              C
9435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9436 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9437 C AL 7/4/01 s1 would occur in the sixth-order moment,
9438 C           but not in a cluster cumulant
9439 #ifdef MOMENT
9440       s1=dip(1,jj,i)*dip(1,kk,k)
9441 #endif
9442       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9443       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9444       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9445       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9446       call transpose2(EUg(1,1,k),auxmat(1,1))
9447       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9448       vv(1)=pizda(1,1)-pizda(2,2)
9449       vv(2)=pizda(1,2)+pizda(2,1)
9450       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9451 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9452 #ifdef MOMENT
9453       eello6_graph2=-(s1+s2+s3+s4)
9454 #else
9455       eello6_graph2=-(s2+s3+s4)
9456 #endif
9457 c      eello6_graph2=-s3
9458 C Derivatives in gamma(i-1)
9459       if (calc_grad) then
9460       if (i.gt.1) then
9461 #ifdef MOMENT
9462         s1=dipderg(1,jj,i)*dip(1,kk,k)
9463 #endif
9464         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9465         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9466         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9467         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9468 #ifdef MOMENT
9469         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9470 #else
9471         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9472 #endif
9473 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9474       endif
9475 C Derivatives in gamma(k-1)
9476 #ifdef MOMENT
9477       s1=dip(1,jj,i)*dipderg(1,kk,k)
9478 #endif
9479       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9480       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9481       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9482       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9483       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9484       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9485       vv(1)=pizda(1,1)-pizda(2,2)
9486       vv(2)=pizda(1,2)+pizda(2,1)
9487       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9488 #ifdef MOMENT
9489       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9490 #else
9491       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9492 #endif
9493 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9494 C Derivatives in gamma(j-1) or gamma(l-1)
9495       if (j.gt.1) then
9496 #ifdef MOMENT
9497         s1=dipderg(3,jj,i)*dip(1,kk,k)
9498 #endif
9499         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9500         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9501         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9502         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9503         vv(1)=pizda(1,1)-pizda(2,2)
9504         vv(2)=pizda(1,2)+pizda(2,1)
9505         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9506 #ifdef MOMENT
9507         if (swap) then
9508           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9509         else
9510           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9511         endif
9512 #endif
9513         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9514 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9515       endif
9516 C Derivatives in gamma(l-1) or gamma(j-1)
9517       if (l.gt.1) then
9518 #ifdef MOMENT
9519         s1=dip(1,jj,i)*dipderg(3,kk,k)
9520 #endif
9521         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9522         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9523         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9524         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9525         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9526         vv(1)=pizda(1,1)-pizda(2,2)
9527         vv(2)=pizda(1,2)+pizda(2,1)
9528         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9529 #ifdef MOMENT
9530         if (swap) then
9531           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9532         else
9533           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9534         endif
9535 #endif
9536         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9537 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9538       endif
9539 C Cartesian derivatives.
9540       if (lprn) then
9541         write (2,*) 'In eello6_graph2'
9542         do iii=1,2
9543           write (2,*) 'iii=',iii
9544           do kkk=1,5
9545             write (2,*) 'kkk=',kkk
9546             do jjj=1,2
9547               write (2,'(3(2f10.5),5x)')
9548      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9549             enddo
9550           enddo
9551         enddo
9552       endif
9553       do iii=1,2
9554         do kkk=1,5
9555           do lll=1,3
9556 #ifdef MOMENT
9557             if (iii.eq.1) then
9558               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9559             else
9560               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9561             endif
9562 #endif
9563             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9564      &        auxvec(1))
9565             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9566             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9567      &        auxvec(1))
9568             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9569             call transpose2(EUg(1,1,k),auxmat(1,1))
9570             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9571      &        pizda(1,1))
9572             vv(1)=pizda(1,1)-pizda(2,2)
9573             vv(2)=pizda(1,2)+pizda(2,1)
9574             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9575 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9576 #ifdef MOMENT
9577             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9578 #else
9579             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9580 #endif
9581             if (swap) then
9582               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9583             else
9584               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9585             endif
9586           enddo
9587         enddo
9588       enddo
9589       endif ! calc_grad
9590       return
9591       end
9592 c----------------------------------------------------------------------------
9593       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9594       implicit real*8 (a-h,o-z)
9595       include 'DIMENSIONS'
9596       include 'DIMENSIONS.ZSCOPT'
9597       include 'COMMON.IOUNITS'
9598       include 'COMMON.CHAIN'
9599       include 'COMMON.DERIV'
9600       include 'COMMON.INTERACT'
9601       include 'COMMON.CONTACTS'
9602       include 'COMMON.TORSION'
9603       include 'COMMON.VAR'
9604       include 'COMMON.GEO'
9605       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9606       logical swap
9607 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9608 C                                                                              C
9609 C      Parallel       Antiparallel                                             C
9610 C                                                                              C
9611 C          o             o                                                     C
9612 C         /l\   /   \   /j\                                                    C
9613 C        /   \ /     \ /   \                                                   C
9614 C       /| o |o       o| o |\                                                  C
9615 C       j|/k\|  /      |/k\|l /                                                C
9616 C        /   \ /       /   \ /                                                 C
9617 C       /     o       /     o                                                  C
9618 C       i             i                                                        C
9619 C                                                                              C
9620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9621 C
9622 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9623 C           energy moment and not to the cluster cumulant.
9624       iti=itortyp(itype(i))
9625       if (j.lt.nres-1) then
9626         itj1=itype2loc(itype(j+1))
9627       else
9628         itj1=nloctyp
9629       endif
9630       itk=itype2loc(itype(k))
9631       itk1=itype2loc(itype(k+1))
9632       if (l.lt.nres-1) then
9633         itl1=itype2loc(itype(l+1))
9634       else
9635         itl1=nloctyp
9636       endif
9637 #ifdef MOMENT
9638       s1=dip(4,jj,i)*dip(4,kk,k)
9639 #endif
9640       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9641       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9642       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9643       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9644       call transpose2(EE(1,1,k),auxmat(1,1))
9645       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9646       vv(1)=pizda(1,1)+pizda(2,2)
9647       vv(2)=pizda(2,1)-pizda(1,2)
9648       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9649 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9650 cd     & "sum",-(s2+s3+s4)
9651 #ifdef MOMENT
9652       eello6_graph3=-(s1+s2+s3+s4)
9653 #else
9654       eello6_graph3=-(s2+s3+s4)
9655 #endif
9656 c      eello6_graph3=-s4
9657 C Derivatives in gamma(k-1)
9658       if (calc_grad) then
9659       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9660       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9661       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9662       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9663 C Derivatives in gamma(l-1)
9664       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9665       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9666       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9667       vv(1)=pizda(1,1)+pizda(2,2)
9668       vv(2)=pizda(2,1)-pizda(1,2)
9669       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9670       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9671 C Cartesian derivatives.
9672       do iii=1,2
9673         do kkk=1,5
9674           do lll=1,3
9675 #ifdef MOMENT
9676             if (iii.eq.1) then
9677               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9678             else
9679               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9680             endif
9681 #endif
9682             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9683      &        auxvec(1))
9684             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9685             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9686      &        auxvec(1))
9687             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9688             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9689      &        pizda(1,1))
9690             vv(1)=pizda(1,1)+pizda(2,2)
9691             vv(2)=pizda(2,1)-pizda(1,2)
9692             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9693 #ifdef MOMENT
9694             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9695 #else
9696             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9697 #endif
9698             if (swap) then
9699               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9700             else
9701               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9702             endif
9703 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9704           enddo
9705         enddo
9706       enddo
9707       endif ! calc_grad
9708       return
9709       end
9710 c----------------------------------------------------------------------------
9711       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9712       implicit real*8 (a-h,o-z)
9713       include 'DIMENSIONS'
9714       include 'DIMENSIONS.ZSCOPT'
9715       include 'COMMON.IOUNITS'
9716       include 'COMMON.CHAIN'
9717       include 'COMMON.DERIV'
9718       include 'COMMON.INTERACT'
9719       include 'COMMON.CONTACTS'
9720       include 'COMMON.TORSION'
9721       include 'COMMON.VAR'
9722       include 'COMMON.GEO'
9723       include 'COMMON.FFIELD'
9724       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9725      & auxvec1(2),auxmat1(2,2)
9726       logical swap
9727 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9728 C                                                                              C
9729 C      Parallel       Antiparallel                                             C
9730 C                                                                              C
9731 C          o             o                                                     C
9732 C         /l\   /   \   /j\                                                    C
9733 C        /   \ /     \ /   \                                                   C
9734 C       /| o |o       o| o |\                                                  C
9735 C     \ j|/k\|      \  |/k\|l                                                  C
9736 C      \ /   \       \ /   \                                                   C
9737 C       o     \       o     \                                                  C
9738 C       i             i                                                        C
9739 C                                                                              C
9740 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9741 C
9742 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9743 C           energy moment and not to the cluster cumulant.
9744 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9745       iti=itype2loc(itype(i))
9746       itj=itype2loc(itype(j))
9747       if (j.lt.nres-1) then
9748         itj1=itype2loc(itype(j+1))
9749       else
9750         itj1=nloctyp
9751       endif
9752       itk=itype2loc(itype(k))
9753       if (k.lt.nres-1) then
9754         itk1=itype2loc(itype(k+1))
9755       else
9756         itk1=nloctyp
9757       endif
9758       itl=itype2loc(itype(l))
9759       if (l.lt.nres-1) then
9760         itl1=itype2loc(itype(l+1))
9761       else
9762         itl1=nloctyp
9763       endif
9764 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9765 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9766 cd     & ' itl',itl,' itl1',itl1
9767 #ifdef MOMENT
9768       if (imat.eq.1) then
9769         s1=dip(3,jj,i)*dip(3,kk,k)
9770       else
9771         s1=dip(2,jj,j)*dip(2,kk,l)
9772       endif
9773 #endif
9774       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9775       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9776       if (j.eq.l+1) then
9777         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9778         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9779       else
9780         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9781         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9782       endif
9783       call transpose2(EUg(1,1,k),auxmat(1,1))
9784       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9785       vv(1)=pizda(1,1)-pizda(2,2)
9786       vv(2)=pizda(2,1)+pizda(1,2)
9787       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9788 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9789 #ifdef MOMENT
9790       eello6_graph4=-(s1+s2+s3+s4)
9791 #else
9792       eello6_graph4=-(s2+s3+s4)
9793 #endif
9794 C Derivatives in gamma(i-1)
9795       if (calc_grad) then
9796       if (i.gt.1) then
9797 #ifdef MOMENT
9798         if (imat.eq.1) then
9799           s1=dipderg(2,jj,i)*dip(3,kk,k)
9800         else
9801           s1=dipderg(4,jj,j)*dip(2,kk,l)
9802         endif
9803 #endif
9804         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9805         if (j.eq.l+1) then
9806           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9807           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9808         else
9809           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9810           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9811         endif
9812         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9813         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9814 cd          write (2,*) 'turn6 derivatives'
9815 #ifdef MOMENT
9816           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9817 #else
9818           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9819 #endif
9820         else
9821 #ifdef MOMENT
9822           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9823 #else
9824           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9825 #endif
9826         endif
9827       endif
9828 C Derivatives in gamma(k-1)
9829 #ifdef MOMENT
9830       if (imat.eq.1) then
9831         s1=dip(3,jj,i)*dipderg(2,kk,k)
9832       else
9833         s1=dip(2,jj,j)*dipderg(4,kk,l)
9834       endif
9835 #endif
9836       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9837       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9838       if (j.eq.l+1) then
9839         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9840         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9841       else
9842         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9843         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9844       endif
9845       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9846       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9847       vv(1)=pizda(1,1)-pizda(2,2)
9848       vv(2)=pizda(2,1)+pizda(1,2)
9849       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9850       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9851 #ifdef MOMENT
9852         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9853 #else
9854         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9855 #endif
9856       else
9857 #ifdef MOMENT
9858         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9859 #else
9860         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9861 #endif
9862       endif
9863 C Derivatives in gamma(j-1) or gamma(l-1)
9864       if (l.eq.j+1 .and. l.gt.1) then
9865         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9866         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9867         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9868         vv(1)=pizda(1,1)-pizda(2,2)
9869         vv(2)=pizda(2,1)+pizda(1,2)
9870         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9871         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9872       else if (j.gt.1) then
9873         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9874         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9875         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9876         vv(1)=pizda(1,1)-pizda(2,2)
9877         vv(2)=pizda(2,1)+pizda(1,2)
9878         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9879         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9880           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9881         else
9882           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9883         endif
9884       endif
9885 C Cartesian derivatives.
9886       do iii=1,2
9887         do kkk=1,5
9888           do lll=1,3
9889 #ifdef MOMENT
9890             if (iii.eq.1) then
9891               if (imat.eq.1) then
9892                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9893               else
9894                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9895               endif
9896             else
9897               if (imat.eq.1) then
9898                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9899               else
9900                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9901               endif
9902             endif
9903 #endif
9904             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9905      &        auxvec(1))
9906             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9907             if (j.eq.l+1) then
9908               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9909      &          b1(1,j+1),auxvec(1))
9910               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9911             else
9912               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9913      &          b1(1,l+1),auxvec(1))
9914               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9915             endif
9916             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9917      &        pizda(1,1))
9918             vv(1)=pizda(1,1)-pizda(2,2)
9919             vv(2)=pizda(2,1)+pizda(1,2)
9920             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9921             if (swap) then
9922               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9923 #ifdef MOMENT
9924                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9925      &             -(s1+s2+s4)
9926 #else
9927                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9928      &             -(s2+s4)
9929 #endif
9930                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9931               else
9932 #ifdef MOMENT
9933                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9934 #else
9935                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9936 #endif
9937                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9938               endif
9939             else
9940 #ifdef MOMENT
9941               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9942 #else
9943               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9944 #endif
9945               if (l.eq.j+1) then
9946                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9947               else
9948                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9949               endif
9950             endif
9951           enddo
9952         enddo
9953       enddo
9954       endif ! calc_grad
9955       return
9956       end
9957 c----------------------------------------------------------------------------
9958       double precision function eello_turn6(i,jj,kk)
9959       implicit real*8 (a-h,o-z)
9960       include 'DIMENSIONS'
9961       include 'DIMENSIONS.ZSCOPT'
9962       include 'COMMON.IOUNITS'
9963       include 'COMMON.CHAIN'
9964       include 'COMMON.DERIV'
9965       include 'COMMON.INTERACT'
9966       include 'COMMON.CONTACTS'
9967       include 'COMMON.TORSION'
9968       include 'COMMON.VAR'
9969       include 'COMMON.GEO'
9970       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9971      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9972      &  ggg1(3),ggg2(3)
9973       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9974      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9975 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9976 C           the respective energy moment and not to the cluster cumulant.
9977       s1=0.0d0
9978       s8=0.0d0
9979       s13=0.0d0
9980 c
9981       eello_turn6=0.0d0
9982       j=i+4
9983       k=i+1
9984       l=i+3
9985       iti=itype2loc(itype(i))
9986       itk=itype2loc(itype(k))
9987       itk1=itype2loc(itype(k+1))
9988       itl=itype2loc(itype(l))
9989       itj=itype2loc(itype(j))
9990 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9991 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9992 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9993 cd        eello6=0.0d0
9994 cd        return
9995 cd      endif
9996 cd      write (iout,*)
9997 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9998 cd     &   ' and',k,l
9999 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10000       do iii=1,2
10001         do kkk=1,5
10002           do lll=1,3
10003             derx_turn(lll,kkk,iii)=0.0d0
10004           enddo
10005         enddo
10006       enddo
10007 cd      eij=1.0d0
10008 cd      ekl=1.0d0
10009 cd      ekont=1.0d0
10010       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10011 cd      eello6_5=0.0d0
10012 cd      write (2,*) 'eello6_5',eello6_5
10013 #ifdef MOMENT
10014       call transpose2(AEA(1,1,1),auxmat(1,1))
10015       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10016       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10017       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10018 #endif
10019       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10020       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10021       s2 = scalar2(b1(1,k),vtemp1(1))
10022 #ifdef MOMENT
10023       call transpose2(AEA(1,1,2),atemp(1,1))
10024       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10025       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10026       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10027 #endif
10028       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10029       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10030       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10031 #ifdef MOMENT
10032       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10033       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10034       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10035       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10036       ss13 = scalar2(b1(1,k),vtemp4(1))
10037       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10038 #endif
10039 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10040 c      s1=0.0d0
10041 c      s2=0.0d0
10042 c      s8=0.0d0
10043 c      s12=0.0d0
10044 c      s13=0.0d0
10045       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10046 C Derivatives in gamma(i+2)
10047       if (calc_grad) then
10048       s1d =0.0d0
10049       s8d =0.0d0
10050 #ifdef MOMENT
10051       call transpose2(AEA(1,1,1),auxmatd(1,1))
10052       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10053       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10054       call transpose2(AEAderg(1,1,2),atempd(1,1))
10055       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10056       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10057 #endif
10058       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10059       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10060       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10061 c      s1d=0.0d0
10062 c      s2d=0.0d0
10063 c      s8d=0.0d0
10064 c      s12d=0.0d0
10065 c      s13d=0.0d0
10066       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10067 C Derivatives in gamma(i+3)
10068 #ifdef MOMENT
10069       call transpose2(AEA(1,1,1),auxmatd(1,1))
10070       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10071       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10072       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10073 #endif
10074       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10075       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10076       s2d = scalar2(b1(1,k),vtemp1d(1))
10077 #ifdef MOMENT
10078       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10079       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10080 #endif
10081       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10082 #ifdef MOMENT
10083       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10084       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10085       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10086 #endif
10087 c      s1d=0.0d0
10088 c      s2d=0.0d0
10089 c      s8d=0.0d0
10090 c      s12d=0.0d0
10091 c      s13d=0.0d0
10092 #ifdef MOMENT
10093       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10094      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10095 #else
10096       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10097      &               -0.5d0*ekont*(s2d+s12d)
10098 #endif
10099 C Derivatives in gamma(i+4)
10100       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10101       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10102       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10103 #ifdef MOMENT
10104       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10105       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10106       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10107 #endif
10108 c      s1d=0.0d0
10109 c      s2d=0.0d0
10110 c      s8d=0.0d0
10111 C      s12d=0.0d0
10112 c      s13d=0.0d0
10113 #ifdef MOMENT
10114       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10115 #else
10116       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10117 #endif
10118 C Derivatives in gamma(i+5)
10119 #ifdef MOMENT
10120       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10121       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10122       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10123 #endif
10124       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10125       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10126       s2d = scalar2(b1(1,k),vtemp1d(1))
10127 #ifdef MOMENT
10128       call transpose2(AEA(1,1,2),atempd(1,1))
10129       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10130       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10131 #endif
10132       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10133       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10134 #ifdef MOMENT
10135       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10136       ss13d = scalar2(b1(1,k),vtemp4d(1))
10137       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10138 #endif
10139 c      s1d=0.0d0
10140 c      s2d=0.0d0
10141 c      s8d=0.0d0
10142 c      s12d=0.0d0
10143 c      s13d=0.0d0
10144 #ifdef MOMENT
10145       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10146      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10147 #else
10148       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10149      &               -0.5d0*ekont*(s2d+s12d)
10150 #endif
10151 C Cartesian derivatives
10152       do iii=1,2
10153         do kkk=1,5
10154           do lll=1,3
10155 #ifdef MOMENT
10156             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10157             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10158             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10159 #endif
10160             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10161             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10162      &          vtemp1d(1))
10163             s2d = scalar2(b1(1,k),vtemp1d(1))
10164 #ifdef MOMENT
10165             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10166             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10167             s8d = -(atempd(1,1)+atempd(2,2))*
10168      &           scalar2(cc(1,1,l),vtemp2(1))
10169 #endif
10170             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10171      &           auxmatd(1,1))
10172             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10173             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10174 c      s1d=0.0d0
10175 c      s2d=0.0d0
10176 c      s8d=0.0d0
10177 c      s12d=0.0d0
10178 c      s13d=0.0d0
10179 #ifdef MOMENT
10180             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10181      &        - 0.5d0*(s1d+s2d)
10182 #else
10183             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10184      &        - 0.5d0*s2d
10185 #endif
10186 #ifdef MOMENT
10187             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10188      &        - 0.5d0*(s8d+s12d)
10189 #else
10190             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10191      &        - 0.5d0*s12d
10192 #endif
10193           enddo
10194         enddo
10195       enddo
10196 #ifdef MOMENT
10197       do kkk=1,5
10198         do lll=1,3
10199           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10200      &      achuj_tempd(1,1))
10201           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10202           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10203           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10204           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10205           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10206      &      vtemp4d(1))
10207           ss13d = scalar2(b1(1,k),vtemp4d(1))
10208           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10209           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10210         enddo
10211       enddo
10212 #endif
10213 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10214 cd     &  16*eel_turn6_num
10215 cd      goto 1112
10216       if (j.lt.nres-1) then
10217         j1=j+1
10218         j2=j-1
10219       else
10220         j1=j-1
10221         j2=j-2
10222       endif
10223       if (l.lt.nres-1) then
10224         l1=l+1
10225         l2=l-1
10226       else
10227         l1=l-1
10228         l2=l-2
10229       endif
10230       do ll=1,3
10231 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10232 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10233 cgrad        ghalf=0.5d0*ggg1(ll)
10234 cd        ghalf=0.0d0
10235         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10236         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10237         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10238      &    +ekont*derx_turn(ll,2,1)
10239         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10240         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10241      &    +ekont*derx_turn(ll,4,1)
10242         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10243         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10244         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10245 cgrad        ghalf=0.5d0*ggg2(ll)
10246 cd        ghalf=0.0d0
10247         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10248      &    +ekont*derx_turn(ll,2,2)
10249         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10250         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10251      &    +ekont*derx_turn(ll,4,2)
10252         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10253         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10254         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10255       enddo
10256 cd      goto 1112
10257 cgrad      do m=i+1,j-1
10258 cgrad        do ll=1,3
10259 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10260 cgrad        enddo
10261 cgrad      enddo
10262 cgrad      do m=k+1,l-1
10263 cgrad        do ll=1,3
10264 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10265 cgrad        enddo
10266 cgrad      enddo
10267 cgrad1112  continue
10268 cgrad      do m=i+2,j2
10269 cgrad        do ll=1,3
10270 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10271 cgrad        enddo
10272 cgrad      enddo
10273 cgrad      do m=k+2,l2
10274 cgrad        do ll=1,3
10275 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10276 cgrad        enddo
10277 cgrad      enddo
10278 cd      do iii=1,nres-3
10279 cd        write (2,*) iii,g_corr6_loc(iii)
10280 cd      enddo
10281       endif ! calc_grad
10282       eello_turn6=ekont*eel_turn6
10283 cd      write (2,*) 'ekont',ekont
10284 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10285       return
10286       end
10287
10288 crc-------------------------------------------------
10289 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10290       subroutine Eliptransfer(eliptran)
10291       implicit real*8 (a-h,o-z)
10292       include 'DIMENSIONS'
10293       include 'DIMENSIONS.ZSCOPT'
10294       include 'COMMON.GEO'
10295       include 'COMMON.VAR'
10296       include 'COMMON.LOCAL'
10297       include 'COMMON.CHAIN'
10298       include 'COMMON.DERIV'
10299       include 'COMMON.INTERACT'
10300       include 'COMMON.IOUNITS'
10301       include 'COMMON.CALC'
10302       include 'COMMON.CONTROL'
10303       include 'COMMON.SPLITELE'
10304       include 'COMMON.SBRIDGE'
10305 C this is done by Adasko
10306 C      print *,"wchodze"
10307 C structure of box:
10308 C      water
10309 C--bordliptop-- buffore starts
10310 C--bufliptop--- here true lipid starts
10311 C      lipid
10312 C--buflipbot--- lipid ends buffore starts
10313 C--bordlipbot--buffore ends
10314       eliptran=0.0
10315       do i=1,nres
10316 C       do i=1,1
10317         if (itype(i).eq.ntyp1) cycle
10318
10319         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10320         if (positi.le.0) positi=positi+boxzsize
10321 C        print *,i
10322 C first for peptide groups
10323 c for each residue check if it is in lipid or lipid water border area
10324        if ((positi.gt.bordlipbot)
10325      &.and.(positi.lt.bordliptop)) then
10326 C the energy transfer exist
10327         if (positi.lt.buflipbot) then
10328 C what fraction I am in
10329          fracinbuf=1.0d0-
10330      &        ((positi-bordlipbot)/lipbufthick)
10331 C lipbufthick is thickenes of lipid buffore
10332          sslip=sscalelip(fracinbuf)
10333          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10334          eliptran=eliptran+sslip*pepliptran
10335          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10336          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10337 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10338         elseif (positi.gt.bufliptop) then
10339          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10340          sslip=sscalelip(fracinbuf)
10341          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10342          eliptran=eliptran+sslip*pepliptran
10343          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10344          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10345 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10346 C          print *, "doing sscalefor top part"
10347 C         print *,i,sslip,fracinbuf,ssgradlip
10348         else
10349          eliptran=eliptran+pepliptran
10350 C         print *,"I am in true lipid"
10351         endif
10352 C       else
10353 C       eliptran=elpitran+0.0 ! I am in water
10354        endif
10355        enddo
10356 C       print *, "nic nie bylo w lipidzie?"
10357 C now multiply all by the peptide group transfer factor
10358 C       eliptran=eliptran*pepliptran
10359 C now the same for side chains
10360 CV       do i=1,1
10361        do i=1,nres
10362         if (itype(i).eq.ntyp1) cycle
10363         positi=(mod(c(3,i+nres),boxzsize))
10364         if (positi.le.0) positi=positi+boxzsize
10365 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10366 c for each residue check if it is in lipid or lipid water border area
10367 C       respos=mod(c(3,i+nres),boxzsize)
10368 C       print *,positi,bordlipbot,buflipbot
10369        if ((positi.gt.bordlipbot)
10370      & .and.(positi.lt.bordliptop)) then
10371 C the energy transfer exist
10372         if (positi.lt.buflipbot) then
10373          fracinbuf=1.0d0-
10374      &     ((positi-bordlipbot)/lipbufthick)
10375 C lipbufthick is thickenes of lipid buffore
10376          sslip=sscalelip(fracinbuf)
10377          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10378          eliptran=eliptran+sslip*liptranene(itype(i))
10379          gliptranx(3,i)=gliptranx(3,i)
10380      &+ssgradlip*liptranene(itype(i))
10381          gliptranc(3,i-1)= gliptranc(3,i-1)
10382      &+ssgradlip*liptranene(itype(i))
10383 C         print *,"doing sccale for lower part"
10384         elseif (positi.gt.bufliptop) then
10385          fracinbuf=1.0d0-
10386      &((bordliptop-positi)/lipbufthick)
10387          sslip=sscalelip(fracinbuf)
10388          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10389          eliptran=eliptran+sslip*liptranene(itype(i))
10390          gliptranx(3,i)=gliptranx(3,i)
10391      &+ssgradlip*liptranene(itype(i))
10392          gliptranc(3,i-1)= gliptranc(3,i-1)
10393      &+ssgradlip*liptranene(itype(i))
10394 C          print *, "doing sscalefor top part",sslip,fracinbuf
10395         else
10396          eliptran=eliptran+liptranene(itype(i))
10397 C         print *,"I am in true lipid"
10398         endif
10399         endif ! if in lipid or buffor
10400 C       else
10401 C       eliptran=elpitran+0.0 ! I am in water
10402        enddo
10403        return
10404        end
10405
10406
10407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10408
10409       SUBROUTINE MATVEC2(A1,V1,V2)
10410       implicit real*8 (a-h,o-z)
10411       include 'DIMENSIONS'
10412       DIMENSION A1(2,2),V1(2),V2(2)
10413 c      DO 1 I=1,2
10414 c        VI=0.0
10415 c        DO 3 K=1,2
10416 c    3     VI=VI+A1(I,K)*V1(K)
10417 c        Vaux(I)=VI
10418 c    1 CONTINUE
10419
10420       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10421       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10422
10423       v2(1)=vaux1
10424       v2(2)=vaux2
10425       END
10426 C---------------------------------------
10427       SUBROUTINE MATMAT2(A1,A2,A3)
10428       implicit real*8 (a-h,o-z)
10429       include 'DIMENSIONS'
10430       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10431 c      DIMENSION AI3(2,2)
10432 c        DO  J=1,2
10433 c          A3IJ=0.0
10434 c          DO K=1,2
10435 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10436 c          enddo
10437 c          A3(I,J)=A3IJ
10438 c       enddo
10439 c      enddo
10440
10441       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10442       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10443       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10444       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10445
10446       A3(1,1)=AI3_11
10447       A3(2,1)=AI3_21
10448       A3(1,2)=AI3_12
10449       A3(2,2)=AI3_22
10450       END
10451
10452 c-------------------------------------------------------------------------
10453       double precision function scalar2(u,v)
10454       implicit none
10455       double precision u(2),v(2)
10456       double precision sc
10457       integer i
10458       scalar2=u(1)*v(1)+u(2)*v(2)
10459       return
10460       end
10461
10462 C-----------------------------------------------------------------------------
10463
10464       subroutine transpose2(a,at)
10465       implicit none
10466       double precision a(2,2),at(2,2)
10467       at(1,1)=a(1,1)
10468       at(1,2)=a(2,1)
10469       at(2,1)=a(1,2)
10470       at(2,2)=a(2,2)
10471       return
10472       end
10473 c--------------------------------------------------------------------------
10474       subroutine transpose(n,a,at)
10475       implicit none
10476       integer n,i,j
10477       double precision a(n,n),at(n,n)
10478       do i=1,n
10479         do j=1,n
10480           at(j,i)=a(i,j)
10481         enddo
10482       enddo
10483       return
10484       end
10485 C---------------------------------------------------------------------------
10486       subroutine prodmat3(a1,a2,kk,transp,prod)
10487       implicit none
10488       integer i,j
10489       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10490       logical transp
10491 crc      double precision auxmat(2,2),prod_(2,2)
10492
10493       if (transp) then
10494 crc        call transpose2(kk(1,1),auxmat(1,1))
10495 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10496 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10497
10498            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10499      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10500            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10501      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10502            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10503      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10504            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10505      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10506
10507       else
10508 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10509 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10510
10511            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10512      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10513            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10514      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10515            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10516      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10517            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10518      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10519
10520       endif
10521 c      call transpose2(a2(1,1),a2t(1,1))
10522
10523 crc      print *,transp
10524 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10525 crc      print *,((prod(i,j),i=1,2),j=1,2)
10526
10527       return
10528       end
10529 C-----------------------------------------------------------------------------
10530       double precision function scalar(u,v)
10531       implicit none
10532       double precision u(3),v(3)
10533       double precision sc
10534       integer i
10535       sc=0.0d0
10536       do i=1,3
10537         sc=sc+u(i)*v(i)
10538       enddo
10539       scalar=sc
10540       return
10541       end
10542 C-----------------------------------------------------------------------
10543       double precision function sscale(r)
10544       double precision r,gamm
10545       include "COMMON.SPLITELE"
10546       if(r.lt.r_cut-rlamb) then
10547         sscale=1.0d0
10548       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10549         gamm=(r-(r_cut-rlamb))/rlamb
10550         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10551       else
10552         sscale=0d0
10553       endif
10554       return
10555       end
10556 C-----------------------------------------------------------------------
10557 C-----------------------------------------------------------------------
10558       double precision function sscagrad(r)
10559       double precision r,gamm
10560       include "COMMON.SPLITELE"
10561       if(r.lt.r_cut-rlamb) then
10562         sscagrad=0.0d0
10563       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10564         gamm=(r-(r_cut-rlamb))/rlamb
10565         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10566       else
10567         sscagrad=0.0d0
10568       endif
10569       return
10570       end
10571 C-----------------------------------------------------------------------
10572 C-----------------------------------------------------------------------
10573       double precision function sscalelip(r)
10574       double precision r,gamm
10575       include "COMMON.SPLITELE"
10576 C      if(r.lt.r_cut-rlamb) then
10577 C        sscale=1.0d0
10578 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10579 C        gamm=(r-(r_cut-rlamb))/rlamb
10580         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10581 C      else
10582 C        sscale=0d0
10583 C      endif
10584       return
10585       end
10586 C-----------------------------------------------------------------------
10587       double precision function sscagradlip(r)
10588       double precision r,gamm
10589       include "COMMON.SPLITELE"
10590 C     if(r.lt.r_cut-rlamb) then
10591 C        sscagrad=0.0d0
10592 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10593 C        gamm=(r-(r_cut-rlamb))/rlamb
10594         sscagradlip=r*(6*r-6.0d0)
10595 C      else
10596 C        sscagrad=0.0d0
10597 C      endif
10598       return
10599       end
10600
10601 C-----------------------------------------------------------------------
10602        subroutine set_shield_fac
10603       implicit real*8 (a-h,o-z)
10604       include 'DIMENSIONS'
10605       include 'DIMENSIONS.ZSCOPT'
10606       include 'COMMON.CHAIN'
10607       include 'COMMON.DERIV'
10608       include 'COMMON.IOUNITS'
10609       include 'COMMON.SHIELD'
10610       include 'COMMON.INTERACT'
10611 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10612       double precision div77_81/0.974996043d0/,
10613      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10614
10615 C the vector between center of side_chain and peptide group
10616        double precision pep_side(3),long,side_calf(3),
10617      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10618      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10619 C the line belowe needs to be changed for FGPROC>1
10620       do i=1,nres-1
10621       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10622       ishield_list(i)=0
10623 Cif there two consequtive dummy atoms there is no peptide group between them
10624 C the line below has to be changed for FGPROC>1
10625       VolumeTotal=0.0
10626       do k=1,nres
10627        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10628        dist_pep_side=0.0
10629        dist_side_calf=0.0
10630        do j=1,3
10631 C first lets set vector conecting the ithe side-chain with kth side-chain
10632       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10633 C      pep_side(j)=2.0d0
10634 C and vector conecting the side-chain with its proper calfa
10635       side_calf(j)=c(j,k+nres)-c(j,k)
10636 C      side_calf(j)=2.0d0
10637       pept_group(j)=c(j,i)-c(j,i+1)
10638 C lets have their lenght
10639       dist_pep_side=pep_side(j)**2+dist_pep_side
10640       dist_side_calf=dist_side_calf+side_calf(j)**2
10641       dist_pept_group=dist_pept_group+pept_group(j)**2
10642       enddo
10643        dist_pep_side=dsqrt(dist_pep_side)
10644        dist_pept_group=dsqrt(dist_pept_group)
10645        dist_side_calf=dsqrt(dist_side_calf)
10646       do j=1,3
10647         pep_side_norm(j)=pep_side(j)/dist_pep_side
10648         side_calf_norm(j)=dist_side_calf
10649       enddo
10650 C now sscale fraction
10651        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10652 C       print *,buff_shield,"buff"
10653 C now sscale
10654         if (sh_frac_dist.le.0.0) cycle
10655 C If we reach here it means that this side chain reaches the shielding sphere
10656 C Lets add him to the list for gradient
10657         ishield_list(i)=ishield_list(i)+1
10658 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10659 C this list is essential otherwise problem would be O3
10660         shield_list(ishield_list(i),i)=k
10661 C Lets have the sscale value
10662         if (sh_frac_dist.gt.1.0) then
10663          scale_fac_dist=1.0d0
10664          do j=1,3
10665          sh_frac_dist_grad(j)=0.0d0
10666          enddo
10667         else
10668          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10669      &                   *(2.0*sh_frac_dist-3.0d0)
10670          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10671      &                  /dist_pep_side/buff_shield*0.5
10672 C remember for the final gradient multiply sh_frac_dist_grad(j)
10673 C for side_chain by factor -2 !
10674          do j=1,3
10675          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10676 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10677 C     &                    sh_frac_dist_grad(j)
10678          enddo
10679         endif
10680 C        if ((i.eq.3).and.(k.eq.2)) then
10681 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10682 C     & ,"TU"
10683 C        endif
10684
10685 C this is what is now we have the distance scaling now volume...
10686       short=short_r_sidechain(itype(k))
10687       long=long_r_sidechain(itype(k))
10688       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10689 C now costhet_grad
10690 C       costhet=0.0d0
10691        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10692 C       costhet_fac=0.0d0
10693        do j=1,3
10694          costhet_grad(j)=costhet_fac*pep_side(j)
10695        enddo
10696 C remember for the final gradient multiply costhet_grad(j)
10697 C for side_chain by factor -2 !
10698 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10699 C pep_side0pept_group is vector multiplication
10700       pep_side0pept_group=0.0
10701       do j=1,3
10702       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10703       enddo
10704       cosalfa=(pep_side0pept_group/
10705      & (dist_pep_side*dist_side_calf))
10706       fac_alfa_sin=1.0-cosalfa**2
10707       fac_alfa_sin=dsqrt(fac_alfa_sin)
10708       rkprim=fac_alfa_sin*(long-short)+short
10709 C now costhet_grad
10710        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10711        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10712
10713        do j=1,3
10714          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10715      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10716      &*(long-short)/fac_alfa_sin*cosalfa/
10717      &((dist_pep_side*dist_side_calf))*
10718      &((side_calf(j))-cosalfa*
10719      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10720
10721         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10722      &*(long-short)/fac_alfa_sin*cosalfa
10723      &/((dist_pep_side*dist_side_calf))*
10724      &(pep_side(j)-
10725      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10726        enddo
10727
10728       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10729      &                    /VSolvSphere_div
10730      &                    *wshield
10731 C now the gradient...
10732 C grad_shield is gradient of Calfa for peptide groups
10733 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10734 C     &               costhet,cosphi
10735 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10736 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10737       do j=1,3
10738       grad_shield(j,i)=grad_shield(j,i)
10739 C gradient po skalowaniu
10740      &                +(sh_frac_dist_grad(j)
10741 C  gradient po costhet
10742      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10743      &-scale_fac_dist*(cosphi_grad_long(j))
10744      &/(1.0-cosphi) )*div77_81
10745      &*VofOverlap
10746 C grad_shield_side is Cbeta sidechain gradient
10747       grad_shield_side(j,ishield_list(i),i)=
10748      &        (sh_frac_dist_grad(j)*-2.0d0
10749      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10750      &       +scale_fac_dist*(cosphi_grad_long(j))
10751      &        *2.0d0/(1.0-cosphi))
10752      &        *div77_81*VofOverlap
10753
10754        grad_shield_loc(j,ishield_list(i),i)=
10755      &   scale_fac_dist*cosphi_grad_loc(j)
10756      &        *2.0d0/(1.0-cosphi)
10757      &        *div77_81*VofOverlap
10758       enddo
10759       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10760       enddo
10761       fac_shield(i)=VolumeTotal*div77_81+div4_81
10762 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10763       enddo
10764       return
10765       end
10766 C--------------------------------------------------------------------------
10767 C first for shielding is setting of function of side-chains
10768        subroutine set_shield_fac2
10769       implicit real*8 (a-h,o-z)
10770       include 'DIMENSIONS'
10771       include 'DIMENSIONS.ZSCOPT'
10772       include 'COMMON.CHAIN'
10773       include 'COMMON.DERIV'
10774       include 'COMMON.IOUNITS'
10775       include 'COMMON.SHIELD'
10776       include 'COMMON.INTERACT'
10777 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10778       double precision div77_81/0.974996043d0/,
10779      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10780
10781 C the vector between center of side_chain and peptide group
10782        double precision pep_side(3),long,side_calf(3),
10783      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10784      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10785 C the line belowe needs to be changed for FGPROC>1
10786       do i=1,nres-1
10787       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10788       ishield_list(i)=0
10789 Cif there two consequtive dummy atoms there is no peptide group between them
10790 C the line below has to be changed for FGPROC>1
10791       VolumeTotal=0.0
10792       do k=1,nres
10793        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10794        dist_pep_side=0.0
10795        dist_side_calf=0.0
10796        do j=1,3
10797 C first lets set vector conecting the ithe side-chain with kth side-chain
10798       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10799 C      pep_side(j)=2.0d0
10800 C and vector conecting the side-chain with its proper calfa
10801       side_calf(j)=c(j,k+nres)-c(j,k)
10802 C      side_calf(j)=2.0d0
10803       pept_group(j)=c(j,i)-c(j,i+1)
10804 C lets have their lenght
10805       dist_pep_side=pep_side(j)**2+dist_pep_side
10806       dist_side_calf=dist_side_calf+side_calf(j)**2
10807       dist_pept_group=dist_pept_group+pept_group(j)**2
10808       enddo
10809        dist_pep_side=dsqrt(dist_pep_side)
10810        dist_pept_group=dsqrt(dist_pept_group)
10811        dist_side_calf=dsqrt(dist_side_calf)
10812       do j=1,3
10813         pep_side_norm(j)=pep_side(j)/dist_pep_side
10814         side_calf_norm(j)=dist_side_calf
10815       enddo
10816 C now sscale fraction
10817        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10818 C       print *,buff_shield,"buff"
10819 C now sscale
10820         if (sh_frac_dist.le.0.0) cycle
10821 C If we reach here it means that this side chain reaches the shielding sphere
10822 C Lets add him to the list for gradient
10823         ishield_list(i)=ishield_list(i)+1
10824 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10825 C this list is essential otherwise problem would be O3
10826         shield_list(ishield_list(i),i)=k
10827 C Lets have the sscale value
10828         if (sh_frac_dist.gt.1.0) then
10829          scale_fac_dist=1.0d0
10830          do j=1,3
10831          sh_frac_dist_grad(j)=0.0d0
10832          enddo
10833         else
10834          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10835      &                   *(2.0d0*sh_frac_dist-3.0d0)
10836          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10837      &                  /dist_pep_side/buff_shield*0.5d0
10838 C remember for the final gradient multiply sh_frac_dist_grad(j)
10839 C for side_chain by factor -2 !
10840          do j=1,3
10841          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10842 C         sh_frac_dist_grad(j)=0.0d0
10843 C         scale_fac_dist=1.0d0
10844 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10845 C     &                    sh_frac_dist_grad(j)
10846          enddo
10847         endif
10848 C this is what is now we have the distance scaling now volume...
10849       short=short_r_sidechain(itype(k))
10850       long=long_r_sidechain(itype(k))
10851       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10852       sinthet=short/dist_pep_side*costhet
10853 C now costhet_grad
10854 C       costhet=0.6d0
10855 C       sinthet=0.8
10856        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10857 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10858 C     &             -short/dist_pep_side**2/costhet)
10859 C       costhet_fac=0.0d0
10860        do j=1,3
10861          costhet_grad(j)=costhet_fac*pep_side(j)
10862        enddo
10863 C remember for the final gradient multiply costhet_grad(j)
10864 C for side_chain by factor -2 !
10865 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10866 C pep_side0pept_group is vector multiplication
10867       pep_side0pept_group=0.0d0
10868       do j=1,3
10869       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10870       enddo
10871       cosalfa=(pep_side0pept_group/
10872      & (dist_pep_side*dist_side_calf))
10873       fac_alfa_sin=1.0d0-cosalfa**2
10874       fac_alfa_sin=dsqrt(fac_alfa_sin)
10875       rkprim=fac_alfa_sin*(long-short)+short
10876 C      rkprim=short
10877
10878 C now costhet_grad
10879        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10880 C       cosphi=0.6
10881        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10882        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10883      &      dist_pep_side**2)
10884 C       sinphi=0.8
10885        do j=1,3
10886          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10887      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10888      &*(long-short)/fac_alfa_sin*cosalfa/
10889      &((dist_pep_side*dist_side_calf))*
10890      &((side_calf(j))-cosalfa*
10891      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10892 C       cosphi_grad_long(j)=0.0d0
10893         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10894      &*(long-short)/fac_alfa_sin*cosalfa
10895      &/((dist_pep_side*dist_side_calf))*
10896      &(pep_side(j)-
10897      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10898 C       cosphi_grad_loc(j)=0.0d0
10899        enddo
10900 C      print *,sinphi,sinthet
10901       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10902      &                    /VSolvSphere_div
10903 C     &                    *wshield
10904 C now the gradient...
10905       do j=1,3
10906       grad_shield(j,i)=grad_shield(j,i)
10907 C gradient po skalowaniu
10908      &                +(sh_frac_dist_grad(j)*VofOverlap
10909 C  gradient po costhet
10910      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10911      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10912      &       sinphi/sinthet*costhet*costhet_grad(j)
10913      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10914      & )*wshield
10915 C grad_shield_side is Cbeta sidechain gradient
10916       grad_shield_side(j,ishield_list(i),i)=
10917      &        (sh_frac_dist_grad(j)*-2.0d0
10918      &        *VofOverlap
10919      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10920      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10921      &       sinphi/sinthet*costhet*costhet_grad(j)
10922      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10923      &       )*wshield
10924
10925        grad_shield_loc(j,ishield_list(i),i)=
10926      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10927      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10928      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10929      &        ))
10930      &        *wshield
10931       enddo
10932       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10933       enddo
10934       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10935 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10936 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10937       enddo
10938       return
10939       end
10940 C--------------------------------------------------------------------------
10941       double precision function tschebyshev(m,n,x,y)
10942       implicit none
10943       include "DIMENSIONS"
10944       integer i,m,n
10945       double precision x(n),y,yy(0:maxvar),aux
10946 c Tschebyshev polynomial. Note that the first term is omitted
10947 c m=0: the constant term is included
10948 c m=1: the constant term is not included
10949       yy(0)=1.0d0
10950       yy(1)=y
10951       do i=2,n
10952         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10953       enddo
10954       aux=0.0d0
10955       do i=m,n
10956         aux=aux+x(i)*yy(i)
10957       enddo
10958       tschebyshev=aux
10959       return
10960       end
10961 C--------------------------------------------------------------------------
10962       double precision function gradtschebyshev(m,n,x,y)
10963       implicit none
10964       include "DIMENSIONS"
10965       integer i,m,n
10966       double precision x(n+1),y,yy(0:maxvar),aux
10967 c Tschebyshev polynomial. Note that the first term is omitted
10968 c m=0: the constant term is included
10969 c m=1: the constant term is not included
10970       yy(0)=1.0d0
10971       yy(1)=2.0d0*y
10972       do i=2,n
10973         yy(i)=2*y*yy(i-1)-yy(i-2)
10974       enddo
10975       aux=0.0d0
10976       do i=m,n
10977         aux=aux+x(i+1)*yy(i)*(i+1)
10978 C        print *, x(i+1),yy(i),i
10979       enddo
10980       gradtschebyshev=aux
10981       return
10982       end
10983