source/maxlik/src_MD_T_maxlik-NEWCORR-PMF-PDB/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=0,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         ebend_temp_kcc(0,iabs(iti))=
7532      &      ebend_temp_kcc(0,iabs(iti))+1.0d0
7533         do j=1,nbend_kcc_Tb(iti)
7534           thybt1(j)=v1bend_chyb(j,iti)
7535           ebend_temp_kcc(j,iabs(iti))=
7536      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7537         enddo
7538         sumth1thyb=v1bend_chyb(0,iti)+
7539      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7540         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7541      &    sumth1thyb
7542         ihelp=nbend_kcc_Tb(iti)-1
7543         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7544         etheta=etheta+sumth1thyb
7545 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7546         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7547       enddo
7548       return
7549       end
7550 c-------------------------------------------------------------------------------------
7551       subroutine etheta_constr(ethetacnstr)
7552
7553       implicit real*8 (a-h,o-z)
7554       include 'DIMENSIONS'
7555       include 'DIMENSIONS.ZSCOPT'
7556       include 'COMMON.VAR'
7557       include 'COMMON.GEO'
7558       include 'COMMON.LOCAL'
7559       include 'COMMON.TORSION'
7560       include 'COMMON.INTERACT'
7561       include 'COMMON.DERIV'
7562       include 'COMMON.CHAIN'
7563       include 'COMMON.NAMES'
7564       include 'COMMON.IOUNITS'
7565       include 'COMMON.FFIELD'
7566       include 'COMMON.TORCNSTR'
7567       include 'COMMON.CONTROL'
7568       ethetacnstr=0.0d0
7569 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7570       do i=ithetaconstr_start,ithetaconstr_end
7571         itheta=itheta_constr(i)
7572         thetiii=theta(itheta)
7573         difi=pinorm(thetiii-theta_constr0(i))
7574         if (difi.gt.theta_drange(i)) then
7575           difi=difi-theta_drange(i)
7576           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7577           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7578      &    +for_thet_constr(i)*difi**3
7579         else if (difi.lt.-drange(i)) then
7580           difi=difi+drange(i)
7581           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7582           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7583      &    +for_thet_constr(i)*difi**3
7584         else
7585           difi=0.0
7586         endif
7587        if (energy_dec) then
7588         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7589      &    i,itheta,rad2deg*thetiii,
7590      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7591      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7592      &    gloc(itheta+nphi-2,icg)
7593         endif
7594       enddo
7595       return
7596       end
7597 c------------------------------------------------------------------------------
7598       subroutine eback_sc_corr(esccor)
7599 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7600 c        conformational states; temporarily implemented as differences
7601 c        between UNRES torsional potentials (dependent on three types of
7602 c        residues) and the torsional potentials dependent on all 20 types
7603 c        of residues computed from AM1 energy surfaces of terminally-blocked
7604 c        amino-acid residues.
7605       implicit real*8 (a-h,o-z)
7606       include 'DIMENSIONS'
7607       include 'DIMENSIONS.ZSCOPT'
7608       include 'COMMON.VAR'
7609       include 'COMMON.GEO'
7610       include 'COMMON.LOCAL'
7611       include 'COMMON.TORSION'
7612       include 'COMMON.SCCOR'
7613       include 'COMMON.INTERACT'
7614       include 'COMMON.DERIV'
7615       include 'COMMON.CHAIN'
7616       include 'COMMON.NAMES'
7617       include 'COMMON.IOUNITS'
7618       include 'COMMON.FFIELD'
7619       include 'COMMON.CONTROL'
7620       logical lprn
7621 C Set lprn=.true. for debugging
7622       lprn=.false.
7623 c      lprn=.true.
7624 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7625       esccor=0.0D0
7626       do i=itau_start,itau_end
7627         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7628         esccor_ii=0.0D0
7629         isccori=isccortyp(itype(i-2))
7630         isccori1=isccortyp(itype(i-1))
7631         phii=phi(i)
7632         do intertyp=1,3 !intertyp
7633 cc Added 09 May 2012 (Adasko)
7634 cc  Intertyp means interaction type of backbone mainchain correlation:
7635 c   1 = SC...Ca...Ca...Ca
7636 c   2 = Ca...Ca...Ca...SC
7637 c   3 = SC...Ca...Ca...SCi
7638         gloci=0.0D0
7639         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7640      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7641      &      (itype(i-1).eq.ntyp1)))
7642      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7643      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7644      &     .or.(itype(i).eq.ntyp1)))
7645      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7646      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7647      &      (itype(i-3).eq.ntyp1)))) cycle
7648         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7649         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7650      & cycle
7651        do j=1,nterm_sccor(isccori,isccori1)
7652           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7653           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7654           cosphi=dcos(j*tauangle(intertyp,i))
7655           sinphi=dsin(j*tauangle(intertyp,i))
7656            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7657            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7658          enddo
7659 C      write (iout,*)"EBACK_SC_COR",esccor,i
7660 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7661 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7662 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7663         if (lprn)
7664      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7665      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7666      &  (v1sccor(j,1,itori,itori1),j=1,6)
7667      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7668 c        gsccor_loc(i-3)=gloci
7669        enddo !intertyp
7670       enddo
7671       return
7672       end
7673 c------------------------------------------------------------------------------
7674       subroutine multibody(ecorr)
7675 C This subroutine calculates multi-body contributions to energy following
7676 C the idea of Skolnick et al. If side chains I and J make a contact and
7677 C at the same time side chains I+1 and J+1 make a contact, an extra
7678 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'DIMENSIONS.ZSCOPT'
7682       include 'COMMON.IOUNITS'
7683       include 'COMMON.DERIV'
7684       include 'COMMON.INTERACT'
7685       include 'COMMON.CONTACTS'
7686       double precision gx(3),gx1(3)
7687       logical lprn
7688
7689 C Set lprn=.true. for debugging
7690       lprn=.false.
7691
7692       if (lprn) then
7693         write (iout,'(a)') 'Contact function values:'
7694         do i=nnt,nct-2
7695           write (iout,'(i2,20(1x,i2,f10.5))')
7696      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7697         enddo
7698       endif
7699       ecorr=0.0D0
7700       do i=nnt,nct
7701         do j=1,3
7702           gradcorr(j,i)=0.0D0
7703           gradxorr(j,i)=0.0D0
7704         enddo
7705       enddo
7706       do i=nnt,nct-2
7707
7708         DO ISHIFT = 3,4
7709
7710         i1=i+ishift
7711         num_conti=num_cont(i)
7712         num_conti1=num_cont(i1)
7713         do jj=1,num_conti
7714           j=jcont(jj,i)
7715           do kk=1,num_conti1
7716             j1=jcont(kk,i1)
7717             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7718 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7719 cd   &                   ' ishift=',ishift
7720 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7721 C The system gains extra energy.
7722               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7723             endif   ! j1==j+-ishift
7724           enddo     ! kk
7725         enddo       ! jj
7726
7727         ENDDO ! ISHIFT
7728
7729       enddo         ! i
7730       return
7731       end
7732 c------------------------------------------------------------------------------
7733       double precision function esccorr(i,j,k,l,jj,kk)
7734       implicit real*8 (a-h,o-z)
7735       include 'DIMENSIONS'
7736       include 'DIMENSIONS.ZSCOPT'
7737       include 'COMMON.IOUNITS'
7738       include 'COMMON.DERIV'
7739       include 'COMMON.INTERACT'
7740       include 'COMMON.CONTACTS'
7741       double precision gx(3),gx1(3)
7742       logical lprn
7743       lprn=.false.
7744       eij=facont(jj,i)
7745       ekl=facont(kk,k)
7746 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7747 C Calculate the multi-body contribution to energy.
7748 C Calculate multi-body contributions to the gradient.
7749 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7750 cd   & k,l,(gacont(m,kk,k),m=1,3)
7751       do m=1,3
7752         gx(m) =ekl*gacont(m,jj,i)
7753         gx1(m)=eij*gacont(m,kk,k)
7754         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7755         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7756         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7757         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7758       enddo
7759       do m=i,j-1
7760         do ll=1,3
7761           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7762         enddo
7763       enddo
7764       do m=k,l-1
7765         do ll=1,3
7766           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7767         enddo
7768       enddo
7769       esccorr=-eij*ekl
7770       return
7771       end
7772 c------------------------------------------------------------------------------
7773       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7774 C This subroutine calculates multi-body contributions to hydrogen-bonding
7775       implicit real*8 (a-h,o-z)
7776       include 'DIMENSIONS'
7777       include 'DIMENSIONS.ZSCOPT'
7778       include 'COMMON.IOUNITS'
7779       include 'COMMON.FFIELD'
7780       include 'COMMON.DERIV'
7781       include 'COMMON.INTERACT'
7782       include 'COMMON.CONTACTS'
7783       double precision gx(3),gx1(3)
7784       logical lprn,ldone
7785
7786 C Set lprn=.true. for debugging
7787       lprn=.false.
7788       if (lprn) then
7789         write (iout,'(a)') 'Contact function values:'
7790         do i=nnt,nct-2
7791           write (iout,'(2i3,50(1x,i2,f5.2))')
7792      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7793      &    j=1,num_cont_hb(i))
7794         enddo
7795       endif
7796       ecorr=0.0D0
7797 C Remove the loop below after debugging !!!
7798       do i=nnt,nct
7799         do j=1,3
7800           gradcorr(j,i)=0.0D0
7801           gradxorr(j,i)=0.0D0
7802         enddo
7803       enddo
7804 C Calculate the local-electrostatic correlation terms
7805       do i=iatel_s,iatel_e+1
7806         i1=i+1
7807         num_conti=num_cont_hb(i)
7808         num_conti1=num_cont_hb(i+1)
7809         do jj=1,num_conti
7810           j=jcont_hb(jj,i)
7811           do kk=1,num_conti1
7812             j1=jcont_hb(kk,i1)
7813 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7814 c     &         ' jj=',jj,' kk=',kk
7815             if (j1.eq.j+1 .or. j1.eq.j-1) then
7816 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7817 C The system gains extra energy.
7818               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7819               n_corr=n_corr+1
7820             else if (j1.eq.j) then
7821 C Contacts I-J and I-(J+1) occur simultaneously.
7822 C The system loses extra energy.
7823 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7824             endif
7825           enddo ! kk
7826           do kk=1,num_conti
7827             j1=jcont_hb(kk,i)
7828 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7829 c    &         ' jj=',jj,' kk=',kk
7830             if (j1.eq.j+1) then
7831 C Contacts I-J and (I+1)-J occur simultaneously.
7832 C The system loses extra energy.
7833 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7834             endif ! j1==j+1
7835           enddo ! kk
7836         enddo ! jj
7837       enddo ! i
7838       return
7839       end
7840 c------------------------------------------------------------------------------
7841       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7842      &  n_corr1)
7843 C This subroutine calculates multi-body contributions to hydrogen-bonding
7844       implicit real*8 (a-h,o-z)
7845       include 'DIMENSIONS'
7846       include 'DIMENSIONS.ZSCOPT'
7847       include 'COMMON.IOUNITS'
7848 #ifdef MPI
7849       include "mpif.h"
7850 #endif
7851       include 'COMMON.FFIELD'
7852       include 'COMMON.DERIV'
7853       include 'COMMON.LOCAL'
7854       include 'COMMON.INTERACT'
7855       include 'COMMON.CONTACTS'
7856       include 'COMMON.CHAIN'
7857       include 'COMMON.CONTROL'
7858       include 'COMMON.SHIELD'
7859       double precision gx(3),gx1(3)
7860       integer num_cont_hb_old(maxres)
7861       logical lprn,ldone
7862       double precision eello4,eello5,eelo6,eello_turn6
7863       external eello4,eello5,eello6,eello_turn6
7864 C Set lprn=.true. for debugging
7865       lprn=.false.
7866       eturn6=0.0d0
7867       if (lprn) then
7868         write (iout,'(a)') 'Contact function values:'
7869         do i=nnt,nct-2
7870           write (iout,'(2i3,50(1x,i2,5f6.3))')
7871      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7872      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7873         enddo
7874       endif
7875       ecorr=0.0D0
7876       ecorr5=0.0d0
7877       ecorr6=0.0d0
7878 C Remove the loop below after debugging !!!
7879       do i=nnt,nct
7880         do j=1,3
7881           gradcorr(j,i)=0.0D0
7882           gradxorr(j,i)=0.0D0
7883         enddo
7884       enddo
7885 C Calculate the dipole-dipole interaction energies
7886       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7887       do i=iatel_s,iatel_e+1
7888         num_conti=num_cont_hb(i)
7889         do jj=1,num_conti
7890           j=jcont_hb(jj,i)
7891 #ifdef MOMENT
7892           call dipole(i,j,jj)
7893 #endif
7894         enddo
7895       enddo
7896       endif
7897 C Calculate the local-electrostatic correlation terms
7898 c                write (iout,*) "gradcorr5 in eello5 before loop"
7899 c                do iii=1,nres
7900 c                  write (iout,'(i5,3f10.5)')
7901 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7902 c                enddo
7903       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7904 c        write (iout,*) "corr loop i",i
7905         i1=i+1
7906         num_conti=num_cont_hb(i)
7907         num_conti1=num_cont_hb(i+1)
7908         do jj=1,num_conti
7909           j=jcont_hb(jj,i)
7910           jp=iabs(j)
7911           do kk=1,num_conti1
7912             j1=jcont_hb(kk,i1)
7913             jp1=iabs(j1)
7914 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7915 c     &         ' jj=',jj,' kk=',kk
7916 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7917             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7918      &          .or. j.lt.0 .and. j1.gt.0) .and.
7919      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7920 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7921 C The system gains extra energy.
7922               n_corr=n_corr+1
7923               sqd1=dsqrt(d_cont(jj,i))
7924               sqd2=dsqrt(d_cont(kk,i1))
7925               sred_geom = sqd1*sqd2
7926               IF (sred_geom.lt.cutoff_corr) THEN
7927                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7928      &            ekont,fprimcont)
7929 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7930 cd     &         ' jj=',jj,' kk=',kk
7931                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7932                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7933                 do l=1,3
7934                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7935                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7936                 enddo
7937                 n_corr1=n_corr1+1
7938 cd               write (iout,*) 'sred_geom=',sred_geom,
7939 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7940 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7941 cd               write (iout,*) "g_contij",g_contij
7942 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7943 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7944                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7945                 if (wcorr4.gt.0.0d0)
7946      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7947 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7948                   if (energy_dec.and.wcorr4.gt.0.0d0)
7949      1                 write (iout,'(a6,4i5,0pf7.3)')
7950      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7951 c                write (iout,*) "gradcorr5 before eello5"
7952 c                do iii=1,nres
7953 c                  write (iout,'(i5,3f10.5)')
7954 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7955 c                enddo
7956                 if (wcorr5.gt.0.0d0)
7957      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7958 c                write (iout,*) "gradcorr5 after eello5"
7959 c                do iii=1,nres
7960 c                  write (iout,'(i5,3f10.5)')
7961 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7962 c                enddo
7963                   if (energy_dec.and.wcorr5.gt.0.0d0)
7964      1                 write (iout,'(a6,4i5,0pf7.3)')
7965      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7966 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7967 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7968                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7969      &               .or. wturn6.eq.0.0d0))then
7970 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7971                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7972                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7973      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7974 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7975 cd     &            'ecorr6=',ecorr6
7976 cd                write (iout,'(4e15.5)') sred_geom,
7977 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7978 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7979 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7980                 else if (wturn6.gt.0.0d0
7981      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7982 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7983                   eturn6=eturn6+eello_turn6(i,jj,kk)
7984                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7985      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7986 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7987                 endif
7988               ENDIF
7989 1111          continue
7990             endif
7991           enddo ! kk
7992         enddo ! jj
7993       enddo ! i
7994       do i=1,nres
7995         num_cont_hb(i)=num_cont_hb_old(i)
7996       enddo
7997 c                write (iout,*) "gradcorr5 in eello5"
7998 c                do iii=1,nres
7999 c                  write (iout,'(i5,3f10.5)')
8000 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8001 c                enddo
8002       return
8003       end
8004 c------------------------------------------------------------------------------
8005       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8006       implicit real*8 (a-h,o-z)
8007       include 'DIMENSIONS'
8008       include 'DIMENSIONS.ZSCOPT'
8009       include 'COMMON.IOUNITS'
8010       include 'COMMON.DERIV'
8011       include 'COMMON.INTERACT'
8012       include 'COMMON.CONTACTS'
8013       include 'COMMON.SHIELD'
8014       include 'COMMON.CONTROL'
8015       double precision gx(3),gx1(3)
8016       logical lprn
8017       lprn=.false.
8018 C      print *,"wchodze",fac_shield(i),shield_mode
8019       eij=facont_hb(jj,i)
8020       ekl=facont_hb(kk,k)
8021       ees0pij=ees0p(jj,i)
8022       ees0pkl=ees0p(kk,k)
8023       ees0mij=ees0m(jj,i)
8024       ees0mkl=ees0m(kk,k)
8025       ekont=eij*ekl
8026       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8027 C*
8028 C     & fac_shield(i)**2*fac_shield(j)**2
8029 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8030 C Following 4 lines for diagnostics.
8031 cd    ees0pkl=0.0D0
8032 cd    ees0pij=1.0D0
8033 cd    ees0mkl=0.0D0
8034 cd    ees0mij=1.0D0
8035 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8036 c     & 'Contacts ',i,j,
8037 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8038 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8039 c     & 'gradcorr_long'
8040 C Calculate the multi-body contribution to energy.
8041 C      ecorr=ecorr+ekont*ees
8042 C Calculate multi-body contributions to the gradient.
8043       coeffpees0pij=coeffp*ees0pij
8044       coeffmees0mij=coeffm*ees0mij
8045       coeffpees0pkl=coeffp*ees0pkl
8046       coeffmees0mkl=coeffm*ees0mkl
8047       do ll=1,3
8048 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8049         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8050      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8051      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8052         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8053      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8054      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8055 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8056         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8057      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8058      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8059         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8060      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8061      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8062         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8063      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8064      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8065         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8066         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8067         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8068      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8069      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8070         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8071         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8072 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8073       enddo
8074 c      write (iout,*)
8075 cgrad      do m=i+1,j-1
8076 cgrad        do ll=1,3
8077 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8078 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8079 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8080 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8081 cgrad        enddo
8082 cgrad      enddo
8083 cgrad      do m=k+1,l-1
8084 cgrad        do ll=1,3
8085 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8086 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8087 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8088 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8089 cgrad        enddo
8090 cgrad      enddo
8091 c      write (iout,*) "ehbcorr",ekont*ees
8092 C      print *,ekont,ees,i,k
8093       ehbcorr=ekont*ees
8094 C now gradient over shielding
8095 C      return
8096       if (shield_mode.gt.0) then
8097        j=ees0plist(jj,i)
8098        l=ees0plist(kk,k)
8099 C        print *,i,j,fac_shield(i),fac_shield(j),
8100 C     &fac_shield(k),fac_shield(l)
8101         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8102      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8103           do ilist=1,ishield_list(i)
8104            iresshield=shield_list(ilist,i)
8105            do m=1,3
8106            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8107 C     &      *2.0
8108            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8109      &              rlocshield
8110      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8111             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8112      &+rlocshield
8113            enddo
8114           enddo
8115           do ilist=1,ishield_list(j)
8116            iresshield=shield_list(ilist,j)
8117            do m=1,3
8118            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8119 C     &     *2.0
8120            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8121      &              rlocshield
8122      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8123            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8124      &     +rlocshield
8125            enddo
8126           enddo
8127
8128           do ilist=1,ishield_list(k)
8129            iresshield=shield_list(ilist,k)
8130            do m=1,3
8131            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8132 C     &     *2.0
8133            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8134      &              rlocshield
8135      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8136            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8137      &     +rlocshield
8138            enddo
8139           enddo
8140           do ilist=1,ishield_list(l)
8141            iresshield=shield_list(ilist,l)
8142            do m=1,3
8143            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8144 C     &     *2.0
8145            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8146      &              rlocshield
8147      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8148            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8149      &     +rlocshield
8150            enddo
8151           enddo
8152 C          print *,gshieldx(m,iresshield)
8153           do m=1,3
8154             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8155      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8156             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8157      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8158             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8159      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8160             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8161      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8162
8163             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8164      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8165             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8166      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8167             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8168      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8169             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8170      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8171
8172            enddo
8173       endif
8174       endif
8175       return
8176       end
8177 #ifdef MOMENT
8178 C---------------------------------------------------------------------------
8179       subroutine dipole(i,j,jj)
8180       implicit real*8 (a-h,o-z)
8181       include 'DIMENSIONS'
8182       include 'DIMENSIONS.ZSCOPT'
8183       include 'COMMON.IOUNITS'
8184       include 'COMMON.CHAIN'
8185       include 'COMMON.FFIELD'
8186       include 'COMMON.DERIV'
8187       include 'COMMON.INTERACT'
8188       include 'COMMON.CONTACTS'
8189       include 'COMMON.TORSION'
8190       include 'COMMON.VAR'
8191       include 'COMMON.GEO'
8192       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8193      &  auxmat(2,2)
8194       iti1 = itortyp(itype(i+1))
8195       if (j.lt.nres-1) then
8196         itj1 = itype2loc(itype(j+1))
8197       else
8198         itj1=nloctyp
8199       endif
8200       do iii=1,2
8201         dipi(iii,1)=Ub2(iii,i)
8202         dipderi(iii)=Ub2der(iii,i)
8203         dipi(iii,2)=b1(iii,i+1)
8204         dipj(iii,1)=Ub2(iii,j)
8205         dipderj(iii)=Ub2der(iii,j)
8206         dipj(iii,2)=b1(iii,j+1)
8207       enddo
8208       kkk=0
8209       do iii=1,2
8210         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8211         do jjj=1,2
8212           kkk=kkk+1
8213           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8214         enddo
8215       enddo
8216       do kkk=1,5
8217         do lll=1,3
8218           mmm=0
8219           do iii=1,2
8220             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8221      &        auxvec(1))
8222             do jjj=1,2
8223               mmm=mmm+1
8224               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8225             enddo
8226           enddo
8227         enddo
8228       enddo
8229       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8230       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8231       do iii=1,2
8232         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8233       enddo
8234       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8235       do iii=1,2
8236         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8237       enddo
8238       return
8239       end
8240 #endif
8241 C---------------------------------------------------------------------------
8242       subroutine calc_eello(i,j,k,l,jj,kk)
8243 C
8244 C This subroutine computes matrices and vectors needed to calculate
8245 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8246 C
8247       implicit real*8 (a-h,o-z)
8248       include 'DIMENSIONS'
8249       include 'DIMENSIONS.ZSCOPT'
8250       include 'COMMON.IOUNITS'
8251       include 'COMMON.CHAIN'
8252       include 'COMMON.DERIV'
8253       include 'COMMON.INTERACT'
8254       include 'COMMON.CONTACTS'
8255       include 'COMMON.TORSION'
8256       include 'COMMON.VAR'
8257       include 'COMMON.GEO'
8258       include 'COMMON.FFIELD'
8259       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8260      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8261       logical lprn
8262       common /kutas/ lprn
8263 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8264 cd     & ' jj=',jj,' kk=',kk
8265 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8266 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8267 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8268       do iii=1,2
8269         do jjj=1,2
8270           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8271           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8272         enddo
8273       enddo
8274       call transpose2(aa1(1,1),aa1t(1,1))
8275       call transpose2(aa2(1,1),aa2t(1,1))
8276       do kkk=1,5
8277         do lll=1,3
8278           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8279      &      aa1tder(1,1,lll,kkk))
8280           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8281      &      aa2tder(1,1,lll,kkk))
8282         enddo
8283       enddo
8284       if (l.eq.j+1) then
8285 C parallel orientation of the two CA-CA-CA frames.
8286         if (i.gt.1) then
8287           iti=itype2loc(itype(i))
8288         else
8289           iti=nloctyp
8290         endif
8291         itk1=itype2loc(itype(k+1))
8292         itj=itype2loc(itype(j))
8293         if (l.lt.nres-1) then
8294           itl1=itype2loc(itype(l+1))
8295         else
8296           itl1=nloctyp
8297         endif
8298 C A1 kernel(j+1) A2T
8299 cd        do iii=1,2
8300 cd          write (iout,'(3f10.5,5x,3f10.5)')
8301 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8302 cd        enddo
8303         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8304      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8305      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8306 C Following matrices are needed only for 6-th order cumulants
8307         IF (wcorr6.gt.0.0d0) THEN
8308         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8309      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8310      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8311         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8312      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8313      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8314      &   ADtEAderx(1,1,1,1,1,1))
8315         lprn=.false.
8316         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8317      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8318      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8319      &   ADtEA1derx(1,1,1,1,1,1))
8320         ENDIF
8321 C End 6-th order cumulants
8322 cd        lprn=.false.
8323 cd        if (lprn) then
8324 cd        write (2,*) 'In calc_eello6'
8325 cd        do iii=1,2
8326 cd          write (2,*) 'iii=',iii
8327 cd          do kkk=1,5
8328 cd            write (2,*) 'kkk=',kkk
8329 cd            do jjj=1,2
8330 cd              write (2,'(3(2f10.5),5x)')
8331 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8332 cd            enddo
8333 cd          enddo
8334 cd        enddo
8335 cd        endif
8336         call transpose2(EUgder(1,1,k),auxmat(1,1))
8337         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8338         call transpose2(EUg(1,1,k),auxmat(1,1))
8339         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8340         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8341         do iii=1,2
8342           do kkk=1,5
8343             do lll=1,3
8344               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8345      &          EAEAderx(1,1,lll,kkk,iii,1))
8346             enddo
8347           enddo
8348         enddo
8349 C A1T kernel(i+1) A2
8350         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8351      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8352      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8353 C Following matrices are needed only for 6-th order cumulants
8354         IF (wcorr6.gt.0.0d0) THEN
8355         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8356      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8357      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8358         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8359      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8360      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8361      &   ADtEAderx(1,1,1,1,1,2))
8362         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8363      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8364      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8365      &   ADtEA1derx(1,1,1,1,1,2))
8366         ENDIF
8367 C End 6-th order cumulants
8368         call transpose2(EUgder(1,1,l),auxmat(1,1))
8369         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8370         call transpose2(EUg(1,1,l),auxmat(1,1))
8371         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8372         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8373         do iii=1,2
8374           do kkk=1,5
8375             do lll=1,3
8376               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8377      &          EAEAderx(1,1,lll,kkk,iii,2))
8378             enddo
8379           enddo
8380         enddo
8381 C AEAb1 and AEAb2
8382 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8383 C They are needed only when the fifth- or the sixth-order cumulants are
8384 C indluded.
8385         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8386         call transpose2(AEA(1,1,1),auxmat(1,1))
8387         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8388         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8389         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8390         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8391         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8392         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8393         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8394         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8395         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8396         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8397         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8398         call transpose2(AEA(1,1,2),auxmat(1,1))
8399         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8400         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8401         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8402         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8403         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8404         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8405         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8406         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8407         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8408         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8409         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8410 C Calculate the Cartesian derivatives of the vectors.
8411         do iii=1,2
8412           do kkk=1,5
8413             do lll=1,3
8414               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8415               call matvec2(auxmat(1,1),b1(1,i),
8416      &          AEAb1derx(1,lll,kkk,iii,1,1))
8417               call matvec2(auxmat(1,1),Ub2(1,i),
8418      &          AEAb2derx(1,lll,kkk,iii,1,1))
8419               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8420      &          AEAb1derx(1,lll,kkk,iii,2,1))
8421               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8422      &          AEAb2derx(1,lll,kkk,iii,2,1))
8423               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8424               call matvec2(auxmat(1,1),b1(1,j),
8425      &          AEAb1derx(1,lll,kkk,iii,1,2))
8426               call matvec2(auxmat(1,1),Ub2(1,j),
8427      &          AEAb2derx(1,lll,kkk,iii,1,2))
8428               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8429      &          AEAb1derx(1,lll,kkk,iii,2,2))
8430               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8431      &          AEAb2derx(1,lll,kkk,iii,2,2))
8432             enddo
8433           enddo
8434         enddo
8435         ENDIF
8436 C End vectors
8437       else
8438 C Antiparallel orientation of the two CA-CA-CA frames.
8439         if (i.gt.1) then
8440           iti=itype2loc(itype(i))
8441         else
8442           iti=nloctyp
8443         endif
8444         itk1=itype2loc(itype(k+1))
8445         itl=itype2loc(itype(l))
8446         itj=itype2loc(itype(j))
8447         if (j.lt.nres-1) then
8448           itj1=itype2loc(itype(j+1))
8449         else
8450           itj1=nloctyp
8451         endif
8452 C A2 kernel(j-1)T A1T
8453         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8454      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8455      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8456 C Following matrices are needed only for 6-th order cumulants
8457         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8458      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8459         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8460      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8461      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8462         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8463      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8464      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8465      &   ADtEAderx(1,1,1,1,1,1))
8466         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8467      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8468      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8469      &   ADtEA1derx(1,1,1,1,1,1))
8470         ENDIF
8471 C End 6-th order cumulants
8472         call transpose2(EUgder(1,1,k),auxmat(1,1))
8473         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8474         call transpose2(EUg(1,1,k),auxmat(1,1))
8475         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8476         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8477         do iii=1,2
8478           do kkk=1,5
8479             do lll=1,3
8480               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8481      &          EAEAderx(1,1,lll,kkk,iii,1))
8482             enddo
8483           enddo
8484         enddo
8485 C A2T kernel(i+1)T A1
8486         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8487      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8488      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8489 C Following matrices are needed only for 6-th order cumulants
8490         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8491      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8492         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8493      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8494      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8495         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8496      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8497      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8498      &   ADtEAderx(1,1,1,1,1,2))
8499         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8500      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8501      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8502      &   ADtEA1derx(1,1,1,1,1,2))
8503         ENDIF
8504 C End 6-th order cumulants
8505         call transpose2(EUgder(1,1,j),auxmat(1,1))
8506         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8507         call transpose2(EUg(1,1,j),auxmat(1,1))
8508         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8509         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8510         do iii=1,2
8511           do kkk=1,5
8512             do lll=1,3
8513               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8514      &          EAEAderx(1,1,lll,kkk,iii,2))
8515             enddo
8516           enddo
8517         enddo
8518 C AEAb1 and AEAb2
8519 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8520 C They are needed only when the fifth- or the sixth-order cumulants are
8521 C indluded.
8522         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8523      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8524         call transpose2(AEA(1,1,1),auxmat(1,1))
8525         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8526         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8527         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8528         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8529         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8530         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8531         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8532         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8533         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8534         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8535         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8536         call transpose2(AEA(1,1,2),auxmat(1,1))
8537         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8538         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8539         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8540         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8541         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8542         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8543         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8544         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8545         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8546         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8547         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8548 C Calculate the Cartesian derivatives of the vectors.
8549         do iii=1,2
8550           do kkk=1,5
8551             do lll=1,3
8552               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8553               call matvec2(auxmat(1,1),b1(1,i),
8554      &          AEAb1derx(1,lll,kkk,iii,1,1))
8555               call matvec2(auxmat(1,1),Ub2(1,i),
8556      &          AEAb2derx(1,lll,kkk,iii,1,1))
8557               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8558      &          AEAb1derx(1,lll,kkk,iii,2,1))
8559               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8560      &          AEAb2derx(1,lll,kkk,iii,2,1))
8561               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8562               call matvec2(auxmat(1,1),b1(1,l),
8563      &          AEAb1derx(1,lll,kkk,iii,1,2))
8564               call matvec2(auxmat(1,1),Ub2(1,l),
8565      &          AEAb2derx(1,lll,kkk,iii,1,2))
8566               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8567      &          AEAb1derx(1,lll,kkk,iii,2,2))
8568               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8569      &          AEAb2derx(1,lll,kkk,iii,2,2))
8570             enddo
8571           enddo
8572         enddo
8573         ENDIF
8574 C End vectors
8575       endif
8576       return
8577       end
8578 C---------------------------------------------------------------------------
8579       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8580      &  KK,KKderg,AKA,AKAderg,AKAderx)
8581       implicit none
8582       integer nderg
8583       logical transp
8584       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8585      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8586      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8587       integer iii,kkk,lll
8588       integer jjj,mmm
8589       logical lprn
8590       common /kutas/ lprn
8591       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8592       do iii=1,nderg
8593         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8594      &    AKAderg(1,1,iii))
8595       enddo
8596 cd      if (lprn) write (2,*) 'In kernel'
8597       do kkk=1,5
8598 cd        if (lprn) write (2,*) 'kkk=',kkk
8599         do lll=1,3
8600           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8601      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8602 cd          if (lprn) then
8603 cd            write (2,*) 'lll=',lll
8604 cd            write (2,*) 'iii=1'
8605 cd            do jjj=1,2
8606 cd              write (2,'(3(2f10.5),5x)')
8607 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8608 cd            enddo
8609 cd          endif
8610           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8611      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8612 cd          if (lprn) then
8613 cd            write (2,*) 'lll=',lll
8614 cd            write (2,*) 'iii=2'
8615 cd            do jjj=1,2
8616 cd              write (2,'(3(2f10.5),5x)')
8617 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8618 cd            enddo
8619 cd          endif
8620         enddo
8621       enddo
8622       return
8623       end
8624 C---------------------------------------------------------------------------
8625       double precision function eello4(i,j,k,l,jj,kk)
8626       implicit real*8 (a-h,o-z)
8627       include 'DIMENSIONS'
8628       include 'DIMENSIONS.ZSCOPT'
8629       include 'COMMON.IOUNITS'
8630       include 'COMMON.CHAIN'
8631       include 'COMMON.DERIV'
8632       include 'COMMON.INTERACT'
8633       include 'COMMON.CONTACTS'
8634       include 'COMMON.TORSION'
8635       include 'COMMON.VAR'
8636       include 'COMMON.GEO'
8637       double precision pizda(2,2),ggg1(3),ggg2(3)
8638 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8639 cd        eello4=0.0d0
8640 cd        return
8641 cd      endif
8642 cd      print *,'eello4:',i,j,k,l,jj,kk
8643 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8644 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8645 cold      eij=facont_hb(jj,i)
8646 cold      ekl=facont_hb(kk,k)
8647 cold      ekont=eij*ekl
8648       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8649       if (calc_grad) then
8650 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8651       gcorr_loc(k-1)=gcorr_loc(k-1)
8652      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8653       if (l.eq.j+1) then
8654         gcorr_loc(l-1)=gcorr_loc(l-1)
8655      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8656       else
8657         gcorr_loc(j-1)=gcorr_loc(j-1)
8658      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8659       endif
8660       do iii=1,2
8661         do kkk=1,5
8662           do lll=1,3
8663             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8664      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8665 cd            derx(lll,kkk,iii)=0.0d0
8666           enddo
8667         enddo
8668       enddo
8669 cd      gcorr_loc(l-1)=0.0d0
8670 cd      gcorr_loc(j-1)=0.0d0
8671 cd      gcorr_loc(k-1)=0.0d0
8672 cd      eel4=1.0d0
8673 cd      write (iout,*)'Contacts have occurred for peptide groups',
8674 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8675 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8676       if (j.lt.nres-1) then
8677         j1=j+1
8678         j2=j-1
8679       else
8680         j1=j-1
8681         j2=j-2
8682       endif
8683       if (l.lt.nres-1) then
8684         l1=l+1
8685         l2=l-1
8686       else
8687         l1=l-1
8688         l2=l-2
8689       endif
8690       do ll=1,3
8691 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8692 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8693         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8694         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8695 cgrad        ghalf=0.5d0*ggg1(ll)
8696         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8697         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8698         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8699         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8700         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8701         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8702 cgrad        ghalf=0.5d0*ggg2(ll)
8703         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8704         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8705         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8706         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8707         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8708         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8709       enddo
8710 cgrad      do m=i+1,j-1
8711 cgrad        do ll=1,3
8712 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8713 cgrad        enddo
8714 cgrad      enddo
8715 cgrad      do m=k+1,l-1
8716 cgrad        do ll=1,3
8717 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8718 cgrad        enddo
8719 cgrad      enddo
8720 cgrad      do m=i+2,j2
8721 cgrad        do ll=1,3
8722 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8723 cgrad        enddo
8724 cgrad      enddo
8725 cgrad      do m=k+2,l2
8726 cgrad        do ll=1,3
8727 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8728 cgrad        enddo
8729 cgrad      enddo
8730 cd      do iii=1,nres-3
8731 cd        write (2,*) iii,gcorr_loc(iii)
8732 cd      enddo
8733       endif ! calc_grad
8734       eello4=ekont*eel4
8735 cd      write (2,*) 'ekont',ekont
8736 cd      write (iout,*) 'eello4',ekont*eel4
8737       return
8738       end
8739 C---------------------------------------------------------------------------
8740       double precision function eello5(i,j,k,l,jj,kk)
8741       implicit real*8 (a-h,o-z)
8742       include 'DIMENSIONS'
8743       include 'DIMENSIONS.ZSCOPT'
8744       include 'COMMON.IOUNITS'
8745       include 'COMMON.CHAIN'
8746       include 'COMMON.DERIV'
8747       include 'COMMON.INTERACT'
8748       include 'COMMON.CONTACTS'
8749       include 'COMMON.TORSION'
8750       include 'COMMON.VAR'
8751       include 'COMMON.GEO'
8752       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8753       double precision ggg1(3),ggg2(3)
8754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8755 C                                                                              C
8756 C                            Parallel chains                                   C
8757 C                                                                              C
8758 C          o             o                   o             o                   C
8759 C         /l\           / \             \   / \           / \   /              C
8760 C        /   \         /   \             \ /   \         /   \ /               C
8761 C       j| o |l1       | o |              o| o |         | o |o                C
8762 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8763 C      \i/   \         /   \ /             /   \         /   \                 C
8764 C       o    k1             o                                                  C
8765 C         (I)          (II)                (III)          (IV)                 C
8766 C                                                                              C
8767 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8768 C                                                                              C
8769 C                            Antiparallel chains                               C
8770 C                                                                              C
8771 C          o             o                   o             o                   C
8772 C         /j\           / \             \   / \           / \   /              C
8773 C        /   \         /   \             \ /   \         /   \ /               C
8774 C      j1| o |l        | o |              o| o |         | o |o                C
8775 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8776 C      \i/   \         /   \ /             /   \         /   \                 C
8777 C       o     k1            o                                                  C
8778 C         (I)          (II)                (III)          (IV)                 C
8779 C                                                                              C
8780 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8781 C                                                                              C
8782 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8783 C                                                                              C
8784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8785 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8786 cd        eello5=0.0d0
8787 cd        return
8788 cd      endif
8789 cd      write (iout,*)
8790 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8791 cd     &   ' and',k,l
8792       itk=itype2loc(itype(k))
8793       itl=itype2loc(itype(l))
8794       itj=itype2loc(itype(j))
8795       eello5_1=0.0d0
8796       eello5_2=0.0d0
8797       eello5_3=0.0d0
8798       eello5_4=0.0d0
8799 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8800 cd     &   eel5_3_num,eel5_4_num)
8801       do iii=1,2
8802         do kkk=1,5
8803           do lll=1,3
8804             derx(lll,kkk,iii)=0.0d0
8805           enddo
8806         enddo
8807       enddo
8808 cd      eij=facont_hb(jj,i)
8809 cd      ekl=facont_hb(kk,k)
8810 cd      ekont=eij*ekl
8811 cd      write (iout,*)'Contacts have occurred for peptide groups',
8812 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8813 cd      goto 1111
8814 C Contribution from the graph I.
8815 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8816 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8817       call transpose2(EUg(1,1,k),auxmat(1,1))
8818       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8819       vv(1)=pizda(1,1)-pizda(2,2)
8820       vv(2)=pizda(1,2)+pizda(2,1)
8821       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8822      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8823       if (calc_grad) then
8824 C Explicit gradient in virtual-dihedral angles.
8825       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8826      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8827      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8828       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8829       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8830       vv(1)=pizda(1,1)-pizda(2,2)
8831       vv(2)=pizda(1,2)+pizda(2,1)
8832       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8833      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8834      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8835       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8836       vv(1)=pizda(1,1)-pizda(2,2)
8837       vv(2)=pizda(1,2)+pizda(2,1)
8838       if (l.eq.j+1) then
8839         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8840      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8841      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8842       else
8843         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8844      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8845      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8846       endif
8847 C Cartesian gradient
8848       do iii=1,2
8849         do kkk=1,5
8850           do lll=1,3
8851             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8852      &        pizda(1,1))
8853             vv(1)=pizda(1,1)-pizda(2,2)
8854             vv(2)=pizda(1,2)+pizda(2,1)
8855             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8856      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8857      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8858           enddo
8859         enddo
8860       enddo
8861       endif ! calc_grad
8862 c      goto 1112
8863 c1111  continue
8864 C Contribution from graph II
8865       call transpose2(EE(1,1,k),auxmat(1,1))
8866       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8867       vv(1)=pizda(1,1)+pizda(2,2)
8868       vv(2)=pizda(2,1)-pizda(1,2)
8869       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8870      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8871       if (calc_grad) then
8872 C Explicit gradient in virtual-dihedral angles.
8873       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8874      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8875       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8876       vv(1)=pizda(1,1)+pizda(2,2)
8877       vv(2)=pizda(2,1)-pizda(1,2)
8878       if (l.eq.j+1) then
8879         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8880      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8881      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8882       else
8883         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8884      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8885      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8886       endif
8887 C Cartesian gradient
8888       do iii=1,2
8889         do kkk=1,5
8890           do lll=1,3
8891             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8892      &        pizda(1,1))
8893             vv(1)=pizda(1,1)+pizda(2,2)
8894             vv(2)=pizda(2,1)-pizda(1,2)
8895             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8896      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8897      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8898           enddo
8899         enddo
8900       enddo
8901       endif ! calc_grad
8902 cd      goto 1112
8903 cd1111  continue
8904       if (l.eq.j+1) then
8905 cd        goto 1110
8906 C Parallel orientation
8907 C Contribution from graph III
8908         call transpose2(EUg(1,1,l),auxmat(1,1))
8909         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8910         vv(1)=pizda(1,1)-pizda(2,2)
8911         vv(2)=pizda(1,2)+pizda(2,1)
8912         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8913      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8914         if (calc_grad) then
8915 C Explicit gradient in virtual-dihedral angles.
8916         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8917      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8918      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8919         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8920         vv(1)=pizda(1,1)-pizda(2,2)
8921         vv(2)=pizda(1,2)+pizda(2,1)
8922         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8923      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8924      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8925         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8926         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8927         vv(1)=pizda(1,1)-pizda(2,2)
8928         vv(2)=pizda(1,2)+pizda(2,1)
8929         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8930      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8931      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8932 C Cartesian gradient
8933         do iii=1,2
8934           do kkk=1,5
8935             do lll=1,3
8936               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8937      &          pizda(1,1))
8938               vv(1)=pizda(1,1)-pizda(2,2)
8939               vv(2)=pizda(1,2)+pizda(2,1)
8940               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8941      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8942      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8943             enddo
8944           enddo
8945         enddo
8946 cd        goto 1112
8947 C Contribution from graph IV
8948 cd1110    continue
8949         call transpose2(EE(1,1,l),auxmat(1,1))
8950         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8951         vv(1)=pizda(1,1)+pizda(2,2)
8952         vv(2)=pizda(2,1)-pizda(1,2)
8953         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8954      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8955 C Explicit gradient in virtual-dihedral angles.
8956         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8957      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8958         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8959         vv(1)=pizda(1,1)+pizda(2,2)
8960         vv(2)=pizda(2,1)-pizda(1,2)
8961         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8962      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8963      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8964 C Cartesian gradient
8965         do iii=1,2
8966           do kkk=1,5
8967             do lll=1,3
8968               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8969      &          pizda(1,1))
8970               vv(1)=pizda(1,1)+pizda(2,2)
8971               vv(2)=pizda(2,1)-pizda(1,2)
8972               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8973      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8974      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8975             enddo
8976           enddo
8977         enddo
8978         endif ! calc_grad
8979       else
8980 C Antiparallel orientation
8981 C Contribution from graph III
8982 c        goto 1110
8983         call transpose2(EUg(1,1,j),auxmat(1,1))
8984         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8985         vv(1)=pizda(1,1)-pizda(2,2)
8986         vv(2)=pizda(1,2)+pizda(2,1)
8987         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8988      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8989         if (calc_grad) then
8990 C Explicit gradient in virtual-dihedral angles.
8991         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8992      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8993      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8994         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8995         vv(1)=pizda(1,1)-pizda(2,2)
8996         vv(2)=pizda(1,2)+pizda(2,1)
8997         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8998      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8999      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9000         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9001         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9002         vv(1)=pizda(1,1)-pizda(2,2)
9003         vv(2)=pizda(1,2)+pizda(2,1)
9004         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9005      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9006      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9007 C Cartesian gradient
9008         do iii=1,2
9009           do kkk=1,5
9010             do lll=1,3
9011               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9012      &          pizda(1,1))
9013               vv(1)=pizda(1,1)-pizda(2,2)
9014               vv(2)=pizda(1,2)+pizda(2,1)
9015               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9016      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9017      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9018             enddo
9019           enddo
9020         enddo
9021         endif ! calc_grad
9022 cd        goto 1112
9023 C Contribution from graph IV
9024 1110    continue
9025         call transpose2(EE(1,1,j),auxmat(1,1))
9026         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9027         vv(1)=pizda(1,1)+pizda(2,2)
9028         vv(2)=pizda(2,1)-pizda(1,2)
9029         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9030      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9031         if (calc_grad) then
9032 C Explicit gradient in virtual-dihedral angles.
9033         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9034      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9035         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9036         vv(1)=pizda(1,1)+pizda(2,2)
9037         vv(2)=pizda(2,1)-pizda(1,2)
9038         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9039      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9040      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9041 C Cartesian gradient
9042         do iii=1,2
9043           do kkk=1,5
9044             do lll=1,3
9045               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9046      &          pizda(1,1))
9047               vv(1)=pizda(1,1)+pizda(2,2)
9048               vv(2)=pizda(2,1)-pizda(1,2)
9049               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9050      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9051      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9052             enddo
9053           enddo
9054         enddo
9055         endif ! calc_grad
9056       endif
9057 1112  continue
9058       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9059 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9060 cd        write (2,*) 'ijkl',i,j,k,l
9061 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9062 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9063 cd      endif
9064 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9065 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9066 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9067 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9068       if (calc_grad) then
9069       if (j.lt.nres-1) then
9070         j1=j+1
9071         j2=j-1
9072       else
9073         j1=j-1
9074         j2=j-2
9075       endif
9076       if (l.lt.nres-1) then
9077         l1=l+1
9078         l2=l-1
9079       else
9080         l1=l-1
9081         l2=l-2
9082       endif
9083 cd      eij=1.0d0
9084 cd      ekl=1.0d0
9085 cd      ekont=1.0d0
9086 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9087 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9088 C        summed up outside the subrouine as for the other subroutines
9089 C        handling long-range interactions. The old code is commented out
9090 C        with "cgrad" to keep track of changes.
9091       do ll=1,3
9092 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9093 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9094         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9095         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9096 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9097 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9098 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9099 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9100 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9101 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9102 c     &   gradcorr5ij,
9103 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9104 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9105 cgrad        ghalf=0.5d0*ggg1(ll)
9106 cd        ghalf=0.0d0
9107         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9108         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9109         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9110         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9111         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9112         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9113 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9114 cgrad        ghalf=0.5d0*ggg2(ll)
9115 cd        ghalf=0.0d0
9116         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9117         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9118         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9119         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9120         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9121         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9122       enddo
9123       endif ! calc_grad
9124 cd      goto 1112
9125 cgrad      do m=i+1,j-1
9126 cgrad        do ll=1,3
9127 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9128 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9129 cgrad        enddo
9130 cgrad      enddo
9131 cgrad      do m=k+1,l-1
9132 cgrad        do ll=1,3
9133 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9134 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9135 cgrad        enddo
9136 cgrad      enddo
9137 c1112  continue
9138 cgrad      do m=i+2,j2
9139 cgrad        do ll=1,3
9140 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9141 cgrad        enddo
9142 cgrad      enddo
9143 cgrad      do m=k+2,l2
9144 cgrad        do ll=1,3
9145 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9146 cgrad        enddo
9147 cgrad      enddo
9148 cd      do iii=1,nres-3
9149 cd        write (2,*) iii,g_corr5_loc(iii)
9150 cd      enddo
9151       eello5=ekont*eel5
9152 cd      write (2,*) 'ekont',ekont
9153 cd      write (iout,*) 'eello5',ekont*eel5
9154       return
9155       end
9156 c--------------------------------------------------------------------------
9157       double precision function eello6(i,j,k,l,jj,kk)
9158       implicit real*8 (a-h,o-z)
9159       include 'DIMENSIONS'
9160       include 'DIMENSIONS.ZSCOPT'
9161       include 'COMMON.IOUNITS'
9162       include 'COMMON.CHAIN'
9163       include 'COMMON.DERIV'
9164       include 'COMMON.INTERACT'
9165       include 'COMMON.CONTACTS'
9166       include 'COMMON.TORSION'
9167       include 'COMMON.VAR'
9168       include 'COMMON.GEO'
9169       include 'COMMON.FFIELD'
9170       double precision ggg1(3),ggg2(3)
9171 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9172 cd        eello6=0.0d0
9173 cd        return
9174 cd      endif
9175 cd      write (iout,*)
9176 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9177 cd     &   ' and',k,l
9178       eello6_1=0.0d0
9179       eello6_2=0.0d0
9180       eello6_3=0.0d0
9181       eello6_4=0.0d0
9182       eello6_5=0.0d0
9183       eello6_6=0.0d0
9184 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9185 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9186       do iii=1,2
9187         do kkk=1,5
9188           do lll=1,3
9189             derx(lll,kkk,iii)=0.0d0
9190           enddo
9191         enddo
9192       enddo
9193 cd      eij=facont_hb(jj,i)
9194 cd      ekl=facont_hb(kk,k)
9195 cd      ekont=eij*ekl
9196 cd      eij=1.0d0
9197 cd      ekl=1.0d0
9198 cd      ekont=1.0d0
9199       if (l.eq.j+1) then
9200         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9201         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9202         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9203         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9204         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9205         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9206       else
9207         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9208         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9209         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9210         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9211         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9212           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9213         else
9214           eello6_5=0.0d0
9215         endif
9216         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9217       endif
9218 C If turn contributions are considered, they will be handled separately.
9219       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9220 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9221 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9222 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9223 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9224 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9225 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9226 cd      goto 1112
9227       if (calc_grad) then
9228       if (j.lt.nres-1) then
9229         j1=j+1
9230         j2=j-1
9231       else
9232         j1=j-1
9233         j2=j-2
9234       endif
9235       if (l.lt.nres-1) then
9236         l1=l+1
9237         l2=l-1
9238       else
9239         l1=l-1
9240         l2=l-2
9241       endif
9242       do ll=1,3
9243 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9244 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9245 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9246 cgrad        ghalf=0.5d0*ggg1(ll)
9247 cd        ghalf=0.0d0
9248         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9249         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9250         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9251         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9252         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9253         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9254         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9255         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9256 cgrad        ghalf=0.5d0*ggg2(ll)
9257 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9258 cd        ghalf=0.0d0
9259         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9260         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9261         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9262         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9263         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9264         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9265       enddo
9266       endif ! calc_grad
9267 cd      goto 1112
9268 cgrad      do m=i+1,j-1
9269 cgrad        do ll=1,3
9270 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9271 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9272 cgrad        enddo
9273 cgrad      enddo
9274 cgrad      do m=k+1,l-1
9275 cgrad        do ll=1,3
9276 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9277 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9278 cgrad        enddo
9279 cgrad      enddo
9280 cgrad1112  continue
9281 cgrad      do m=i+2,j2
9282 cgrad        do ll=1,3
9283 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9284 cgrad        enddo
9285 cgrad      enddo
9286 cgrad      do m=k+2,l2
9287 cgrad        do ll=1,3
9288 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9289 cgrad        enddo
9290 cgrad      enddo
9291 cd      do iii=1,nres-3
9292 cd        write (2,*) iii,g_corr6_loc(iii)
9293 cd      enddo
9294       eello6=ekont*eel6
9295 cd      write (2,*) 'ekont',ekont
9296 cd      write (iout,*) 'eello6',ekont*eel6
9297       return
9298       end
9299 c--------------------------------------------------------------------------
9300       double precision function eello6_graph1(i,j,k,l,imat,swap)
9301       implicit real*8 (a-h,o-z)
9302       include 'DIMENSIONS'
9303       include 'DIMENSIONS.ZSCOPT'
9304       include 'COMMON.IOUNITS'
9305       include 'COMMON.CHAIN'
9306       include 'COMMON.DERIV'
9307       include 'COMMON.INTERACT'
9308       include 'COMMON.CONTACTS'
9309       include 'COMMON.TORSION'
9310       include 'COMMON.VAR'
9311       include 'COMMON.GEO'
9312       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9313       logical swap
9314       logical lprn
9315       common /kutas/ lprn
9316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9317 C                                                                              C
9318 C      Parallel       Antiparallel                                             C
9319 C                                                                              C
9320 C          o             o                                                     C
9321 C         /l\           /j\                                                    C
9322 C        /   \         /   \                                                   C
9323 C       /| o |         | o |\                                                  C
9324 C     \ j|/k\|  /   \  |/k\|l /                                                C
9325 C      \ /   \ /     \ /   \ /                                                 C
9326 C       o     o       o     o                                                  C
9327 C       i             i                                                        C
9328 C                                                                              C
9329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9330       itk=itype2loc(itype(k))
9331       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9332       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9333       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9334       call transpose2(EUgC(1,1,k),auxmat(1,1))
9335       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9336       vv1(1)=pizda1(1,1)-pizda1(2,2)
9337       vv1(2)=pizda1(1,2)+pizda1(2,1)
9338       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9339       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9340       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9341       s5=scalar2(vv(1),Dtobr2(1,i))
9342 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9343       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9344       if (calc_grad) then
9345       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9346      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9347      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9348      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9349      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9350      & +scalar2(vv(1),Dtobr2der(1,i)))
9351       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9352       vv1(1)=pizda1(1,1)-pizda1(2,2)
9353       vv1(2)=pizda1(1,2)+pizda1(2,1)
9354       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9355       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9356       if (l.eq.j+1) then
9357         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9358      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9359      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9360      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9361      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9362       else
9363         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9364      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9365      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9366      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9367      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9368       endif
9369       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9370       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9371       vv1(1)=pizda1(1,1)-pizda1(2,2)
9372       vv1(2)=pizda1(1,2)+pizda1(2,1)
9373       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9374      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9375      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9376      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9377       do iii=1,2
9378         if (swap) then
9379           ind=3-iii
9380         else
9381           ind=iii
9382         endif
9383         do kkk=1,5
9384           do lll=1,3
9385             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9386             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9387             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9388             call transpose2(EUgC(1,1,k),auxmat(1,1))
9389             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9390      &        pizda1(1,1))
9391             vv1(1)=pizda1(1,1)-pizda1(2,2)
9392             vv1(2)=pizda1(1,2)+pizda1(2,1)
9393             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9394             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9395      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9396             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9397      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9398             s5=scalar2(vv(1),Dtobr2(1,i))
9399             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9400           enddo
9401         enddo
9402       enddo
9403       endif ! calc_grad
9404       return
9405       end
9406 c----------------------------------------------------------------------------
9407       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9408       implicit real*8 (a-h,o-z)
9409       include 'DIMENSIONS'
9410       include 'DIMENSIONS.ZSCOPT'
9411       include 'COMMON.IOUNITS'
9412       include 'COMMON.CHAIN'
9413       include 'COMMON.DERIV'
9414       include 'COMMON.INTERACT'
9415       include 'COMMON.CONTACTS'
9416       include 'COMMON.TORSION'
9417       include 'COMMON.VAR'
9418       include 'COMMON.GEO'
9419       logical swap
9420       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9421      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9422       logical lprn
9423       common /kutas/ lprn
9424 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9425 C                                                                              C
9426 C      Parallel       Antiparallel                                             C
9427 C                                                                              C
9428 C          o             o                                                     C
9429 C     \   /l\           /j\   /                                                C
9430 C      \ /   \         /   \ /                                                 C
9431 C       o| o |         | o |o                                                  C
9432 C     \ j|/k\|      \  |/k\|l                                                  C
9433 C      \ /   \       \ /   \                                                   C
9434 C       o             o                                                        C
9435 C       i             i                                                        C
9436 C                                                                              C
9437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9438 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9439 C AL 7/4/01 s1 would occur in the sixth-order moment,
9440 C           but not in a cluster cumulant
9441 #ifdef MOMENT
9442       s1=dip(1,jj,i)*dip(1,kk,k)
9443 #endif
9444       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9445       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9446       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9447       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9448       call transpose2(EUg(1,1,k),auxmat(1,1))
9449       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9450       vv(1)=pizda(1,1)-pizda(2,2)
9451       vv(2)=pizda(1,2)+pizda(2,1)
9452       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9453 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9454 #ifdef MOMENT
9455       eello6_graph2=-(s1+s2+s3+s4)
9456 #else
9457       eello6_graph2=-(s2+s3+s4)
9458 #endif
9459 c      eello6_graph2=-s3
9460 C Derivatives in gamma(i-1)
9461       if (calc_grad) then
9462       if (i.gt.1) then
9463 #ifdef MOMENT
9464         s1=dipderg(1,jj,i)*dip(1,kk,k)
9465 #endif
9466         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9467         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9468         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9469         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9470 #ifdef MOMENT
9471         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9472 #else
9473         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9474 #endif
9475 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9476       endif
9477 C Derivatives in gamma(k-1)
9478 #ifdef MOMENT
9479       s1=dip(1,jj,i)*dipderg(1,kk,k)
9480 #endif
9481       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9482       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9483       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9484       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9485       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9486       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9487       vv(1)=pizda(1,1)-pizda(2,2)
9488       vv(2)=pizda(1,2)+pizda(2,1)
9489       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9490 #ifdef MOMENT
9491       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9492 #else
9493       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9494 #endif
9495 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9496 C Derivatives in gamma(j-1) or gamma(l-1)
9497       if (j.gt.1) then
9498 #ifdef MOMENT
9499         s1=dipderg(3,jj,i)*dip(1,kk,k)
9500 #endif
9501         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9502         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9503         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9504         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9505         vv(1)=pizda(1,1)-pizda(2,2)
9506         vv(2)=pizda(1,2)+pizda(2,1)
9507         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9508 #ifdef MOMENT
9509         if (swap) then
9510           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9511         else
9512           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9513         endif
9514 #endif
9515         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9516 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9517       endif
9518 C Derivatives in gamma(l-1) or gamma(j-1)
9519       if (l.gt.1) then
9520 #ifdef MOMENT
9521         s1=dip(1,jj,i)*dipderg(3,kk,k)
9522 #endif
9523         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9524         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9525         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9526         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9527         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9528         vv(1)=pizda(1,1)-pizda(2,2)
9529         vv(2)=pizda(1,2)+pizda(2,1)
9530         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9531 #ifdef MOMENT
9532         if (swap) then
9533           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9534         else
9535           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9536         endif
9537 #endif
9538         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9539 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9540       endif
9541 C Cartesian derivatives.
9542       if (lprn) then
9543         write (2,*) 'In eello6_graph2'
9544         do iii=1,2
9545           write (2,*) 'iii=',iii
9546           do kkk=1,5
9547             write (2,*) 'kkk=',kkk
9548             do jjj=1,2
9549               write (2,'(3(2f10.5),5x)')
9550      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9551             enddo
9552           enddo
9553         enddo
9554       endif
9555       do iii=1,2
9556         do kkk=1,5
9557           do lll=1,3
9558 #ifdef MOMENT
9559             if (iii.eq.1) then
9560               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9561             else
9562               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9563             endif
9564 #endif
9565             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9566      &        auxvec(1))
9567             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9568             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9569      &        auxvec(1))
9570             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9571             call transpose2(EUg(1,1,k),auxmat(1,1))
9572             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9573      &        pizda(1,1))
9574             vv(1)=pizda(1,1)-pizda(2,2)
9575             vv(2)=pizda(1,2)+pizda(2,1)
9576             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9577 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9578 #ifdef MOMENT
9579             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9580 #else
9581             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9582 #endif
9583             if (swap) then
9584               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9585             else
9586               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9587             endif
9588           enddo
9589         enddo
9590       enddo
9591       endif ! calc_grad
9592       return
9593       end
9594 c----------------------------------------------------------------------------
9595       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9596       implicit real*8 (a-h,o-z)
9597       include 'DIMENSIONS'
9598       include 'DIMENSIONS.ZSCOPT'
9599       include 'COMMON.IOUNITS'
9600       include 'COMMON.CHAIN'
9601       include 'COMMON.DERIV'
9602       include 'COMMON.INTERACT'
9603       include 'COMMON.CONTACTS'
9604       include 'COMMON.TORSION'
9605       include 'COMMON.VAR'
9606       include 'COMMON.GEO'
9607       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9608       logical swap
9609 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9610 C                                                                              C
9611 C      Parallel       Antiparallel                                             C
9612 C                                                                              C
9613 C          o             o                                                     C
9614 C         /l\   /   \   /j\                                                    C
9615 C        /   \ /     \ /   \                                                   C
9616 C       /| o |o       o| o |\                                                  C
9617 C       j|/k\|  /      |/k\|l /                                                C
9618 C        /   \ /       /   \ /                                                 C
9619 C       /     o       /     o                                                  C
9620 C       i             i                                                        C
9621 C                                                                              C
9622 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9623 C
9624 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9625 C           energy moment and not to the cluster cumulant.
9626       iti=itortyp(itype(i))
9627       if (j.lt.nres-1) then
9628         itj1=itype2loc(itype(j+1))
9629       else
9630         itj1=nloctyp
9631       endif
9632       itk=itype2loc(itype(k))
9633       itk1=itype2loc(itype(k+1))
9634       if (l.lt.nres-1) then
9635         itl1=itype2loc(itype(l+1))
9636       else
9637         itl1=nloctyp
9638       endif
9639 #ifdef MOMENT
9640       s1=dip(4,jj,i)*dip(4,kk,k)
9641 #endif
9642       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9643       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9644       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9645       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9646       call transpose2(EE(1,1,k),auxmat(1,1))
9647       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9648       vv(1)=pizda(1,1)+pizda(2,2)
9649       vv(2)=pizda(2,1)-pizda(1,2)
9650       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9651 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9652 cd     & "sum",-(s2+s3+s4)
9653 #ifdef MOMENT
9654       eello6_graph3=-(s1+s2+s3+s4)
9655 #else
9656       eello6_graph3=-(s2+s3+s4)
9657 #endif
9658 c      eello6_graph3=-s4
9659 C Derivatives in gamma(k-1)
9660       if (calc_grad) then
9661       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9662       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9663       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9664       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9665 C Derivatives in gamma(l-1)
9666       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9667       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9668       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9669       vv(1)=pizda(1,1)+pizda(2,2)
9670       vv(2)=pizda(2,1)-pizda(1,2)
9671       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9672       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9673 C Cartesian derivatives.
9674       do iii=1,2
9675         do kkk=1,5
9676           do lll=1,3
9677 #ifdef MOMENT
9678             if (iii.eq.1) then
9679               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9680             else
9681               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9682             endif
9683 #endif
9684             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9685      &        auxvec(1))
9686             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9687             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9688      &        auxvec(1))
9689             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9690             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9691      &        pizda(1,1))
9692             vv(1)=pizda(1,1)+pizda(2,2)
9693             vv(2)=pizda(2,1)-pizda(1,2)
9694             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9695 #ifdef MOMENT
9696             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9697 #else
9698             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9699 #endif
9700             if (swap) then
9701               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9702             else
9703               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9704             endif
9705 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9706           enddo
9707         enddo
9708       enddo
9709       endif ! calc_grad
9710       return
9711       end
9712 c----------------------------------------------------------------------------
9713       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9714       implicit real*8 (a-h,o-z)
9715       include 'DIMENSIONS'
9716       include 'DIMENSIONS.ZSCOPT'
9717       include 'COMMON.IOUNITS'
9718       include 'COMMON.CHAIN'
9719       include 'COMMON.DERIV'
9720       include 'COMMON.INTERACT'
9721       include 'COMMON.CONTACTS'
9722       include 'COMMON.TORSION'
9723       include 'COMMON.VAR'
9724       include 'COMMON.GEO'
9725       include 'COMMON.FFIELD'
9726       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9727      & auxvec1(2),auxmat1(2,2)
9728       logical swap
9729 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9730 C                                                                              C
9731 C      Parallel       Antiparallel                                             C
9732 C                                                                              C
9733 C          o             o                                                     C
9734 C         /l\   /   \   /j\                                                    C
9735 C        /   \ /     \ /   \                                                   C
9736 C       /| o |o       o| o |\                                                  C
9737 C     \ j|/k\|      \  |/k\|l                                                  C
9738 C      \ /   \       \ /   \                                                   C
9739 C       o     \       o     \                                                  C
9740 C       i             i                                                        C
9741 C                                                                              C
9742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9743 C
9744 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9745 C           energy moment and not to the cluster cumulant.
9746 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9747       iti=itype2loc(itype(i))
9748       itj=itype2loc(itype(j))
9749       if (j.lt.nres-1) then
9750         itj1=itype2loc(itype(j+1))
9751       else
9752         itj1=nloctyp
9753       endif
9754       itk=itype2loc(itype(k))
9755       if (k.lt.nres-1) then
9756         itk1=itype2loc(itype(k+1))
9757       else
9758         itk1=nloctyp
9759       endif
9760       itl=itype2loc(itype(l))
9761       if (l.lt.nres-1) then
9762         itl1=itype2loc(itype(l+1))
9763       else
9764         itl1=nloctyp
9765       endif
9766 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9767 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9768 cd     & ' itl',itl,' itl1',itl1
9769 #ifdef MOMENT
9770       if (imat.eq.1) then
9771         s1=dip(3,jj,i)*dip(3,kk,k)
9772       else
9773         s1=dip(2,jj,j)*dip(2,kk,l)
9774       endif
9775 #endif
9776       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9777       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9778       if (j.eq.l+1) then
9779         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9780         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9781       else
9782         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9783         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9784       endif
9785       call transpose2(EUg(1,1,k),auxmat(1,1))
9786       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9787       vv(1)=pizda(1,1)-pizda(2,2)
9788       vv(2)=pizda(2,1)+pizda(1,2)
9789       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9790 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9791 #ifdef MOMENT
9792       eello6_graph4=-(s1+s2+s3+s4)
9793 #else
9794       eello6_graph4=-(s2+s3+s4)
9795 #endif
9796 C Derivatives in gamma(i-1)
9797       if (calc_grad) then
9798       if (i.gt.1) then
9799 #ifdef MOMENT
9800         if (imat.eq.1) then
9801           s1=dipderg(2,jj,i)*dip(3,kk,k)
9802         else
9803           s1=dipderg(4,jj,j)*dip(2,kk,l)
9804         endif
9805 #endif
9806         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9807         if (j.eq.l+1) then
9808           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9809           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9810         else
9811           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9812           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9813         endif
9814         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9815         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9816 cd          write (2,*) 'turn6 derivatives'
9817 #ifdef MOMENT
9818           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9819 #else
9820           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9821 #endif
9822         else
9823 #ifdef MOMENT
9824           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9825 #else
9826           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9827 #endif
9828         endif
9829       endif
9830 C Derivatives in gamma(k-1)
9831 #ifdef MOMENT
9832       if (imat.eq.1) then
9833         s1=dip(3,jj,i)*dipderg(2,kk,k)
9834       else
9835         s1=dip(2,jj,j)*dipderg(4,kk,l)
9836       endif
9837 #endif
9838       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9839       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9840       if (j.eq.l+1) then
9841         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9842         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9843       else
9844         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9845         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9846       endif
9847       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9848       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9849       vv(1)=pizda(1,1)-pizda(2,2)
9850       vv(2)=pizda(2,1)+pizda(1,2)
9851       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9852       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9853 #ifdef MOMENT
9854         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9855 #else
9856         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9857 #endif
9858       else
9859 #ifdef MOMENT
9860         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9861 #else
9862         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9863 #endif
9864       endif
9865 C Derivatives in gamma(j-1) or gamma(l-1)
9866       if (l.eq.j+1 .and. l.gt.1) then
9867         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9868         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9869         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9870         vv(1)=pizda(1,1)-pizda(2,2)
9871         vv(2)=pizda(2,1)+pizda(1,2)
9872         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9873         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9874       else if (j.gt.1) then
9875         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9876         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9877         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9878         vv(1)=pizda(1,1)-pizda(2,2)
9879         vv(2)=pizda(2,1)+pizda(1,2)
9880         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9881         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9882           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9883         else
9884           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9885         endif
9886       endif
9887 C Cartesian derivatives.
9888       do iii=1,2
9889         do kkk=1,5
9890           do lll=1,3
9891 #ifdef MOMENT
9892             if (iii.eq.1) then
9893               if (imat.eq.1) then
9894                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9895               else
9896                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9897               endif
9898             else
9899               if (imat.eq.1) then
9900                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9901               else
9902                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9903               endif
9904             endif
9905 #endif
9906             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9907      &        auxvec(1))
9908             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9909             if (j.eq.l+1) then
9910               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9911      &          b1(1,j+1),auxvec(1))
9912               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9913             else
9914               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9915      &          b1(1,l+1),auxvec(1))
9916               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9917             endif
9918             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9919      &        pizda(1,1))
9920             vv(1)=pizda(1,1)-pizda(2,2)
9921             vv(2)=pizda(2,1)+pizda(1,2)
9922             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9923             if (swap) then
9924               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9925 #ifdef MOMENT
9926                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9927      &             -(s1+s2+s4)
9928 #else
9929                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9930      &             -(s2+s4)
9931 #endif
9932                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9933               else
9934 #ifdef MOMENT
9935                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9936 #else
9937                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9938 #endif
9939                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9940               endif
9941             else
9942 #ifdef MOMENT
9943               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9944 #else
9945               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9946 #endif
9947               if (l.eq.j+1) then
9948                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9949               else
9950                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9951               endif
9952             endif
9953           enddo
9954         enddo
9955       enddo
9956       endif ! calc_grad
9957       return
9958       end
9959 c----------------------------------------------------------------------------
9960       double precision function eello_turn6(i,jj,kk)
9961       implicit real*8 (a-h,o-z)
9962       include 'DIMENSIONS'
9963       include 'DIMENSIONS.ZSCOPT'
9964       include 'COMMON.IOUNITS'
9965       include 'COMMON.CHAIN'
9966       include 'COMMON.DERIV'
9967       include 'COMMON.INTERACT'
9968       include 'COMMON.CONTACTS'
9969       include 'COMMON.TORSION'
9970       include 'COMMON.VAR'
9971       include 'COMMON.GEO'
9972       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9973      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9974      &  ggg1(3),ggg2(3)
9975       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9976      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9977 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9978 C           the respective energy moment and not to the cluster cumulant.
9979       s1=0.0d0
9980       s8=0.0d0
9981       s13=0.0d0
9982 c
9983       eello_turn6=0.0d0
9984       j=i+4
9985       k=i+1
9986       l=i+3
9987       iti=itype2loc(itype(i))
9988       itk=itype2loc(itype(k))
9989       itk1=itype2loc(itype(k+1))
9990       itl=itype2loc(itype(l))
9991       itj=itype2loc(itype(j))
9992 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9993 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9994 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9995 cd        eello6=0.0d0
9996 cd        return
9997 cd      endif
9998 cd      write (iout,*)
9999 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10000 cd     &   ' and',k,l
10001 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10002       do iii=1,2
10003         do kkk=1,5
10004           do lll=1,3
10005             derx_turn(lll,kkk,iii)=0.0d0
10006           enddo
10007         enddo
10008       enddo
10009 cd      eij=1.0d0
10010 cd      ekl=1.0d0
10011 cd      ekont=1.0d0
10012       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10013 cd      eello6_5=0.0d0
10014 cd      write (2,*) 'eello6_5',eello6_5
10015 #ifdef MOMENT
10016       call transpose2(AEA(1,1,1),auxmat(1,1))
10017       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10018       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10019       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10020 #endif
10021       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10022       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10023       s2 = scalar2(b1(1,k),vtemp1(1))
10024 #ifdef MOMENT
10025       call transpose2(AEA(1,1,2),atemp(1,1))
10026       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10027       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10028       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10029 #endif
10030       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10031       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10032       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10033 #ifdef MOMENT
10034       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10035       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10036       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10037       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10038       ss13 = scalar2(b1(1,k),vtemp4(1))
10039       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10040 #endif
10041 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10042 c      s1=0.0d0
10043 c      s2=0.0d0
10044 c      s8=0.0d0
10045 c      s12=0.0d0
10046 c      s13=0.0d0
10047       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10048 C Derivatives in gamma(i+2)
10049       if (calc_grad) then
10050       s1d =0.0d0
10051       s8d =0.0d0
10052 #ifdef MOMENT
10053       call transpose2(AEA(1,1,1),auxmatd(1,1))
10054       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10055       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10056       call transpose2(AEAderg(1,1,2),atempd(1,1))
10057       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10058       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10059 #endif
10060       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10061       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10062       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10063 c      s1d=0.0d0
10064 c      s2d=0.0d0
10065 c      s8d=0.0d0
10066 c      s12d=0.0d0
10067 c      s13d=0.0d0
10068       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10069 C Derivatives in gamma(i+3)
10070 #ifdef MOMENT
10071       call transpose2(AEA(1,1,1),auxmatd(1,1))
10072       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10073       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10074       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10075 #endif
10076       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10077       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10078       s2d = scalar2(b1(1,k),vtemp1d(1))
10079 #ifdef MOMENT
10080       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10081       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10082 #endif
10083       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10084 #ifdef MOMENT
10085       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10086       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10087       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10088 #endif
10089 c      s1d=0.0d0
10090 c      s2d=0.0d0
10091 c      s8d=0.0d0
10092 c      s12d=0.0d0
10093 c      s13d=0.0d0
10094 #ifdef MOMENT
10095       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10096      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10097 #else
10098       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10099      &               -0.5d0*ekont*(s2d+s12d)
10100 #endif
10101 C Derivatives in gamma(i+4)
10102       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10103       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10104       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10105 #ifdef MOMENT
10106       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10107       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10108       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10109 #endif
10110 c      s1d=0.0d0
10111 c      s2d=0.0d0
10112 c      s8d=0.0d0
10113 C      s12d=0.0d0
10114 c      s13d=0.0d0
10115 #ifdef MOMENT
10116       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10117 #else
10118       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10119 #endif
10120 C Derivatives in gamma(i+5)
10121 #ifdef MOMENT
10122       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10123       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10124       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10125 #endif
10126       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10127       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10128       s2d = scalar2(b1(1,k),vtemp1d(1))
10129 #ifdef MOMENT
10130       call transpose2(AEA(1,1,2),atempd(1,1))
10131       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10132       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10133 #endif
10134       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10135       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10136 #ifdef MOMENT
10137       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10138       ss13d = scalar2(b1(1,k),vtemp4d(1))
10139       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10140 #endif
10141 c      s1d=0.0d0
10142 c      s2d=0.0d0
10143 c      s8d=0.0d0
10144 c      s12d=0.0d0
10145 c      s13d=0.0d0
10146 #ifdef MOMENT
10147       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10148      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10149 #else
10150       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10151      &               -0.5d0*ekont*(s2d+s12d)
10152 #endif
10153 C Cartesian derivatives
10154       do iii=1,2
10155         do kkk=1,5
10156           do lll=1,3
10157 #ifdef MOMENT
10158             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10159             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10160             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10161 #endif
10162             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10163             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10164      &          vtemp1d(1))
10165             s2d = scalar2(b1(1,k),vtemp1d(1))
10166 #ifdef MOMENT
10167             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10168             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10169             s8d = -(atempd(1,1)+atempd(2,2))*
10170      &           scalar2(cc(1,1,l),vtemp2(1))
10171 #endif
10172             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10173      &           auxmatd(1,1))
10174             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10175             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10176 c      s1d=0.0d0
10177 c      s2d=0.0d0
10178 c      s8d=0.0d0
10179 c      s12d=0.0d0
10180 c      s13d=0.0d0
10181 #ifdef MOMENT
10182             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10183      &        - 0.5d0*(s1d+s2d)
10184 #else
10185             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10186      &        - 0.5d0*s2d
10187 #endif
10188 #ifdef MOMENT
10189             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10190      &        - 0.5d0*(s8d+s12d)
10191 #else
10192             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10193      &        - 0.5d0*s12d
10194 #endif
10195           enddo
10196         enddo
10197       enddo
10198 #ifdef MOMENT
10199       do kkk=1,5
10200         do lll=1,3
10201           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10202      &      achuj_tempd(1,1))
10203           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10204           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10205           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10206           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10207           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10208      &      vtemp4d(1))
10209           ss13d = scalar2(b1(1,k),vtemp4d(1))
10210           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10211           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10212         enddo
10213       enddo
10214 #endif
10215 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10216 cd     &  16*eel_turn6_num
10217 cd      goto 1112
10218       if (j.lt.nres-1) then
10219         j1=j+1
10220         j2=j-1
10221       else
10222         j1=j-1
10223         j2=j-2
10224       endif
10225       if (l.lt.nres-1) then
10226         l1=l+1
10227         l2=l-1
10228       else
10229         l1=l-1
10230         l2=l-2
10231       endif
10232       do ll=1,3
10233 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10234 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10235 cgrad        ghalf=0.5d0*ggg1(ll)
10236 cd        ghalf=0.0d0
10237         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10238         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10239         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10240      &    +ekont*derx_turn(ll,2,1)
10241         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10242         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10243      &    +ekont*derx_turn(ll,4,1)
10244         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10245         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10246         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10247 cgrad        ghalf=0.5d0*ggg2(ll)
10248 cd        ghalf=0.0d0
10249         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10250      &    +ekont*derx_turn(ll,2,2)
10251         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10252         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10253      &    +ekont*derx_turn(ll,4,2)
10254         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10255         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10256         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10257       enddo
10258 cd      goto 1112
10259 cgrad      do m=i+1,j-1
10260 cgrad        do ll=1,3
10261 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10262 cgrad        enddo
10263 cgrad      enddo
10264 cgrad      do m=k+1,l-1
10265 cgrad        do ll=1,3
10266 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10267 cgrad        enddo
10268 cgrad      enddo
10269 cgrad1112  continue
10270 cgrad      do m=i+2,j2
10271 cgrad        do ll=1,3
10272 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10273 cgrad        enddo
10274 cgrad      enddo
10275 cgrad      do m=k+2,l2
10276 cgrad        do ll=1,3
10277 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10278 cgrad        enddo
10279 cgrad      enddo
10280 cd      do iii=1,nres-3
10281 cd        write (2,*) iii,g_corr6_loc(iii)
10282 cd      enddo
10283       endif ! calc_grad
10284       eello_turn6=ekont*eel_turn6
10285 cd      write (2,*) 'ekont',ekont
10286 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10287       return
10288       end
10289
10290 crc-------------------------------------------------
10291 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10292       subroutine Eliptransfer(eliptran)
10293       implicit real*8 (a-h,o-z)
10294       include 'DIMENSIONS'
10295       include 'DIMENSIONS.ZSCOPT'
10296       include 'COMMON.GEO'
10297       include 'COMMON.VAR'
10298       include 'COMMON.LOCAL'
10299       include 'COMMON.CHAIN'
10300       include 'COMMON.DERIV'
10301       include 'COMMON.INTERACT'
10302       include 'COMMON.IOUNITS'
10303       include 'COMMON.CALC'
10304       include 'COMMON.CONTROL'
10305       include 'COMMON.SPLITELE'
10306       include 'COMMON.SBRIDGE'
10307 C this is done by Adasko
10308 C      print *,"wchodze"
10309 C structure of box:
10310 C      water
10311 C--bordliptop-- buffore starts
10312 C--bufliptop--- here true lipid starts
10313 C      lipid
10314 C--buflipbot--- lipid ends buffore starts
10315 C--bordlipbot--buffore ends
10316       eliptran=0.0
10317       do i=1,nres
10318 C       do i=1,1
10319         if (itype(i).eq.ntyp1) cycle
10320
10321         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10322         if (positi.le.0) positi=positi+boxzsize
10323 C        print *,i
10324 C first for peptide groups
10325 c for each residue check if it is in lipid or lipid water border area
10326        if ((positi.gt.bordlipbot)
10327      &.and.(positi.lt.bordliptop)) then
10328 C the energy transfer exist
10329         if (positi.lt.buflipbot) then
10330 C what fraction I am in
10331          fracinbuf=1.0d0-
10332      &        ((positi-bordlipbot)/lipbufthick)
10333 C lipbufthick is thickenes of lipid buffore
10334          sslip=sscalelip(fracinbuf)
10335          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10336          eliptran=eliptran+sslip*pepliptran
10337          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10338          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10339 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10340         elseif (positi.gt.bufliptop) then
10341          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10342          sslip=sscalelip(fracinbuf)
10343          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10344          eliptran=eliptran+sslip*pepliptran
10345          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10346          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10347 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10348 C          print *, "doing sscalefor top part"
10349 C         print *,i,sslip,fracinbuf,ssgradlip
10350         else
10351          eliptran=eliptran+pepliptran
10352 C         print *,"I am in true lipid"
10353         endif
10354 C       else
10355 C       eliptran=elpitran+0.0 ! I am in water
10356        endif
10357        enddo
10358 C       print *, "nic nie bylo w lipidzie?"
10359 C now multiply all by the peptide group transfer factor
10360 C       eliptran=eliptran*pepliptran
10361 C now the same for side chains
10362 CV       do i=1,1
10363        do i=1,nres
10364         if (itype(i).eq.ntyp1) cycle
10365         positi=(mod(c(3,i+nres),boxzsize))
10366         if (positi.le.0) positi=positi+boxzsize
10367 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10368 c for each residue check if it is in lipid or lipid water border area
10369 C       respos=mod(c(3,i+nres),boxzsize)
10370 C       print *,positi,bordlipbot,buflipbot
10371        if ((positi.gt.bordlipbot)
10372      & .and.(positi.lt.bordliptop)) then
10373 C the energy transfer exist
10374         if (positi.lt.buflipbot) then
10375          fracinbuf=1.0d0-
10376      &     ((positi-bordlipbot)/lipbufthick)
10377 C lipbufthick is thickenes of lipid buffore
10378          sslip=sscalelip(fracinbuf)
10379          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10380          eliptran=eliptran+sslip*liptranene(itype(i))
10381          gliptranx(3,i)=gliptranx(3,i)
10382      &+ssgradlip*liptranene(itype(i))
10383          gliptranc(3,i-1)= gliptranc(3,i-1)
10384      &+ssgradlip*liptranene(itype(i))
10385 C         print *,"doing sccale for lower part"
10386         elseif (positi.gt.bufliptop) then
10387          fracinbuf=1.0d0-
10388      &((bordliptop-positi)/lipbufthick)
10389          sslip=sscalelip(fracinbuf)
10390          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10391          eliptran=eliptran+sslip*liptranene(itype(i))
10392          gliptranx(3,i)=gliptranx(3,i)
10393      &+ssgradlip*liptranene(itype(i))
10394          gliptranc(3,i-1)= gliptranc(3,i-1)
10395      &+ssgradlip*liptranene(itype(i))
10396 C          print *, "doing sscalefor top part",sslip,fracinbuf
10397         else
10398          eliptran=eliptran+liptranene(itype(i))
10399 C         print *,"I am in true lipid"
10400         endif
10401         endif ! if in lipid or buffor
10402 C       else
10403 C       eliptran=elpitran+0.0 ! I am in water
10404        enddo
10405        return
10406        end
10407
10408
10409 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10410
10411       SUBROUTINE MATVEC2(A1,V1,V2)
10412       implicit real*8 (a-h,o-z)
10413       include 'DIMENSIONS'
10414       DIMENSION A1(2,2),V1(2),V2(2)
10415 c      DO 1 I=1,2
10416 c        VI=0.0
10417 c        DO 3 K=1,2
10418 c    3     VI=VI+A1(I,K)*V1(K)
10419 c        Vaux(I)=VI
10420 c    1 CONTINUE
10421
10422       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10423       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10424
10425       v2(1)=vaux1
10426       v2(2)=vaux2
10427       END
10428 C---------------------------------------
10429       SUBROUTINE MATMAT2(A1,A2,A3)
10430       implicit real*8 (a-h,o-z)
10431       include 'DIMENSIONS'
10432       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10433 c      DIMENSION AI3(2,2)
10434 c        DO  J=1,2
10435 c          A3IJ=0.0
10436 c          DO K=1,2
10437 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10438 c          enddo
10439 c          A3(I,J)=A3IJ
10440 c       enddo
10441 c      enddo
10442
10443       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10444       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10445       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10446       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10447
10448       A3(1,1)=AI3_11
10449       A3(2,1)=AI3_21
10450       A3(1,2)=AI3_12
10451       A3(2,2)=AI3_22
10452       END
10453
10454 c-------------------------------------------------------------------------
10455       double precision function scalar2(u,v)
10456       implicit none
10457       double precision u(2),v(2)
10458       double precision sc
10459       integer i
10460       scalar2=u(1)*v(1)+u(2)*v(2)
10461       return
10462       end
10463
10464 C-----------------------------------------------------------------------------
10465
10466       subroutine transpose2(a,at)
10467       implicit none
10468       double precision a(2,2),at(2,2)
10469       at(1,1)=a(1,1)
10470       at(1,2)=a(2,1)
10471       at(2,1)=a(1,2)
10472       at(2,2)=a(2,2)
10473       return
10474       end
10475 c--------------------------------------------------------------------------
10476       subroutine transpose(n,a,at)
10477       implicit none
10478       integer n,i,j
10479       double precision a(n,n),at(n,n)
10480       do i=1,n
10481         do j=1,n
10482           at(j,i)=a(i,j)
10483         enddo
10484       enddo
10485       return
10486       end
10487 C---------------------------------------------------------------------------
10488       subroutine prodmat3(a1,a2,kk,transp,prod)
10489       implicit none
10490       integer i,j
10491       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10492       logical transp
10493 crc      double precision auxmat(2,2),prod_(2,2)
10494
10495       if (transp) then
10496 crc        call transpose2(kk(1,1),auxmat(1,1))
10497 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10498 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10499
10500            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10501      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10502            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10503      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10504            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10505      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10506            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10507      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10508
10509       else
10510 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10511 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10512
10513            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10514      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10515            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10516      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10517            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10518      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10519            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10520      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10521
10522       endif
10523 c      call transpose2(a2(1,1),a2t(1,1))
10524
10525 crc      print *,transp
10526 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10527 crc      print *,((prod(i,j),i=1,2),j=1,2)
10528
10529       return
10530       end
10531 C-----------------------------------------------------------------------------
10532       double precision function scalar(u,v)
10533       implicit none
10534       double precision u(3),v(3)
10535       double precision sc
10536       integer i
10537       sc=0.0d0
10538       do i=1,3
10539         sc=sc+u(i)*v(i)
10540       enddo
10541       scalar=sc
10542       return
10543       end
10544 C-----------------------------------------------------------------------
10545       double precision function sscale(r)
10546       double precision r,gamm
10547       include "COMMON.SPLITELE"
10548       if(r.lt.r_cut-rlamb) then
10549         sscale=1.0d0
10550       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10551         gamm=(r-(r_cut-rlamb))/rlamb
10552         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10553       else
10554         sscale=0d0
10555       endif
10556       return
10557       end
10558 C-----------------------------------------------------------------------
10559 C-----------------------------------------------------------------------
10560       double precision function sscagrad(r)
10561       double precision r,gamm
10562       include "COMMON.SPLITELE"
10563       if(r.lt.r_cut-rlamb) then
10564         sscagrad=0.0d0
10565       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10566         gamm=(r-(r_cut-rlamb))/rlamb
10567         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10568       else
10569         sscagrad=0.0d0
10570       endif
10571       return
10572       end
10573 C-----------------------------------------------------------------------
10574 C-----------------------------------------------------------------------
10575       double precision function sscalelip(r)
10576       double precision r,gamm
10577       include "COMMON.SPLITELE"
10578 C      if(r.lt.r_cut-rlamb) then
10579 C        sscale=1.0d0
10580 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10581 C        gamm=(r-(r_cut-rlamb))/rlamb
10582         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10583 C      else
10584 C        sscale=0d0
10585 C      endif
10586       return
10587       end
10588 C-----------------------------------------------------------------------
10589       double precision function sscagradlip(r)
10590       double precision r,gamm
10591       include "COMMON.SPLITELE"
10592 C     if(r.lt.r_cut-rlamb) then
10593 C        sscagrad=0.0d0
10594 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10595 C        gamm=(r-(r_cut-rlamb))/rlamb
10596         sscagradlip=r*(6*r-6.0d0)
10597 C      else
10598 C        sscagrad=0.0d0
10599 C      endif
10600       return
10601       end
10602
10603 C-----------------------------------------------------------------------
10604        subroutine set_shield_fac
10605       implicit real*8 (a-h,o-z)
10606       include 'DIMENSIONS'
10607       include 'DIMENSIONS.ZSCOPT'
10608       include 'COMMON.CHAIN'
10609       include 'COMMON.DERIV'
10610       include 'COMMON.IOUNITS'
10611       include 'COMMON.SHIELD'
10612       include 'COMMON.INTERACT'
10613 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10614       double precision div77_81/0.974996043d0/,
10615      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10616
10617 C the vector between center of side_chain and peptide group
10618        double precision pep_side(3),long,side_calf(3),
10619      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10620      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10621 C the line belowe needs to be changed for FGPROC>1
10622       do i=1,nres-1
10623       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10624       ishield_list(i)=0
10625 Cif there two consequtive dummy atoms there is no peptide group between them
10626 C the line below has to be changed for FGPROC>1
10627       VolumeTotal=0.0
10628       do k=1,nres
10629        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10630        dist_pep_side=0.0
10631        dist_side_calf=0.0
10632        do j=1,3
10633 C first lets set vector conecting the ithe side-chain with kth side-chain
10634       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10635 C      pep_side(j)=2.0d0
10636 C and vector conecting the side-chain with its proper calfa
10637       side_calf(j)=c(j,k+nres)-c(j,k)
10638 C      side_calf(j)=2.0d0
10639       pept_group(j)=c(j,i)-c(j,i+1)
10640 C lets have their lenght
10641       dist_pep_side=pep_side(j)**2+dist_pep_side
10642       dist_side_calf=dist_side_calf+side_calf(j)**2
10643       dist_pept_group=dist_pept_group+pept_group(j)**2
10644       enddo
10645        dist_pep_side=dsqrt(dist_pep_side)
10646        dist_pept_group=dsqrt(dist_pept_group)
10647        dist_side_calf=dsqrt(dist_side_calf)
10648       do j=1,3
10649         pep_side_norm(j)=pep_side(j)/dist_pep_side
10650         side_calf_norm(j)=dist_side_calf
10651       enddo
10652 C now sscale fraction
10653        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10654 C       print *,buff_shield,"buff"
10655 C now sscale
10656         if (sh_frac_dist.le.0.0) cycle
10657 C If we reach here it means that this side chain reaches the shielding sphere
10658 C Lets add him to the list for gradient
10659         ishield_list(i)=ishield_list(i)+1
10660 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10661 C this list is essential otherwise problem would be O3
10662         shield_list(ishield_list(i),i)=k
10663 C Lets have the sscale value
10664         if (sh_frac_dist.gt.1.0) then
10665          scale_fac_dist=1.0d0
10666          do j=1,3
10667          sh_frac_dist_grad(j)=0.0d0
10668          enddo
10669         else
10670          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10671      &                   *(2.0*sh_frac_dist-3.0d0)
10672          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10673      &                  /dist_pep_side/buff_shield*0.5
10674 C remember for the final gradient multiply sh_frac_dist_grad(j)
10675 C for side_chain by factor -2 !
10676          do j=1,3
10677          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10678 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10679 C     &                    sh_frac_dist_grad(j)
10680          enddo
10681         endif
10682 C        if ((i.eq.3).and.(k.eq.2)) then
10683 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10684 C     & ,"TU"
10685 C        endif
10686
10687 C this is what is now we have the distance scaling now volume...
10688       short=short_r_sidechain(itype(k))
10689       long=long_r_sidechain(itype(k))
10690       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10691 C now costhet_grad
10692 C       costhet=0.0d0
10693        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10694 C       costhet_fac=0.0d0
10695        do j=1,3
10696          costhet_grad(j)=costhet_fac*pep_side(j)
10697        enddo
10698 C remember for the final gradient multiply costhet_grad(j)
10699 C for side_chain by factor -2 !
10700 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10701 C pep_side0pept_group is vector multiplication
10702       pep_side0pept_group=0.0
10703       do j=1,3
10704       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10705       enddo
10706       cosalfa=(pep_side0pept_group/
10707      & (dist_pep_side*dist_side_calf))
10708       fac_alfa_sin=1.0-cosalfa**2
10709       fac_alfa_sin=dsqrt(fac_alfa_sin)
10710       rkprim=fac_alfa_sin*(long-short)+short
10711 C now costhet_grad
10712        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10713        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10714
10715        do j=1,3
10716          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10717      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10718      &*(long-short)/fac_alfa_sin*cosalfa/
10719      &((dist_pep_side*dist_side_calf))*
10720      &((side_calf(j))-cosalfa*
10721      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10722
10723         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10724      &*(long-short)/fac_alfa_sin*cosalfa
10725      &/((dist_pep_side*dist_side_calf))*
10726      &(pep_side(j)-
10727      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10728        enddo
10729
10730       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10731      &                    /VSolvSphere_div
10732      &                    *wshield
10733 C now the gradient...
10734 C grad_shield is gradient of Calfa for peptide groups
10735 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10736 C     &               costhet,cosphi
10737 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10738 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10739       do j=1,3
10740       grad_shield(j,i)=grad_shield(j,i)
10741 C gradient po skalowaniu
10742      &                +(sh_frac_dist_grad(j)
10743 C  gradient po costhet
10744      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10745      &-scale_fac_dist*(cosphi_grad_long(j))
10746      &/(1.0-cosphi) )*div77_81
10747      &*VofOverlap
10748 C grad_shield_side is Cbeta sidechain gradient
10749       grad_shield_side(j,ishield_list(i),i)=
10750      &        (sh_frac_dist_grad(j)*-2.0d0
10751      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10752      &       +scale_fac_dist*(cosphi_grad_long(j))
10753      &        *2.0d0/(1.0-cosphi))
10754      &        *div77_81*VofOverlap
10755
10756        grad_shield_loc(j,ishield_list(i),i)=
10757      &   scale_fac_dist*cosphi_grad_loc(j)
10758      &        *2.0d0/(1.0-cosphi)
10759      &        *div77_81*VofOverlap
10760       enddo
10761       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10762       enddo
10763       fac_shield(i)=VolumeTotal*div77_81+div4_81
10764 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10765       enddo
10766       return
10767       end
10768 C--------------------------------------------------------------------------
10769 C first for shielding is setting of function of side-chains
10770        subroutine set_shield_fac2
10771       implicit real*8 (a-h,o-z)
10772       include 'DIMENSIONS'
10773       include 'DIMENSIONS.ZSCOPT'
10774       include 'COMMON.CHAIN'
10775       include 'COMMON.DERIV'
10776       include 'COMMON.IOUNITS'
10777       include 'COMMON.SHIELD'
10778       include 'COMMON.INTERACT'
10779 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10780       double precision div77_81/0.974996043d0/,
10781      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10782
10783 C the vector between center of side_chain and peptide group
10784        double precision pep_side(3),long,side_calf(3),
10785      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10786      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10787 C the line belowe needs to be changed for FGPROC>1
10788       do i=1,nres-1
10789       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10790       ishield_list(i)=0
10791 Cif there two consequtive dummy atoms there is no peptide group between them
10792 C the line below has to be changed for FGPROC>1
10793       VolumeTotal=0.0
10794       do k=1,nres
10795        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10796        dist_pep_side=0.0
10797        dist_side_calf=0.0
10798        do j=1,3
10799 C first lets set vector conecting the ithe side-chain with kth side-chain
10800       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10801 C      pep_side(j)=2.0d0
10802 C and vector conecting the side-chain with its proper calfa
10803       side_calf(j)=c(j,k+nres)-c(j,k)
10804 C      side_calf(j)=2.0d0
10805       pept_group(j)=c(j,i)-c(j,i+1)
10806 C lets have their lenght
10807       dist_pep_side=pep_side(j)**2+dist_pep_side
10808       dist_side_calf=dist_side_calf+side_calf(j)**2
10809       dist_pept_group=dist_pept_group+pept_group(j)**2
10810       enddo
10811        dist_pep_side=dsqrt(dist_pep_side)
10812        dist_pept_group=dsqrt(dist_pept_group)
10813        dist_side_calf=dsqrt(dist_side_calf)
10814       do j=1,3
10815         pep_side_norm(j)=pep_side(j)/dist_pep_side
10816         side_calf_norm(j)=dist_side_calf
10817       enddo
10818 C now sscale fraction
10819        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10820 C       print *,buff_shield,"buff"
10821 C now sscale
10822         if (sh_frac_dist.le.0.0) cycle
10823 C If we reach here it means that this side chain reaches the shielding sphere
10824 C Lets add him to the list for gradient
10825         ishield_list(i)=ishield_list(i)+1
10826 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10827 C this list is essential otherwise problem would be O3
10828         shield_list(ishield_list(i),i)=k
10829 C Lets have the sscale value
10830         if (sh_frac_dist.gt.1.0) then
10831          scale_fac_dist=1.0d0
10832          do j=1,3
10833          sh_frac_dist_grad(j)=0.0d0
10834          enddo
10835         else
10836          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10837      &                   *(2.0d0*sh_frac_dist-3.0d0)
10838          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10839      &                  /dist_pep_side/buff_shield*0.5d0
10840 C remember for the final gradient multiply sh_frac_dist_grad(j)
10841 C for side_chain by factor -2 !
10842          do j=1,3
10843          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10844 C         sh_frac_dist_grad(j)=0.0d0
10845 C         scale_fac_dist=1.0d0
10846 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10847 C     &                    sh_frac_dist_grad(j)
10848          enddo
10849         endif
10850 C this is what is now we have the distance scaling now volume...
10851       short=short_r_sidechain(itype(k))
10852       long=long_r_sidechain(itype(k))
10853       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10854       sinthet=short/dist_pep_side*costhet
10855 C now costhet_grad
10856 C       costhet=0.6d0
10857 C       sinthet=0.8
10858        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10859 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10860 C     &             -short/dist_pep_side**2/costhet)
10861 C       costhet_fac=0.0d0
10862        do j=1,3
10863          costhet_grad(j)=costhet_fac*pep_side(j)
10864        enddo
10865 C remember for the final gradient multiply costhet_grad(j)
10866 C for side_chain by factor -2 !
10867 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10868 C pep_side0pept_group is vector multiplication
10869       pep_side0pept_group=0.0d0
10870       do j=1,3
10871       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10872       enddo
10873       cosalfa=(pep_side0pept_group/
10874      & (dist_pep_side*dist_side_calf))
10875       fac_alfa_sin=1.0d0-cosalfa**2
10876       fac_alfa_sin=dsqrt(fac_alfa_sin)
10877       rkprim=fac_alfa_sin*(long-short)+short
10878 C      rkprim=short
10879
10880 C now costhet_grad
10881        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10882 C       cosphi=0.6
10883        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10884        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10885      &      dist_pep_side**2)
10886 C       sinphi=0.8
10887        do j=1,3
10888          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10889      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10890      &*(long-short)/fac_alfa_sin*cosalfa/
10891      &((dist_pep_side*dist_side_calf))*
10892      &((side_calf(j))-cosalfa*
10893      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10894 C       cosphi_grad_long(j)=0.0d0
10895         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10896      &*(long-short)/fac_alfa_sin*cosalfa
10897      &/((dist_pep_side*dist_side_calf))*
10898      &(pep_side(j)-
10899      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10900 C       cosphi_grad_loc(j)=0.0d0
10901        enddo
10902 C      print *,sinphi,sinthet
10903       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10904      &                    /VSolvSphere_div
10905 C     &                    *wshield
10906 C now the gradient...
10907       do j=1,3
10908       grad_shield(j,i)=grad_shield(j,i)
10909 C gradient po skalowaniu
10910      &                +(sh_frac_dist_grad(j)*VofOverlap
10911 C  gradient po costhet
10912      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10913      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10914      &       sinphi/sinthet*costhet*costhet_grad(j)
10915      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10916      & )*wshield
10917 C grad_shield_side is Cbeta sidechain gradient
10918       grad_shield_side(j,ishield_list(i),i)=
10919      &        (sh_frac_dist_grad(j)*-2.0d0
10920      &        *VofOverlap
10921      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10922      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10923      &       sinphi/sinthet*costhet*costhet_grad(j)
10924      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10925      &       )*wshield
10926
10927        grad_shield_loc(j,ishield_list(i),i)=
10928      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10929      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10930      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10931      &        ))
10932      &        *wshield
10933       enddo
10934       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10935       enddo
10936       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10937 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10938 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10939       enddo
10940       return
10941       end
10942 C--------------------------------------------------------------------------
10943       double precision function tschebyshev(m,n,x,y)
10944       implicit none
10945       include "DIMENSIONS"
10946       integer i,m,n
10947       double precision x(n),y,yy(0:maxvar),aux
10948 c Tschebyshev polynomial. Note that the first term is omitted
10949 c m=0: the constant term is included
10950 c m=1: the constant term is not included
10951       yy(0)=1.0d0
10952       yy(1)=y
10953       do i=2,n
10954         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10955       enddo
10956       aux=0.0d0
10957       do i=m,n
10958         aux=aux+x(i)*yy(i)
10959       enddo
10960       tschebyshev=aux
10961       return
10962       end
10963 C--------------------------------------------------------------------------
10964       double precision function gradtschebyshev(m,n,x,y)
10965       implicit none
10966       include "DIMENSIONS"
10967       integer i,m,n
10968       double precision x(n+1),y,yy(0:maxvar),aux
10969 c Tschebyshev polynomial. Note that the first term is omitted
10970 c m=0: the constant term is included
10971 c m=1: the constant term is not included
10972       yy(0)=1.0d0
10973       yy(1)=2.0d0*y
10974       do i=2,n
10975         yy(i)=2*y*yy(i-1)-yy(i-2)
10976       enddo
10977       aux=0.0d0
10978       do i=m,n
10979         aux=aux+x(i+1)*yy(i)*(i+1)
10980 C        print *, x(i+1),yy(i),i
10981       enddo
10982       gradtschebyshev=aux
10983       return
10984       end
10985