source/maxlik/src-Fmatch_safe/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       include "COMMON.NAMES"
  26 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 c      call flush(iout)
  28 cd    print *,'nnt=',nnt,' nct=',nct
  29 C
  30 C Compute the side-chain and electrostatic interaction energy
  31 C
  32       gloc_compon=0.0d0
  33       gcompon=0.0d0
  34       goto (101,102,103,104,105,106) ipot
  35 C Lennard-Jones potential.
  36   101 call elj(evdw)
  37 cd    print '(a)','Exit ELJ'
  38       goto 107
  39 C Lennard-Jones-Kihara potential (shifted).
  40   102 call eljk(evdw)
  41       goto 107
  42 C Berne-Pechukas potential (dilated LJ, angular dependence).
  43   103 call ebp(evdw)
  44       goto 107
  45 C Gay-Berne potential (shifted LJ, angular dependence).
  46   104 call egb(evdw)
  47       goto 107
  48 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  49   105 call egbv(evdw)
  50       goto 107
  51 C New SC-SC potential
  52   106 call emomo(evdw,evdw_p,evdw_m)
  53 C
  54 C Calculate electrostatic (H-bonding) energy of the main chain.
  55 C
  56   107 continue
  57       call vec_and_deriv
  58       if (shield_mode.eq.1) then
  59        call set_shield_fac
  60       else if  (shield_mode.eq.2) then
  61        call set_shield_fac2
  62       endif
  63       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  64 C            write(iout,*) 'po eelec'
  65
  66 C Calculate excluded-volume interaction energy between peptide groups
  67 C and side chains.
  68 C
  69       call escp(evdw2,evdw2_14)
  70 c
  71 c Calculate the bond-stretching energy
  72 c
  73
  74       call ebond(estr)
  75 C       write (iout,*) "estr",estr
  76 C
  77 C Calculate the disulfide-bridge and other energy and the contributions
  78 C from other distance constraints.
  79 cd    print *,'Calling EHPB'
  80       call edis(ehpb)
  81 cd    print *,'EHPB exitted succesfully.'
  82 C
  83 C Calculate the virtual-bond-angle energy.
  84 C
  85 C      print *,'Bend energy finished.'
  86       if (wang.gt.0d0) then
  87        if (tor_mode.eq.0) then
  88          call ebend(ebe)
  89        else
  90 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  91 C energy function
  92          call ebend_kcc(ebe)
  93        endif
  94       else
  95         ebe=0.0d0
  96       endif
  97       ethetacnstr=0.0d0
  98       if (with_theta_constr) call etheta_constr(ethetacnstr)
  99 c      call ebend(ebe,ethetacnstr)
 100 cd    print *,'Bend energy finished.'
 101 C
 102 C Calculate the SC local energy.
 103 C
 104       call esc(escloc)
 105 C       print *,'SCLOC energy finished.'
 106 C
 107 C Calculate the virtual-bond torsional energy.
 108 C
 109       if (wtor.gt.0.0d0) then
 110          if (tor_mode.eq.0) then
 111            call etor(etors)
 112          else
 113 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 114 C energy function
 115            call etor_kcc(etors)
 116          endif
 117       else
 118         etors=0.0d0
 119       endif
 120       edihcnstr=0.0d0
 121       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 122 c      print *,"Processor",myrank," computed Utor"
 123 C
 124 C 6/23/01 Calculate double-torsional energy
 125 C
 126       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 127         call etor_d(etors_d)
 128       else
 129         etors_d=0
 130       endif
 131 c      print *,"Processor",myrank," computed Utord"
 132 C
 133       call eback_sc_corr(esccor)
 134
 135       eliptran=0.0d0
 136       if (wliptran.gt.0) then
 137         call Eliptransfer(eliptran)
 138       endif
 139
 140 C
 141 C 12/1/95 Multi-body terms
 142 C
 143       n_corr=0
 144       n_corr1=0
 145       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 146      &    .or. wturn6.gt.0.0d0) then
 147 c         write(iout,*)"calling multibody_eello"
 148          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 149 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 150 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 151       else
 152          ecorr=0.0d0
 153          ecorr5=0.0d0
 154          ecorr6=0.0d0
 155          eturn6=0.0d0
 156       endif
 157       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 158 c         write (iout,*) "Calling multibody_hbond"
 159          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 160       endif
 161 #ifdef SPLITELE
 162       if (shield_mode.gt.0) then
 163       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 164      & +welec*ees
 165      & +wvdwpp*evdw1
 166      & +wang*ebe+wtor*etors+wscloc*escloc
 167      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 168      & +wcorr6*ecorr6+wturn4*eello_turn4
 169      & +wturn3*eello_turn3+wturn6*eturn6
 170      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 171      & +wbond*estr+wsccor*esccor+ethetacnstr
 172      & +wliptran*eliptran
 173       else
 174       etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees
 175      & +wvdwpp*evdw1
 176      & +wang*ebe+wtor*etors+wscloc*escloc
 177      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 178      & +wcorr6*ecorr6+wturn4*eello_turn4
 179      & +wturn3*eello_turn3+wturn6*eturn6
 180      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 181      & +wbond*estr+wsccor*esccor+ethetacnstr
 182      & +wliptran*eliptran
 183       endif
 184 #else
 185       if (shield_mode.gt.0) then
 186       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 187      & +welec*(ees+evdw1)
 188      & +wang*ebe+wtor*etors+wscloc*escloc
 189      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 190      & +wcorr6*ecorr6+wturn4*eello_turn4
 191      & +wturn3*eello_turn3+wturn6*eturn6
 192      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 193      & +wbond*estr+wsccor*esccor+ethetacnstr
 194      & +wliptran*eliptran
 195       else
 196       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 197      & +welec*(ees+evdw1)
 198      & +wang*ebe+wtor*etors+wscloc*escloc
 199      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 200      & +wcorr6*ecorr6+wturn4*eello_turn4
 201      & +wturn3*eello_turn3+wturn6*eturn6
 202      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 203      & +wbond*estr+wsccor*esccor+ethetacnstr
 204      & +wliptran*eliptran
 205       endif
 206 #endif
 207       energia(0)=etot
 208       energia(1)=evdw
 209 #ifdef SCP14
 210       energia(2)=evdw2-evdw2_14
 211       energia(17)=evdw2_14
 212 #else
 213       energia(2)=evdw2
 214       energia(17)=0.0d0
 215 #endif
 216 #ifdef SPLITELE
 217       energia(3)=ees
 218       energia(16)=evdw1
 219 #else
 220       energia(3)=ees+evdw1
 221       energia(16)=0.0d0
 222 #endif
 223       energia(4)=ecorr
 224       energia(5)=ecorr5
 225       energia(6)=ecorr6
 226       energia(7)=eel_loc
 227       energia(8)=eello_turn3
 228       energia(9)=eello_turn4
 229       energia(10)=eturn6
 230       energia(11)=ebe
 231       energia(12)=escloc
 232       energia(13)=etors
 233       energia(14)=etors_d
 234       energia(15)=ehpb
 235       energia(17)=estr
 236       energia(19)=esccor
 237       energia(20)=edihcnstr
 238       energia(21)=evdw_t
 239       energia(24)=ethetacnstr
 240       energia(22)=eliptran
 241 c detecting NaNQ
 242 #ifdef ISNAN
 243 #ifdef AIX
 244       if (isnan(etot).ne.0) energia(0)=1.0d+99
 245 #else
 246       if (isnan(etot)) energia(0)=1.0d+99
 247 #endif
 248 #else
 249       i=0
 250 #ifdef WINPGI
 251       idumm=proc_proc(etot,i)
 252 #else
 253       call proc_proc(etot,i)
 254 #endif
 255       if(i.eq.1)energia(0)=1.0d+99
 256 #endif
 257 #ifdef MPL
 258 c     endif
 259 #endif
 260 #ifdef DEBUG
 261       call enerprint(energia)
 262 #endif
 263 c      if (dyn_ss) call dyn_set_nss
 264       return
 265       end
 266 C------------------------------------------------------------------------
 267       subroutine enerprint(energia)
 268       implicit real*8 (a-h,o-z)
 269       include 'DIMENSIONS'
 270       include 'DIMENSIONS.ZSCOPT'
 271       include 'COMMON.IOUNITS'
 272       include 'COMMON.FFIELD'
 273       include 'COMMON.SBRIDGE'
 274       double precision energia(0:max_ene)
 275       etot=energia(0)
 276       evdw=energia(1)+energia(21)
 277 #ifdef SCP14
 278       evdw2=energia(2)+energia(17)
 279 #else
 280       evdw2=energia(2)
 281 #endif
 282       ees=energia(3)
 283 #ifdef SPLITELE
 284       evdw1=energia(16)
 285 #endif
 286       ecorr=energia(4)
 287       ecorr5=energia(5)
 288       ecorr6=energia(6)
 289       eel_loc=energia(7)
 290       eello_turn3=energia(8)
 291       eello_turn4=energia(9)
 292       eello_turn6=energia(10)
 293       ebe=energia(11)
 294       escloc=energia(12)
 295       etors=energia(13)
 296       etors_d=energia(14)
 297       ehpb=energia(15)
 298       esccor=energia(19)
 299       edihcnstr=energia(20)
 300       estr=energia(17)
 301       ethetacnstr=energia(24)
 302       eliptran=energia(22)
 303 #ifdef SPLITELE
 304       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,
 305      &  wvdwpp,
 306      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor,
 307      &  etors_d,wtor_d,ehpb,wstrain,
 308      &  ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6,
 309      &  eel_loc,wel_loc,eello_turn3,wturn3,
 310      &  eello_turn4,wturn4,eello_turn6,wturn6,
 311      &  esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss,
 312      & eliptran,wliptran,etot
 313    10 format (/'Virtual-chain energies:'//
 314      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 315      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 316      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 317      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 318      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 319      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 320      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 321      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 322      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 323      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 324      & ' (SS bridges & dist. cnstr.)'/
 325      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 326      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 327      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 328      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 329      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 330      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 331      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 332      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 333      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 334      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 335      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 336      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 337      & 'ETOT=  ',1pE16.6,' (total)')
 338 #else
 339       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,
 340      &  ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d,
 341      &  ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5,
 342      &  ecorr6,wcorr6,eel_loc,wel_loc,
 343      &  eello_turn3,wturn3,eello_turn4,wturn4,
 344      &  eello_turn6,wturn6,esccor,wsccor,
 345      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 346    10 format (/'Virtual-chain energies:'//
 347      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 348      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 349      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 350      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 351      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 352      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 353      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 354      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 355      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 356      & ' (SS bridges & dist. cnstr.)'/
 357      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 358      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 359      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 360      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 361      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 362      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 363      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 364      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 365      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 366      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 367      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 368      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 369      & 'ETOT=  ',1pE16.6,' (total)')
 370 #endif
 371       return
 372       end
 373 C-----------------------------------------------------------------------
 374       subroutine elj(evdw)
 375 C
 376 C This subroutine calculates the interaction energy of nonbonded side chains
 377 C assuming the LJ potential of interaction.
 378 C
 379       implicit real*8 (a-h,o-z)
 380       include 'DIMENSIONS'
 381       include 'DIMENSIONS.ZSCOPT'
 382       parameter (accur=1.0d-10)
 383       include 'COMMON.GEO'
 384       include 'COMMON.VAR'
 385       include 'COMMON.LOCAL'
 386       include 'COMMON.CHAIN'
 387       include 'COMMON.DERIV'
 388       include 'COMMON.INTERACT'
 389       include 'COMMON.TORSION'
 390       include 'COMMON.WEIGHTDER'
 391       include 'COMMON.SBRIDGE'
 392       include 'COMMON.NAMES'
 393       include 'COMMON.IOUNITS'
 394       include 'COMMON.CONTACTS'
 395       dimension gg(3)
 396       integer icant
 397       external icant
 398 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 399       do i=1,nntyp
 400         do j=1,2
 401           eneps_temp(j,i)=0.0d0
 402         enddo
 403       enddo
 404       evdw=0.0D0
 405       do i=iatsc_s,iatsc_e
 406         itypi=itype(i)
 407         itypi1=itype(i+1)
 408         xi=c(1,nres+i)
 409         yi=c(2,nres+i)
 410         zi=c(3,nres+i)
 411 C Change 12/1/95
 412         num_conti=0
 413 C
 414 C Calculate SC interaction energy.
 415 C
 416         do iint=1,nint_gr(i)
 417 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 418 cd   &                  'iend=',iend(i,iint)
 419           do j=istart(i,iint),iend(i,iint)
 420             itypj=itype(j)
 421             xj=c(1,nres+j)-xi
 422             yj=c(2,nres+j)-yi
 423             zj=c(3,nres+j)-zi
 424 C Change 12/1/95 to calculate four-body interactions
 425             rij=xj*xj+yj*yj+zj*zj
 426             rrij=1.0D0/rij
 427 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 428             eps0ij=eps(itypi,itypj)
 429             fac=rrij**expon2
 430             e1=fac*fac*aa(itypi,itypj)
 431             e2=fac*bb(itypi,itypj)
 432             evdwij=e1+e2
 433             ij=icant(itypi,itypj)
 434             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 435             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 436 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 437 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 438 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 439 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 440 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 441 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 442             evdw=evdw+evdwij
 443             if (calc_grad) then
 444 C
 445 C Calculate the components of the gradient in DC and X
 446 C
 447             fac=-rrij*(e1+evdwij)
 448             gg(1)=xj*fac
 449             gg(2)=yj*fac
 450             gg(3)=zj*fac
 451             do k=1,3
 452               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 453               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 454             enddo
 455 c            do k=i,j-1
 456 c              do l=1,3
 457 c                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 458 c              enddo
 459 c            enddo
 460             endif
 461 C
 462 C 12/1/95, revised on 5/20/97
 463 C
 464 C Calculate the contact function. The ith column of the array JCONT will
 465 C contain the numbers of atoms that make contacts with the atom I (of numbers
 466 C greater than I). The arrays FACONT and GACONT will contain the values of
 467 C the contact function and its derivative.
 468 C
 469 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 470 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 471 C Uncomment next line, if the correlation interactions are contact function only
 472             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 473               rij=dsqrt(rij)
 474               sigij=sigma(itypi,itypj)
 475               r0ij=rs0(itypi,itypj)
 476 C
 477 C Check whether the SC's are not too far to make a contact.
 478 C
 479               rcut=1.5d0*r0ij
 480               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 481 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 482 C
 483               if (fcont.gt.0.0D0) then
 484 C If the SC-SC distance if close to sigma, apply spline.
 485 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 486 cAdam &             fcont1,fprimcont1)
 487 cAdam           fcont1=1.0d0-fcont1
 488 cAdam           if (fcont1.gt.0.0d0) then
 489 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 490 cAdam             fcont=fcont*fcont1
 491 cAdam           endif
 492 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 493 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 494 cga             do k=1,3
 495 cga               gg(k)=gg(k)*eps0ij
 496 cga             enddo
 497 cga             eps0ij=-evdwij*eps0ij
 498 C Uncomment for AL's type of SC correlation interactions.
 499 cadam           eps0ij=-evdwij
 500                 num_conti=num_conti+1
 501                 jcont(num_conti,i)=j
 502                 facont(num_conti,i)=fcont*eps0ij
 503                 fprimcont=eps0ij*fprimcont/rij
 504                 fcont=expon*fcont
 505 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 506 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 507 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 508 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 509                 gacont(1,num_conti,i)=-fprimcont*xj
 510                 gacont(2,num_conti,i)=-fprimcont*yj
 511                 gacont(3,num_conti,i)=-fprimcont*zj
 512 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 513 cd              write (iout,'(2i3,3f10.5)')
 514 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 515               endif
 516             endif
 517           enddo      ! j
 518         enddo        ! iint
 519 C Change 12/1/95
 520         num_cont(i)=num_conti
 521       enddo          ! i
 522       if (calc_grad) then
 523       do i=1,nct
 524         do j=1,3
 525           gvdwc(j,i)=expon*gvdwc(j,i)
 526           gvdwx(j,i)=expon*gvdwx(j,i)
 527         enddo
 528       enddo
 529       endif
 530 C******************************************************************************
 531 C
 532 C                              N O T E !!!
 533 C
 534 C To save time, the factor of EXPON has been extracted from ALL components
 535 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 536 C use!
 537 C
 538 C******************************************************************************
 539       return
 540       end
 541 C-----------------------------------------------------------------------------
 542       subroutine eljk(evdw)
 543 C
 544 C This subroutine calculates the interaction energy of nonbonded side chains
 545 C assuming the LJK potential of interaction.
 546 C
 547       implicit real*8 (a-h,o-z)
 548       include 'DIMENSIONS'
 549       include 'DIMENSIONS.ZSCOPT'
 550       include 'COMMON.GEO'
 551       include 'COMMON.VAR'
 552       include 'COMMON.LOCAL'
 553       include 'COMMON.CHAIN'
 554       include 'COMMON.DERIV'
 555       include 'COMMON.INTERACT'
 556       include 'COMMON.WEIGHTDER'
 557       include 'COMMON.IOUNITS'
 558       include 'COMMON.NAMES'
 559       dimension gg(3)
 560       logical scheck
 561       integer icant
 562       external icant
 563 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 564       do i=1,nntyp
 565         do j=1,2
 566           eneps_temp(j,i)=0.0d0
 567         enddo
 568       enddo
 569       evdw=0.0D0
 570       do i=iatsc_s,iatsc_e
 571         itypi=itype(i)
 572         itypi1=itype(i+1)
 573         xi=c(1,nres+i)
 574         yi=c(2,nres+i)
 575         zi=c(3,nres+i)
 576 C
 577 C Calculate SC interaction energy.
 578 C
 579         do iint=1,nint_gr(i)
 580           do j=istart(i,iint),iend(i,iint)
 581             itypj=itype(j)
 582             xj=c(1,nres+j)-xi
 583             yj=c(2,nres+j)-yi
 584             zj=c(3,nres+j)-zi
 585             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 586             fac_augm=rrij**expon
 587             e_augm=augm(itypi,itypj)*fac_augm
 588             r_inv_ij=dsqrt(rrij)
 589             rij=1.0D0/r_inv_ij
 590             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 591             fac=r_shift_inv**expon
 592             e1=fac*fac*aa(itypi,itypj)
 593             e2=fac*bb(itypi,itypj)
 594             evdwij=e_augm+e1+e2
 595             ij=icant(itypi,itypj)
 596             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 597      &        /dabs(eps(itypi,itypj))
 598             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 599 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 600 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 601 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 602 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 603 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 604 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 605 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 606             evdw=evdw+evdwij
 607             if (calc_grad) then
 608 C
 609 C Calculate the components of the gradient in DC and X
 610 C
 611             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 612             gg(1)=xj*fac
 613             gg(2)=yj*fac
 614             gg(3)=zj*fac
 615             do k=1,3
 616               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 617               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 618             enddo
 619 c            do k=i,j-1
 620 c              do l=1,3
 621 c                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 622 c              enddo
 623 c            enddo
 624             endif
 625           enddo      ! j
 626         enddo        ! iint
 627       enddo          ! i
 628       if (calc_grad) then
 629       do i=1,nct
 630         do j=1,3
 631           gvdwc(j,i)=expon*gvdwc(j,i)
 632           gvdwx(j,i)=expon*gvdwx(j,i)
 633         enddo
 634       enddo
 635       endif
 636       return
 637       end
 638 C-----------------------------------------------------------------------------
 639       subroutine ebp(evdw)
 640 C
 641 C This subroutine calculates the interaction energy of nonbonded side chains
 642 C assuming the Berne-Pechukas potential of interaction.
 643 C
 644       implicit real*8 (a-h,o-z)
 645       include 'DIMENSIONS'
 646       include 'DIMENSIONS.ZSCOPT'
 647       include 'COMMON.GEO'
 648       include 'COMMON.VAR'
 649       include 'COMMON.LOCAL'
 650       include 'COMMON.CHAIN'
 651       include 'COMMON.DERIV'
 652       include 'COMMON.NAMES'
 653       include 'COMMON.INTERACT'
 654       include 'COMMON.WEIGHTDER'
 655       include 'COMMON.IOUNITS'
 656       include 'COMMON.CALC'
 657       common /srutu/ icall
 658 c     double precision rrsave(maxdim)
 659       logical lprn
 660       integer icant
 661       external icant
 662       do i=1,nntyp
 663         do j=1,2
 664           eneps_temp(j,i)=0.0d0
 665         enddo
 666       enddo
 667       evdw=0.0D0
 668 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 669       evdw=0.0D0
 670 c     if (icall.eq.0) then
 671 c       lprn=.true.
 672 c     else
 673         lprn=.false.
 674 c     endif
 675       ind=0
 676       do i=iatsc_s,iatsc_e
 677         itypi=itype(i)
 678         itypi1=itype(i+1)
 679         xi=c(1,nres+i)
 680         yi=c(2,nres+i)
 681         zi=c(3,nres+i)
 682         dxi=dc_norm(1,nres+i)
 683         dyi=dc_norm(2,nres+i)
 684         dzi=dc_norm(3,nres+i)
 685         dsci_inv=vbld_inv(i+nres)
 686 C
 687 C Calculate SC interaction energy.
 688 C
 689         do iint=1,nint_gr(i)
 690           do j=istart(i,iint),iend(i,iint)
 691             ind=ind+1
 692             itypj=itype(j)
 693             dscj_inv=vbld_inv(j+nres)
 694             chi1=chi(itypi,itypj)
 695             chi2=chi(itypj,itypi)
 696             chi12=chi1*chi2
 697             chip1=chip(itypi)
 698             chip2=chip(itypj)
 699             chip12=chip1*chip2
 700             alf1=alp(itypi)
 701             alf2=alp(itypj)
 702             alf12=0.5D0*(alf1+alf2)
 703 C For diagnostics only!!!
 704 c           chi1=0.0D0
 705 c           chi2=0.0D0
 706 c           chi12=0.0D0
 707 c           chip1=0.0D0
 708 c           chip2=0.0D0
 709 c           chip12=0.0D0
 710 c           alf1=0.0D0
 711 c           alf2=0.0D0
 712 c           alf12=0.0D0
 713             xj=c(1,nres+j)-xi
 714             yj=c(2,nres+j)-yi
 715             zj=c(3,nres+j)-zi
 716             dxj=dc_norm(1,nres+j)
 717             dyj=dc_norm(2,nres+j)
 718             dzj=dc_norm(3,nres+j)
 719             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 720 cd          if (icall.eq.0) then
 721 cd            rrsave(ind)=rrij
 722 cd          else
 723 cd            rrij=rrsave(ind)
 724 cd          endif
 725             rij=dsqrt(rrij)
 726 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 727             call sc_angular
 728 C Calculate whole angle-dependent part of epsilon and contributions
 729 C to its derivatives
 730             fac=(rrij*sigsq)**expon2
 731             e1=fac*fac*aa(itypi,itypj)
 732             e2=fac*bb(itypi,itypj)
 733             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 734             eps2der=evdwij*eps3rt
 735             eps3der=evdwij*eps2rt
 736             evdwij=evdwij*eps2rt*eps3rt
 737             ij=icant(itypi,itypj)
 738             aux=eps1*eps2rt**2*eps3rt**2
 739             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 740      &        /dabs(eps(itypi,itypj))
 741             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 742             evdw=evdw+evdwij
 743             if (calc_grad) then
 744             if (lprn) then
 745             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 746             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 747 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 748 cd     &        restyp(itypi),i,restyp(itypj),j,
 749 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 750 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 751 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 752 cd     &        evdwij
 753             endif
 754 C Calculate gradient components.
 755             e1=e1*eps1*eps2rt**2*eps3rt**2
 756             fac=-expon*(e1+evdwij)
 757             sigder=fac/sigsq
 758             fac=rrij*fac
 759 C Calculate radial part of the gradient
 760             gg(1)=xj*fac
 761             gg(2)=yj*fac
 762             gg(3)=zj*fac
 763 C Calculate the angular part of the gradient and sum add the contributions
 764 C to the appropriate components of the Cartesian gradient.
 765             call sc_grad
 766             endif
 767           enddo      ! j
 768         enddo        ! iint
 769       enddo          ! i
 770 c     stop
 771       return
 772       end
 773 C-----------------------------------------------------------------------------
 774       subroutine egb(evdw)
 775 C
 776 C This subroutine calculates the interaction energy of nonbonded side chains
 777 C assuming the Gay-Berne potential of interaction.
 778 C
 779       implicit real*8 (a-h,o-z)
 780       include 'DIMENSIONS'
 781       include 'DIMENSIONS.ZSCOPT'
 782       include 'COMMON.GEO'
 783       include 'COMMON.VAR'
 784       include 'COMMON.LOCAL'
 785       include 'COMMON.CHAIN'
 786       include 'COMMON.DERIV'
 787       include 'COMMON.NAMES'
 788       include 'COMMON.INTERACT'
 789       include 'COMMON.WEIGHTDER'
 790       include 'COMMON.IOUNITS'
 791       include 'COMMON.CALC'
 792       logical lprn
 793       common /srutu/icall
 794       integer icant
 795       external icant
 796       do i=1,nntyp
 797         do j=1,2
 798           eneps_temp(j,i)=0.0d0
 799         enddo
 800       enddo
 801       evdw=0.0D0
 802 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 803       evdw=0.0D0
 804       lprn=.false.
 805 c      if (icall.gt.0) lprn=.true.
 806       ind=0
 807       do i=iatsc_s,iatsc_e
 808         itypi=itype(i)
 809         itypi1=itype(i+1)
 810         xi=c(1,nres+i)
 811         yi=c(2,nres+i)
 812         zi=c(3,nres+i)
 813         dxi=dc_norm(1,nres+i)
 814         dyi=dc_norm(2,nres+i)
 815         dzi=dc_norm(3,nres+i)
 816         dsci_inv=vbld_inv(i+nres)
 817 C
 818 C Calculate SC interaction energy.
 819 C
 820         do iint=1,nint_gr(i)
 821           do j=istart(i,iint),iend(i,iint)
 822             ind=ind+1
 823             itypj=itype(j)
 824             dscj_inv=vbld_inv(j+nres)
 825             sig0ij=sigma(itypi,itypj)
 826             chi1=chi(itypi,itypj)
 827             chi2=chi(itypj,itypi)
 828             chi12=chi1*chi2
 829             chip1=chip(itypi)
 830             chip2=chip(itypj)
 831             chip12=chip1*chip2
 832             alf1=alp(itypi)
 833             alf2=alp(itypj)
 834             alf12=0.5D0*(alf1+alf2)
 835 C For diagnostics only!!!
 836 c           chi1=0.0D0
 837 c           chi2=0.0D0
 838 c           chi12=0.0D0
 839 c           chip1=0.0D0
 840 c           chip2=0.0D0
 841 c           chip12=0.0D0
 842 c           alf1=0.0D0
 843 c           alf2=0.0D0
 844 c           alf12=0.0D0
 845             xj=c(1,nres+j)-xi
 846             yj=c(2,nres+j)-yi
 847             zj=c(3,nres+j)-zi
 848             dxj=dc_norm(1,nres+j)
 849             dyj=dc_norm(2,nres+j)
 850             dzj=dc_norm(3,nres+j)
 851 c            write (iout,*) i,j,xj,yj,zj
 852             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 853             rij=dsqrt(rrij)
 854 C Calculate angle-dependent terms of energy and contributions to their
 855 C derivatives.
 856             call sc_angular
 857             sigsq=1.0D0/sigsq
 858             sig=sig0ij*dsqrt(sigsq)
 859             rij_shift=1.0D0/rij-sig+sig0ij
 860 C I hate to put IF's in the loops, but here don't have another choice!!!!
 861             if (rij_shift.le.0.0D0) then
 862               evdw=1.0D20
 863               return
 864             endif
 865             sigder=-sig*sigsq
 866 c---------------------------------------------------------------
 867             rij_shift=1.0D0/rij_shift
 868             fac=rij_shift**expon
 869             e1=fac*fac*aa(itypi,itypj)
 870             e2=fac*bb(itypi,itypj)
 871             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 872             eps2der=evdwij*eps3rt
 873             eps3der=evdwij*eps2rt
 874             evdwij=evdwij*eps2rt*eps3rt
 875             evdw=evdw+evdwij
 876             ij=icant(itypi,itypj)
 877             aux=eps1*eps2rt**2*eps3rt**2
 878 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 879 c     &        /dabs(eps(itypi,itypj))
 880 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 881 c-----------------------
 882             eps0ij=eps(itypi,itypj)
 883             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
 884             rr0ij=r0(itypi,itypj)
 885             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
 886 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
 887 c-----------------------
 888 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 889 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 890 c     &         aux*e2/eps(itypi,itypj)
 891             if (lprn) then
 892             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 893             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 894             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 895      &        restyp(itypi),i,restyp(itypj),j,
 896      &        epsi,sigm,chi1,chi2,chip1,chip2,
 897      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 898      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 899      &        evdwij
 900             endif
 901             if (calc_grad) then
 902 C Calculate gradient components.
 903             e1=e1*eps1*eps2rt**2*eps3rt**2
 904             fac=-expon*(e1+evdwij)*rij_shift
 905             sigder=fac*sigder
 906             fac=rij*fac
 907 C Calculate the radial part of the gradient
 908             gg(1)=xj*fac
 909             gg(2)=yj*fac
 910             gg(3)=zj*fac
 911 C Calculate angular part of the gradient.
 912             call sc_grad
 913             endif
 914           enddo      ! j
 915         enddo        ! iint
 916       enddo          ! i
 917       return
 918       end
 919 C-----------------------------------------------------------------------------
 920       subroutine egbv(evdw)
 921 C
 922 C This subroutine calculates the interaction energy of nonbonded side chains
 923 C assuming the Gay-Berne-Vorobjev potential of interaction.
 924 C
 925       implicit real*8 (a-h,o-z)
 926       include 'DIMENSIONS'
 927       include 'DIMENSIONS.ZSCOPT'
 928       include 'COMMON.GEO'
 929       include 'COMMON.VAR'
 930       include 'COMMON.LOCAL'
 931       include 'COMMON.CHAIN'
 932       include 'COMMON.DERIV'
 933       include 'COMMON.NAMES'
 934       include 'COMMON.INTERACT'
 935       include 'COMMON.WEIGHTDER'
 936       include 'COMMON.IOUNITS'
 937       include 'COMMON.CALC'
 938       common /srutu/ icall
 939       logical lprn
 940       integer icant
 941       external icant
 942       do i=1,nntyp
 943         do j=1,2
 944           eneps_temp(j,i)=0.0d0
 945         enddo
 946       enddo
 947       evdw=0.0D0
 948 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 949       evdw=0.0D0
 950       lprn=.false.
 951 c      if (icall.gt.0) lprn=.true.
 952       ind=0
 953       do i=iatsc_s,iatsc_e
 954         itypi=itype(i)
 955         itypi1=itype(i+1)
 956         xi=c(1,nres+i)
 957         yi=c(2,nres+i)
 958         zi=c(3,nres+i)
 959         dxi=dc_norm(1,nres+i)
 960         dyi=dc_norm(2,nres+i)
 961         dzi=dc_norm(3,nres+i)
 962         dsci_inv=vbld_inv(i+nres)
 963 C
 964 C Calculate SC interaction energy.
 965 C
 966         do iint=1,nint_gr(i)
 967           do j=istart(i,iint),iend(i,iint)
 968             ind=ind+1
 969             itypj=itype(j)
 970             dscj_inv=vbld_inv(j+nres)
 971             sig0ij=sigma(itypi,itypj)
 972             r0ij=r0(itypi,itypj)
 973             chi1=chi(itypi,itypj)
 974             chi2=chi(itypj,itypi)
 975             chi12=chi1*chi2
 976             chip1=chip(itypi)
 977             chip2=chip(itypj)
 978             chip12=chip1*chip2
 979             alf1=alp(itypi)
 980             alf2=alp(itypj)
 981             alf12=0.5D0*(alf1+alf2)
 982 C For diagnostics only!!!
 983 c           chi1=0.0D0
 984 c           chi2=0.0D0
 985 c           chi12=0.0D0
 986 c           chip1=0.0D0
 987 c           chip2=0.0D0
 988 c           chip12=0.0D0
 989 c           alf1=0.0D0
 990 c           alf2=0.0D0
 991 c           alf12=0.0D0
 992             xj=c(1,nres+j)-xi
 993             yj=c(2,nres+j)-yi
 994             zj=c(3,nres+j)-zi
 995             dxj=dc_norm(1,nres+j)
 996             dyj=dc_norm(2,nres+j)
 997             dzj=dc_norm(3,nres+j)
 998             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 999             rij=dsqrt(rrij)
1000 C Calculate angle-dependent terms of energy and contributions to their
1001 C derivatives.
1002             call sc_angular
1003             sigsq=1.0D0/sigsq
1004             sig=sig0ij*dsqrt(sigsq)
1005             rij_shift=1.0D0/rij-sig+r0ij
1006 C I hate to put IF's in the loops, but here don't have another choice!!!!
1007             if (rij_shift.le.0.0D0) then
1008               evdw=1.0D20
1009               return
1010             endif
1011             sigder=-sig*sigsq
1012 c---------------------------------------------------------------
1013             rij_shift=1.0D0/rij_shift
1014             fac=rij_shift**expon
1015             e1=fac*fac*aa(itypi,itypj)
1016             e2=fac*bb(itypi,itypj)
1017             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1018             eps2der=evdwij*eps3rt
1019             eps3der=evdwij*eps2rt
1020             fac_augm=rrij**expon
1021             e_augm=augm(itypi,itypj)*fac_augm
1022             evdwij=evdwij*eps2rt*eps3rt
1023             evdw=evdw+evdwij+e_augm
1024             ij=icant(itypi,itypj)
1025             aux=eps1*eps2rt**2*eps3rt**2
1026             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1027      &        /dabs(eps(itypi,itypj))
1028             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1029 c            eneps_temp(ij)=eneps_temp(ij)
1030 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1031 c            if (lprn) then
1032 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1033 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1034 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1035 c     &        restyp(itypi),i,restyp(itypj),j,
1036 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1037 c     &        chi1,chi2,chip1,chip2,
1038 c     &        eps1,eps2rt**2,eps3rt**2,
1039 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1040 c     &        evdwij+e_augm
1041 c            endif
1042             if (calc_grad) then
1043 C Calculate gradient components.
1044             e1=e1*eps1*eps2rt**2*eps3rt**2
1045             fac=-expon*(e1+evdwij)*rij_shift
1046             sigder=fac*sigder
1047             fac=rij*fac-2*expon*rrij*e_augm
1048 C Calculate the radial part of the gradient
1049             gg(1)=xj*fac
1050             gg(2)=yj*fac
1051             gg(3)=zj*fac
1052 C Calculate angular part of the gradient.
1053             call sc_grad
1054             endif
1055           enddo      ! j
1056         enddo        ! iint
1057       enddo          ! i
1058       return
1059       end
1060 C-----------------------------------------------------------------------------
1061       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1062 C
1063 C This subroutine calculates the interaction energy of nonbonded side chains
1064 C assuming the Gay-Berne potential of interaction.
1065 C
1066        IMPLICIT NONE
1067        INCLUDE 'DIMENSIONS'
1068        INCLUDE 'DIMENSIONS.ZSCOPT'
1069        INCLUDE 'COMMON.CALC'
1070        INCLUDE 'COMMON.CONTROL'
1071        INCLUDE 'COMMON.CHAIN'
1072        INCLUDE 'COMMON.DERIV'
1073        INCLUDE 'COMMON.EMP'
1074        INCLUDE 'COMMON.GEO'
1075        INCLUDE 'COMMON.INTERACT'
1076        INCLUDE 'COMMON.IOUNITS'
1077        INCLUDE 'COMMON.LOCAL'
1078        INCLUDE 'COMMON.NAMES'
1079        INCLUDE 'COMMON.VAR'
1080        INCLUDE 'COMMON.WEIGHTDER'
1081        logical lprn
1082        double precision scalar
1083        double precision ener(4)
1084        integer troll
1085        integer iint,ij
1086        integer icant
1087
1088        energy_dec=.false.
1089        IF (energy_dec) write (iout,'(a)')
1090      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1091      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1092        evdw   = 0.0D0
1093        evdw_p = 0.0D0
1094        evdw_m = 0.0D0
1095 c DIAGNOSTICS
1096 ccccc      energy_dec=.false.
1097 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1098 c      lprn   = .false.
1099 c     if (icall.eq.0) lprn=.false.
1100 c END DIAGNOSTICS
1101 c      ind = 0
1102        DO i = iatsc_s, iatsc_e
1103         itypi  = itype(i)
1104 c        itypi1 = itype(i+1)
1105         dxi    = dc_norm(1,nres+i)
1106         dyi    = dc_norm(2,nres+i)
1107         dzi    = dc_norm(3,nres+i)
1108 c        dsci_inv=dsc_inv(itypi)
1109         dsci_inv = vbld_inv(i+nres)
1110 c        DO k = 1, 3
1111 c         ctail(k,1) = c(k, i+nres)
1112 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1113 c        END DO
1114         xi=c(1,nres+i)
1115         yi=c(2,nres+i)
1116         zi=c(3,nres+i)
1117 c!-------------------------------------------------------------------
1118 C Calculate SC interaction energy.
1119         DO iint = 1, nint_gr(i)
1120          DO j = istart(i,iint), iend(i,iint)
1121 c! initialize variables for electrostatic gradients
1122           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1123 c            ind=ind+1
1124 c            dscj_inv = dsc_inv(itypj)
1125           dscj_inv = vbld_inv(j+nres)
1126 c! rij holds 1/(distance of Calpha atoms)
1127           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1128           rij  = dsqrt(rrij)
1129 c!-------------------------------------------------------------------
1130 C Calculate angle-dependent terms of energy and contributions to their
1131 C derivatives.
1132
1133 #ifdef CHECK_MOMO
1134 c!      DO troll = 10, 5000
1135 c!      om1    = 0.0d0
1136 c!      om2    = 0.0d0
1137 c!      om12   = 1.0d0
1138 c!      sqom1  = om1 * om1
1139 c!      sqom2  = om2 * om2
1140 c!      sqom12 = om12 * om12
1141 c!      rij    = 5.0d0 / troll
1142 c!      rrij   = rij * rij
1143 c!      Rtail  = troll / 5.0d0
1144 c!      Rhead  = troll / 5.0d0
1145 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1146 c!      Rtail = dsqrt((Rtail**2)
1147 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1148 c!      rij = 1.0d0/Rtail
1149 c!      rrij = rij * rij
1150 #endif
1151           CALL sc_angular
1152 c! this should be in elgrad_init but om's are calculated by sc_angular
1153 c! which in turn is used by older potentials
1154 c! which proves how tangled UNRES code is >.<
1155 c! om = omega, sqom = om^2
1156           sqom1  = om1 * om1
1157           sqom2  = om2 * om2
1158           sqom12 = om12 * om12
1159
1160 c! now we calculate EGB - Gey-Berne
1161 c! It will be summed up in evdwij and saved in evdw
1162           sigsq     = 1.0D0  / sigsq
1163           sig       = sig0ij * dsqrt(sigsq)
1164 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1165           rij_shift = Rtail - sig + sig0ij
1166           IF (rij_shift.le.0.0D0) THEN
1167            evdw = 1.0D20
1168            RETURN
1169           END IF
1170           sigder = -sig * sigsq
1171           rij_shift = 1.0D0 / rij_shift
1172           fac       = rij_shift**expon
1173           c1        = fac  * fac * aa(itypi,itypj)
1174 c!          c1        = 0.0d0
1175           c2        = fac  * bb(itypi,itypj)
1176 c!          c2        = 0.0d0
1177           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1178           eps2der   = eps3rt * evdwij
1179           eps3der   = eps2rt * evdwij
1180 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1181           evdwij    = eps2rt * eps3rt * evdwij
1182 c!      evdwij = 0.0d0
1183 c!      write (*,*) "Gey Berne = ", evdwij
1184 #ifdef TSCSC
1185           IF (bb(itypi,itypj).gt.0) THEN
1186            evdw_p = evdw_p + evdwij
1187           ELSE
1188            evdw_m = evdw_m + evdwij
1189           END IF
1190 #else
1191           evdw = evdw
1192      &         + evdwij
1193 #endif
1194 c!-------------------------------------------------------------------
1195 c! Calculate some components of GGB
1196           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1197           fac    = -expon * (c1 + evdwij) * rij_shift
1198           sigder = fac * sigder
1199 c!          fac    = rij * fac
1200 c! Calculate distance derivative
1201 c!          gg(1) = xj * fac
1202 c!          gg(2) = yj * fac
1203 c!          gg(3) = zj * fac
1204           gg(1) = fac
1205           gg(2) = fac
1206           gg(3) = fac
1207 c!      write (*,*) "gg(1) = ", gg(1)
1208 c!      write (*,*) "gg(2) = ", gg(2)
1209 c!      write (*,*) "gg(3) = ", gg(3)
1210 c! The angular derivatives of GGB are brought together in sc_grad
1211 c!-------------------------------------------------------------------
1212 c! Fcav
1213 c!
1214 c! Catch gly-gly interactions to skip calculation of something that
1215 c! does not exist
1216
1217       IF (itypi.eq.10.and.itypj.eq.10) THEN
1218        Fcav = 0.0d0
1219        dFdR = 0.0d0
1220        dCAVdOM1  = 0.0d0
1221        dCAVdOM2  = 0.0d0
1222        dCAVdOM12 = 0.0d0
1223       ELSE
1224
1225 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1226        fac = chis1 * sqom1 + chis2 * sqom2
1227      &     - 2.0d0 * chis12 * om1 * om2 * om12
1228 c! we will use pom later in Gcav, so dont mess with it!
1229        pom = 1.0d0 - chis1 * chis2 * sqom12
1230
1231        Lambf = (1.0d0 - (fac / pom))
1232        Lambf = dsqrt(Lambf)
1233
1234
1235        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1236 c!       write (*,*) "sparrow = ", sparrow
1237        Chif = Rtail * sparrow
1238        ChiLambf = Chif * Lambf
1239        eagle = dsqrt(ChiLambf)
1240        bat = ChiLambf ** 11.0d0
1241
1242        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1243        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1244        botsq = bot * bot
1245
1246 c!      write (*,*) "sig1 = ",sig1
1247 c!      write (*,*) "sig2 = ",sig2
1248 c!      write (*,*) "Rtail = ",Rtail
1249 c!      write (*,*) "sparrow = ",sparrow
1250 c!      write (*,*) "Chis1 = ", chis1
1251 c!      write (*,*) "Chis2 = ", chis2
1252 c!      write (*,*) "Chis12 = ", chis12
1253 c!      write (*,*) "om1 = ", om1
1254 c!      write (*,*) "om2 = ", om2
1255 c!      write (*,*) "om12 = ", om12
1256 c!      write (*,*) "sqom1 = ", sqom1
1257 c!      write (*,*) "sqom2 = ", sqom2
1258 c!      write (*,*) "sqom12 = ", sqom12
1259 c!      write (*,*) "Lambf = ",Lambf
1260 c!      write (*,*) "b1 = ",b1
1261 c!      write (*,*) "b2 = ",b2
1262 c!      write (*,*) "b3 = ",b3
1263 c!      write (*,*) "b4 = ",b4
1264 c!      write (*,*) "top = ",top
1265 c!      write (*,*) "bot = ",bot
1266        Fcav = top / bot
1267 c!       Fcav = 0.0d0
1268 c!      write (*,*) "Fcav = ", Fcav
1269 c!-------------------------------------------------------------------
1270 c! derivative of Fcav is Gcav...
1271 c!---------------------------------------------------
1272
1273        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1274        dbot = 12.0d0 * b4 * bat * Lambf
1275        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1276 c!       dFdR = 0.0d0
1277 c!      write (*,*) "dFcav/dR = ", dFdR
1278
1279        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1280        dbot = 12.0d0 * b4 * bat * Chif
1281        eagle = Lambf * pom
1282        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1283        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1284        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1285      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1286
1287        dFdL = ((dtop * bot - top * dbot) / botsq)
1288 c!       dFdL = 0.0d0
1289        dCAVdOM1  = dFdL * ( dFdOM1 )
1290        dCAVdOM2  = dFdL * ( dFdOM2 )
1291        dCAVdOM12 = dFdL * ( dFdOM12 )
1292 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1293 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1294 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1295 c!      write (*,*) ""
1296 c!-------------------------------------------------------------------
1297 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1298 c! Pom is used here to project the gradient vector into
1299 c! cartesian coordinates and at the same time contains
1300 c! dXhb/dXsc derivative (for charged amino acids
1301 c! location of hydrophobic centre of interaction is not
1302 c! the same as geometric centre of side chain, this
1303 c! derivative takes that into account)
1304 c! derivatives of omega angles will be added in sc_grad
1305
1306        DO k= 1, 3
1307         ertail(k) = Rtail_distance(k)/Rtail
1308        END DO
1309        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1310        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1311        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1312        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1313        DO k = 1, 3
1314 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1315 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1316         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1317         gvdwx(k,i) = gvdwx(k,i)
1318      &             - (( dFdR + gg(k) ) * pom)
1319 c!     &             - ( dFdR * pom )
1320         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1321         gvdwx(k,j) = gvdwx(k,j)
1322      &             + (( dFdR + gg(k) ) * pom)
1323 c!     &             + ( dFdR * pom )
1324
1325         gvdwc(k,i) = gvdwc(k,i)
1326      &             - (( dFdR + gg(k) ) * ertail(k))
1327 c!     &             - ( dFdR * ertail(k))
1328
1329         gvdwc(k,j) = gvdwc(k,j)
1330      &             + (( dFdR + gg(k) ) * ertail(k))
1331 c!     &             + ( dFdR * ertail(k))
1332
1333         gg(k) = 0.0d0
1334 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1335 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1336       END DO
1337
1338 c!-------------------------------------------------------------------
1339 c! Compute head-head and head-tail energies for each state
1340
1341           isel = iabs(Qi) + iabs(Qj)
1342           IF (isel.eq.0) THEN
1343 c! No charges - do nothing
1344            eheadtail = 0.0d0
1345
1346           ELSE IF (isel.eq.4) THEN
1347 c! Calculate dipole-dipole interactions
1348            CALL edd(ecl)
1349            eheadtail = ECL
1350
1351           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1352 c! Charge-nonpolar interactions
1353            CALL eqn(epol)
1354            eheadtail = epol
1355
1356           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1357 c! Nonpolar-charge interactions
1358            CALL enq(epol)
1359            eheadtail = epol
1360
1361           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1362 c! Charge-dipole interactions
1363            CALL eqd(ecl, elj, epol)
1364            eheadtail = ECL + elj + epol
1365
1366           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1367 c! Dipole-charge interactions
1368            CALL edq(ecl, elj, epol)
1369            eheadtail = ECL + elj + epol
1370
1371           ELSE IF ((isel.eq.2.and.
1372      &          iabs(Qi).eq.1).and.
1373      &          nstate(itypi,itypj).eq.1) THEN
1374 c! Same charge-charge interaction ( +/+ or -/- )
1375            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1376            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1377
1378           ELSE IF ((isel.eq.2.and.
1379      &          iabs(Qi).eq.1).and.
1380      &          nstate(itypi,itypj).ne.1) THEN
1381 c! Different charge-charge interaction ( +/- or -/+ )
1382            CALL energy_quad
1383      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1384           END IF
1385        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1386 c!      write (*,*) "evdw = ", evdw
1387 c!      write (*,*) "Fcav = ", Fcav
1388 c!      write (*,*) "eheadtail = ", eheadtail
1389        evdw = evdw
1390      &      + Fcav
1391      &      + eheadtail
1392        ij=icant(itypi,itypj)
1393        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1394        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1395        eneps_temp(3,ij)=eheadtail
1396        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1397      &  restyp(itype(i)),i,restyp(itype(j)),j,
1398      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1399      &  Equad,evdw
1400        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1401      &  restyp(itype(i)),i,restyp(itype(j)),j,
1402      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1403      &  Equad,evdw
1404 #ifdef CHECK_MOMO
1405        evdw = 0.0d0
1406        END DO ! troll
1407 #endif
1408
1409 c!-------------------------------------------------------------------
1410 c! As all angular derivatives are done, now we sum them up,
1411 c! then transform and project into cartesian vectors and add to gvdwc
1412 c! We call sc_grad always, with the exception of +/- interaction.
1413 c! This is because energy_quad subroutine needs to handle
1414 c! this job in his own way.
1415 c! This IS probably not very efficient and SHOULD be optimised
1416 c! but it will require major restructurization of emomo
1417 c! so it will be left as it is for now
1418 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1419        IF (nstate(itypi,itypj).eq.1) THEN
1420 #ifdef TSCSC
1421         IF (bb(itypi,itypj).gt.0) THEN
1422          CALL sc_grad
1423         ELSE
1424          CALL sc_grad_T
1425         END IF
1426 #else
1427         CALL sc_grad
1428 #endif
1429        END IF
1430 c!-------------------------------------------------------------------
1431 c! NAPISY KONCOWE
1432          END DO   ! j
1433         END DO    ! iint
1434        END DO     ! i
1435 c      write (iout,*) "Number of loop steps in EGB:",ind
1436 c      energy_dec=.false.
1437        RETURN
1438       END SUBROUTINE emomo
1439 c! END OF MOMO
1440 C-----------------------------------------------------------------------------
1441       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1442        IMPLICIT NONE
1443        INCLUDE 'DIMENSIONS'
1444        INCLUDE 'DIMENSIONS.ZSCOPT'
1445        INCLUDE 'COMMON.CALC'
1446        INCLUDE 'COMMON.CHAIN'
1447        INCLUDE 'COMMON.CONTROL'
1448        INCLUDE 'COMMON.DERIV'
1449        INCLUDE 'COMMON.EMP'
1450        INCLUDE 'COMMON.GEO'
1451        INCLUDE 'COMMON.INTERACT'
1452        INCLUDE 'COMMON.IOUNITS'
1453        INCLUDE 'COMMON.LOCAL'
1454        INCLUDE 'COMMON.NAMES'
1455        INCLUDE 'COMMON.VAR'
1456        double precision scalar, facd3, facd4, federmaus, adler
1457 c! Epol and Gpol analytical parameters
1458        alphapol1 = alphapol(itypi,itypj)
1459        alphapol2 = alphapol(itypj,itypi)
1460 c! Fisocav and Gisocav analytical parameters
1461        al1  = alphiso(1,itypi,itypj)
1462        al2  = alphiso(2,itypi,itypj)
1463        al3  = alphiso(3,itypi,itypj)
1464        al4  = alphiso(4,itypi,itypj)
1465        csig = (1.0d0
1466      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1467      &      + sigiso2(itypi,itypj)**2.0d0))
1468 c!
1469        pis  = sig0head(itypi,itypj)
1470        eps_head = epshead(itypi,itypj)
1471        Rhead_sq = Rhead * Rhead
1472 c! R1 - distance between head of ith side chain and tail of jth sidechain
1473 c! R2 - distance between head of jth side chain and tail of ith sidechain
1474        R1 = 0.0d0
1475        R2 = 0.0d0
1476        DO k = 1, 3
1477 c! Calculate head-to-tail distances needed by Epol
1478         R1=R1+(ctail(k,2)-chead(k,1))**2
1479         R2=R2+(chead(k,2)-ctail(k,1))**2
1480        END DO
1481 c! Pitagoras
1482        R1 = dsqrt(R1)
1483        R2 = dsqrt(R2)
1484
1485 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1486 c!     &        +dhead(1,1,itypi,itypj))**2))
1487 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1488 c!     &        +dhead(2,1,itypi,itypj))**2))
1489 c!-------------------------------------------------------------------
1490 c! Coulomb electrostatic interaction
1491        Ecl = (332.0d0 * Qij) / Rhead
1492 c! derivative of Ecl is Gcl...
1493        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1494        dGCLdOM1 = 0.0d0
1495        dGCLdOM2 = 0.0d0
1496        dGCLdOM12 = 0.0d0
1497 c!-------------------------------------------------------------------
1498 c! Generalised Born Solvent Polarization
1499 c! Charged head polarizes the solvent
1500        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1501        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1502        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1503 c! Derivative of Egb is Ggb...
1504        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1505        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1506      &        / ( 2.0d0 * Fgb )
1507        dGGBdR = dGGBdFGB * dFGBdR
1508 c!-------------------------------------------------------------------
1509 c! Fisocav - isotropic cavity creation term
1510 c! or "how much energy it costs to put charged head in water"
1511        pom = Rhead * csig
1512        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1513        bot = (1.0d0 + al4 * pom**12.0d0)
1514        botsq = bot * bot
1515        FisoCav = top / bot
1516 c!      write (*,*) "Rhead = ",Rhead
1517 c!      write (*,*) "csig = ",csig
1518 c!      write (*,*) "pom = ",pom
1519 c!      write (*,*) "al1 = ",al1
1520 c!      write (*,*) "al2 = ",al2
1521 c!      write (*,*) "al3 = ",al3
1522 c!      write (*,*) "al4 = ",al4
1523 c!      write (*,*) "top = ",top
1524 c!      write (*,*) "bot = ",bot
1525 c! Derivative of Fisocav is GCV...
1526        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1527        dbot = 12.0d0 * al4 * pom ** 11.0d0
1528        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1529 c!-------------------------------------------------------------------
1530 c! Epol
1531 c! Polarization energy - charged heads polarize hydrophobic "neck"
1532        MomoFac1 = (1.0d0 - chi1 * sqom2)
1533        MomoFac2 = (1.0d0 - chi2 * sqom1)
1534        RR1  = ( R1 * R1 ) / MomoFac1
1535        RR2  = ( R2 * R2 ) / MomoFac2
1536        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1537        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1538        fgb1 = sqrt( RR1 + a12sq * ee1 )
1539        fgb2 = sqrt( RR2 + a12sq * ee2 )
1540        epol = 332.0d0 * eps_inout_fac * (
1541      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1542 c!       epol = 0.0d0
1543 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1544 c       write (*,*) "alphapol1 = ", alphapol1
1545 c       write (*,*) "alphapol2 = ", alphapol2
1546 c       write (*,*) "fgb1 = ", fgb1
1547 c       write (*,*) "fgb2 = ", fgb2
1548 c       write (*,*) "epol = ", epol
1549 c! derivative of Epol is Gpol...
1550        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1551      &          / (fgb1 ** 5.0d0)
1552        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1553      &          / (fgb2 ** 5.0d0)
1554        dFGBdR1 = ( (R1 / MomoFac1)
1555      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1556      &        / ( 2.0d0 * fgb1 )
1557        dFGBdR2 = ( (R2 / MomoFac2)
1558      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1559      &        / ( 2.0d0 * fgb2 )
1560        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1561      &          * ( 2.0d0 - 0.5d0 * ee1) )
1562      &          / ( 2.0d0 * fgb1 )
1563        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1564      &          * ( 2.0d0 - 0.5d0 * ee2) )
1565      &          / ( 2.0d0 * fgb2 )
1566        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1567 c!       dPOLdR1 = 0.0d0
1568        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1569 c!       dPOLdR2 = 0.0d0
1570        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1571 c!       dPOLdOM1 = 0.0d0
1572        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1573 c!       dPOLdOM2 = 0.0d0
1574 c!-------------------------------------------------------------------
1575 c! Elj
1576 c! Lennard-Jones 6-12 interaction between heads
1577        pom = (pis / Rhead)**6.0d0
1578        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1579 c! derivative of Elj is Glj
1580        dGLJdR = 4.0d0 * eps_head
1581      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1582      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1583 c!-------------------------------------------------------------------
1584 c! Return the results
1585 c! These things do the dRdX derivatives, that is
1586 c! allow us to change what we see from function that changes with
1587 c! distance to function that changes with LOCATION (of the interaction
1588 c! site)
1589        DO k = 1, 3
1590         erhead(k) = Rhead_distance(k)/Rhead
1591         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1592         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1593        END DO
1594
1595        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1596        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1597        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1598        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1599        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1600        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1601        facd1 = d1 * vbld_inv(i+nres)
1602        facd2 = d2 * vbld_inv(j+nres)
1603        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1604        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1605
1606 c! Now we add appropriate partial derivatives (one in each dimension)
1607        DO k = 1, 3
1608         hawk   = (erhead_tail(k,1) +
1609      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1610         condor = (erhead_tail(k,2) +
1611      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1612
1613         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1614         gvdwx(k,i) = gvdwx(k,i)
1615      &             - dGCLdR * pom
1616      &             - dGGBdR * pom
1617      &             - dGCVdR * pom
1618      &             - dPOLdR1 * hawk
1619      &             - dPOLdR2 * (erhead_tail(k,2)
1620      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1621      &             - dGLJdR * pom
1622
1623         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1624         gvdwx(k,j) = gvdwx(k,j)
1625      &             + dGCLdR * pom
1626      &             + dGGBdR * pom
1627      &             + dGCVdR * pom
1628      &             + dPOLdR1 * (erhead_tail(k,1)
1629      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1630      &             + dPOLdR2 * condor
1631      &             + dGLJdR * pom
1632
1633         gvdwc(k,i) = gvdwc(k,i)
1634      &             - dGCLdR * erhead(k)
1635      &             - dGGBdR * erhead(k)
1636      &             - dGCVdR * erhead(k)
1637      &             - dPOLdR1 * erhead_tail(k,1)
1638      &             - dPOLdR2 * erhead_tail(k,2)
1639      &             - dGLJdR * erhead(k)
1640
1641         gvdwc(k,j) = gvdwc(k,j)
1642      &             + dGCLdR * erhead(k)
1643      &             + dGGBdR * erhead(k)
1644      &             + dGCVdR * erhead(k)
1645      &             + dPOLdR1 * erhead_tail(k,1)
1646      &             + dPOLdR2 * erhead_tail(k,2)
1647      &             + dGLJdR * erhead(k)
1648
1649        END DO
1650        RETURN
1651       END SUBROUTINE eqq
1652 c!-------------------------------------------------------------------
1653       SUBROUTINE energy_quad
1654      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1655        IMPLICIT NONE
1656        INCLUDE 'DIMENSIONS'
1657        INCLUDE 'DIMENSIONS.ZSCOPT'
1658        INCLUDE 'COMMON.CALC'
1659        INCLUDE 'COMMON.CHAIN'
1660        INCLUDE 'COMMON.CONTROL'
1661        INCLUDE 'COMMON.DERIV'
1662        INCLUDE 'COMMON.EMP'
1663        INCLUDE 'COMMON.GEO'
1664        INCLUDE 'COMMON.INTERACT'
1665        INCLUDE 'COMMON.IOUNITS'
1666        INCLUDE 'COMMON.LOCAL'
1667        INCLUDE 'COMMON.NAMES'
1668        INCLUDE 'COMMON.VAR'
1669        double precision scalar
1670        double precision ener(4)
1671        double precision dcosom1(3),dcosom2(3)
1672 c! used in Epol derivatives
1673        double precision facd3, facd4
1674        double precision federmaus, adler
1675 c! Epol and Gpol analytical parameters
1676        alphapol1 = alphapol(itypi,itypj)
1677        alphapol2 = alphapol(itypj,itypi)
1678 c! Fisocav and Gisocav analytical parameters
1679        al1  = alphiso(1,itypi,itypj)
1680        al2  = alphiso(2,itypi,itypj)
1681        al3  = alphiso(3,itypi,itypj)
1682        al4  = alphiso(4,itypi,itypj)
1683        csig = (1.0d0
1684      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1685      &      + sigiso2(itypi,itypj)**2.0d0))
1686 c!
1687        w1   = wqdip(1,itypi,itypj)
1688        w2   = wqdip(2,itypi,itypj)
1689        pis  = sig0head(itypi,itypj)
1690        eps_head = epshead(itypi,itypj)
1691 c! First things first:
1692 c! We need to do sc_grad's job with GB and Fcav
1693        eom1  =
1694      &         eps2der * eps2rt_om1
1695      &       - 2.0D0 * alf1 * eps3der
1696      &       + sigder * sigsq_om1
1697      &       + dCAVdOM1
1698        eom2  =
1699      &         eps2der * eps2rt_om2
1700      &       + 2.0D0 * alf2 * eps3der
1701      &       + sigder * sigsq_om2
1702      &       + dCAVdOM2
1703        eom12 =
1704      &         evdwij  * eps1_om12
1705      &       + eps2der * eps2rt_om12
1706      &       - 2.0D0 * alf12 * eps3der
1707      &       + sigder *sigsq_om12
1708      &       + dCAVdOM12
1709 c! now some magical transformations to project gradient into
1710 c! three cartesian vectors
1711        DO k = 1, 3
1712         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1713         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1714         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1715 c! this acts on hydrophobic center of interaction
1716         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1717      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1718      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1719         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1720      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1721      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1722 c! this acts on Calpha
1723         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1724         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1725        END DO
1726 c! sc_grad is done, now we will compute
1727        eheadtail = 0.0d0
1728        eom1 = 0.0d0
1729        eom2 = 0.0d0
1730        eom12 = 0.0d0
1731
1732 c! ENERGY DEBUG
1733 c!       ii = 1
1734 c!       jj = 1
1735 c!       d1 = dhead(1, 1, itypi, itypj)
1736 c!       d2 = dhead(2, 1, itypi, itypj)
1737 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1738 c!     &        +dhead(1,ii,itypi,itypj))**2))
1739 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1740 c!     &        +dhead(2,jj,itypi,itypj))**2))
1741 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1742 c! END OF ENERGY DEBUG
1743 c*************************************************************
1744        DO istate = 1, nstate(itypi,itypj)
1745 c*************************************************************
1746         IF (istate.ne.1) THEN
1747          IF (istate.lt.3) THEN
1748           ii = 1
1749          ELSE
1750           ii = 2
1751          END IF
1752         jj = istate/ii
1753         d1 = dhead(1,ii,itypi,itypj)
1754         d2 = dhead(2,jj,itypi,itypj)
1755         DO k = 1,3
1756          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1757          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1758          Rhead_distance(k) = chead(k,2) - chead(k,1)
1759         END DO
1760 c! pitagoras (root of sum of squares)
1761         Rhead = dsqrt(
1762      &          (Rhead_distance(1)*Rhead_distance(1))
1763      &        + (Rhead_distance(2)*Rhead_distance(2))
1764      &        + (Rhead_distance(3)*Rhead_distance(3)))
1765         END IF
1766         Rhead_sq = Rhead * Rhead
1767
1768 c! R1 - distance between head of ith side chain and tail of jth sidechain
1769 c! R2 - distance between head of jth side chain and tail of ith sidechain
1770         R1 = 0.0d0
1771         R2 = 0.0d0
1772         DO k = 1, 3
1773 c! Calculate head-to-tail distances
1774          R1=R1+(ctail(k,2)-chead(k,1))**2
1775          R2=R2+(chead(k,2)-ctail(k,1))**2
1776         END DO
1777 c! Pitagoras
1778         R1 = dsqrt(R1)
1779         R2 = dsqrt(R2)
1780
1781 c! ENERGY DEBUG
1782 c!      write (*,*) "istate = ", istate
1783 c!      write (*,*) "ii = ", ii
1784 c!      write (*,*) "jj = ", jj
1785 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1786 c!     &        +dhead(1,ii,itypi,itypj))**2))
1787 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1788 c!     &        +dhead(2,jj,itypi,itypj))**2))
1789 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1790 c!      Rhead_sq = Rhead * Rhead
1791 c!      write (*,*) "d1 = ",d1
1792 c!      write (*,*) "d2 = ",d2
1793 c!      write (*,*) "R1 = ",R1
1794 c!      write (*,*) "R2 = ",R2
1795 c!      write (*,*) "Rhead = ",Rhead
1796 c! END OF ENERGY DEBUG
1797
1798 c!-------------------------------------------------------------------
1799 c! Coulomb electrostatic interaction
1800         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1801 c!        Ecl = 0.0d0
1802 c!        write (*,*) "Ecl = ", Ecl
1803 c! derivative of Ecl is Gcl...
1804         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1805 c!        dGCLdR = 0.0d0
1806         dGCLdOM1 = 0.0d0
1807         dGCLdOM2 = 0.0d0
1808         dGCLdOM12 = 0.0d0
1809 c!-------------------------------------------------------------------
1810 c! Generalised Born Solvent Polarization
1811         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1812         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1813         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1814 c!        Egb = 0.0d0
1815 c!      write (*,*) "a1*a2 = ", a12sq
1816 c!      write (*,*) "Rhead = ", Rhead
1817 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1818 c!      write (*,*) "ee = ", ee
1819 c!      write (*,*) "Fgb = ", Fgb
1820 c!      write (*,*) "fac = ", eps_inout_fac
1821 c!      write (*,*) "Qij = ", Qij
1822 c!      write (*,*) "Egb = ", Egb
1823 c! Derivative of Egb is Ggb...
1824 c! dFGBdR is used by Quad's later...
1825         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1826         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1827      &         / ( 2.0d0 * Fgb )
1828         dGGBdR = dGGBdFGB * dFGBdR
1829 c!        dGGBdR = 0.0d0
1830 c!-------------------------------------------------------------------
1831 c! Fisocav - isotropic cavity creation term
1832         pom = Rhead * csig
1833         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1834         bot = (1.0d0 + al4 * pom**12.0d0)
1835         botsq = bot * bot
1836         FisoCav = top / bot
1837 c!        FisoCav = 0.0d0
1838 c!      write (*,*) "pom = ",pom
1839 c!      write (*,*) "al1 = ",al1
1840 c!      write (*,*) "al2 = ",al2
1841 c!      write (*,*) "al3 = ",al3
1842 c!      write (*,*) "al4 = ",al4
1843 c!      write (*,*) "top = ",top
1844 c!      write (*,*) "bot = ",bot
1845 c!      write (*,*) "Fisocav = ", Fisocav
1846
1847 c! Derivative of Fisocav is GCV...
1848         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1849         dbot = 12.0d0 * al4 * pom ** 11.0d0
1850         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1851 c!        dGCVdR = 0.0d0
1852 c!-------------------------------------------------------------------
1853 c! Polarization energy
1854 c! Epol
1855         MomoFac1 = (1.0d0 - chi1 * sqom2)
1856         MomoFac2 = (1.0d0 - chi2 * sqom1)
1857         RR1  = ( R1 * R1 ) / MomoFac1
1858         RR2  = ( R2 * R2 ) / MomoFac2
1859         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1860         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1861         fgb1 = sqrt( RR1 + a12sq * ee1 )
1862         fgb2 = sqrt( RR2 + a12sq * ee2 )
1863         epol = 332.0d0 * eps_inout_fac * (
1864      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1865 c!        epol = 0.0d0
1866 c! derivative of Epol is Gpol...
1867         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1868      &            / (fgb1 ** 5.0d0)
1869         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1870      &            / (fgb2 ** 5.0d0)
1871         dFGBdR1 = ( (R1 / MomoFac1)
1872      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1873      &          / ( 2.0d0 * fgb1 )
1874         dFGBdR2 = ( (R2 / MomoFac2)
1875      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1876      &          / ( 2.0d0 * fgb2 )
1877         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1878      &           * ( 2.0d0 - 0.5d0 * ee1) )
1879      &           / ( 2.0d0 * fgb1 )
1880         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1881      &           * ( 2.0d0 - 0.5d0 * ee2) )
1882      &           / ( 2.0d0 * fgb2 )
1883         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1884 c!        dPOLdR1 = 0.0d0
1885         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1886 c!        dPOLdR2 = 0.0d0
1887         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1888 c!        dPOLdOM1 = 0.0d0
1889         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1890 c!        dPOLdOM2 = 0.0d0
1891 c!-------------------------------------------------------------------
1892 c! Elj
1893         pom = (pis / Rhead)**6.0d0
1894         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1895 c!        Elj = 0.0d0
1896 c! derivative of Elj is Glj
1897         dGLJdR = 4.0d0 * eps_head
1898      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1899      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1900 c!        dGLJdR = 0.0d0
1901 c!-------------------------------------------------------------------
1902 c! Equad
1903        IF (Wqd.ne.0.0d0) THEN
1904         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1905      &        - 37.5d0  * ( sqom1 + sqom2 )
1906      &        + 157.5d0 * ( sqom1 * sqom2 )
1907      &        - 45.0d0  * om1*om2*om12
1908         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1909         Equad = fac * Beta1
1910 c!        Equad = 0.0d0
1911 c! derivative of Equad...
1912         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1913 c!        dQUADdR = 0.0d0
1914         dQUADdOM1 = fac
1915      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1916 c!        dQUADdOM1 = 0.0d0
1917         dQUADdOM2 = fac
1918      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1919 c!        dQUADdOM2 = 0.0d0
1920         dQUADdOM12 = fac
1921      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1922 c!        dQUADdOM12 = 0.0d0
1923         ELSE
1924          Beta1 = 0.0d0
1925          Equad = 0.0d0
1926         END IF
1927 c!-------------------------------------------------------------------
1928 c! Return the results
1929 c! Angular stuff
1930         eom1 = dPOLdOM1 + dQUADdOM1
1931         eom2 = dPOLdOM2 + dQUADdOM2
1932         eom12 = dQUADdOM12
1933 c! now some magical transformations to project gradient into
1934 c! three cartesian vectors
1935         DO k = 1, 3
1936          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1937          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1938          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1939         END DO
1940 c! Radial stuff
1941         DO k = 1, 3
1942          erhead(k) = Rhead_distance(k)/Rhead
1943          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1944          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1945         END DO
1946         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1947         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1948         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1949         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1950         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1951         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1952         facd1 = d1 * vbld_inv(i+nres)
1953         facd2 = d2 * vbld_inv(j+nres)
1954         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1955         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1956 c! Throw the results into gheadtail which holds gradients
1957 c! for each micro-state
1958         DO k = 1, 3
1959          hawk   = erhead_tail(k,1) +
1960      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1961          condor = erhead_tail(k,2) +
1962      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1963
1964          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1965 c! this acts on hydrophobic center of interaction
1966          gheadtail(k,1,1) = gheadtail(k,1,1)
1967      &                    - dGCLdR * pom
1968      &                    - dGGBdR * pom
1969      &                    - dGCVdR * pom
1970      &                    - dPOLdR1 * hawk
1971      &                    - dPOLdR2 * (erhead_tail(k,2)
1972      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1973      &                    - dGLJdR * pom
1974      &                    - dQUADdR * pom
1975      &                    - tuna(k)
1976      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1977      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1978
1979          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1980 c! this acts on hydrophobic center of interaction
1981          gheadtail(k,2,1) = gheadtail(k,2,1)
1982      &                    + dGCLdR * pom
1983      &                    + dGGBdR * pom
1984      &                    + dGCVdR * pom
1985      &                    + dPOLdR1 * (erhead_tail(k,1)
1986      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1987      &                    + dPOLdR2 * condor
1988      &                    + dGLJdR * pom
1989      &                    + dQUADdR * pom
1990      &                    + tuna(k)
1991      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1992      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1993
1994 c! this acts on Calpha
1995          gheadtail(k,3,1) = gheadtail(k,3,1)
1996      &                    - dGCLdR * erhead(k)
1997      &                    - dGGBdR * erhead(k)
1998      &                    - dGCVdR * erhead(k)
1999      &                    - dPOLdR1 * erhead_tail(k,1)
2000      &                    - dPOLdR2 * erhead_tail(k,2)
2001      &                    - dGLJdR * erhead(k)
2002      &                    - dQUADdR * erhead(k)
2003      &                    - tuna(k)
2004
2005 c! this acts on Calpha
2006          gheadtail(k,4,1) = gheadtail(k,4,1)
2007      &                    + dGCLdR * erhead(k)
2008      &                    + dGGBdR * erhead(k)
2009      &                    + dGCVdR * erhead(k)
2010      &                    + dPOLdR1 * erhead_tail(k,1)
2011      &                    + dPOLdR2 * erhead_tail(k,2)
2012      &                    + dGLJdR * erhead(k)
2013      &                    + dQUADdR * erhead(k)
2014      &                    + tuna(k)
2015         END DO
2016 c!      write(*,*) "ECL = ", Ecl
2017 c!      write(*,*) "Egb = ", Egb
2018 c!      write(*,*) "Epol = ", Epol
2019 c!      write(*,*) "Fisocav = ", Fisocav
2020 c!      write(*,*) "Elj = ", Elj
2021 c!      write(*,*) "Equad = ", Equad
2022 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2023 c!      write(*,*) "eheadtail = ", eheadtail
2024 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2025 c!      write(*,*) "dGCLdR = ", dGCLdR
2026 c!      write(*,*) "dGGBdR = ", dGGBdR
2027 c!      write(*,*) "dGCVdR = ", dGCVdR
2028 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2029 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2030 c!      write(*,*) "dGLJdR = ", dGLJdR
2031 c!      write(*,*) "dQUADdR = ", dQUADdR
2032 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2033         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2034         eheadtail = eheadtail
2035      &            + wstate(istate, itypi, itypj)
2036      &            * dexp(-betaT * ener(istate))
2037 c! foreach cartesian dimension
2038         DO k = 1, 3
2039 c! foreach of two gvdwx and gvdwc
2040          DO l = 1, 4
2041           gheadtail(k,l,2) = gheadtail(k,l,2)
2042      &                     + wstate( istate, itypi, itypj )
2043      &                     * dexp(-betaT * ener(istate))
2044      &                     * gheadtail(k,l,1)
2045           gheadtail(k,l,1) = 0.0d0
2046          END DO
2047         END DO
2048        END DO
2049 c! Here ended the gigantic DO istate = 1, 4, which starts
2050 c! at the beggining of the subroutine
2051
2052        DO k = 1, 3
2053         DO l = 1, 4
2054          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2055         END DO
2056         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2057         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2058         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2059         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2060         DO l = 1, 4
2061          gheadtail(k,l,1) = 0.0d0
2062          gheadtail(k,l,2) = 0.0d0
2063         END DO
2064        END DO
2065        eheadtail = (-dlog(eheadtail)) / betaT
2066        dPOLdOM1 = 0.0d0
2067        dPOLdOM2 = 0.0d0
2068        dQUADdOM1 = 0.0d0
2069        dQUADdOM2 = 0.0d0
2070        dQUADdOM12 = 0.0d0
2071        RETURN
2072       END SUBROUTINE energy_quad
2073 c!-------------------------------------------------------------------
2074       SUBROUTINE eqn(Epol)
2075       IMPLICIT NONE
2076       INCLUDE 'DIMENSIONS'
2077       INCLUDE 'DIMENSIONS.ZSCOPT'
2078       INCLUDE 'COMMON.CALC'
2079       INCLUDE 'COMMON.CHAIN'
2080       INCLUDE 'COMMON.CONTROL'
2081       INCLUDE 'COMMON.DERIV'
2082       INCLUDE 'COMMON.EMP'
2083       INCLUDE 'COMMON.GEO'
2084       INCLUDE 'COMMON.INTERACT'
2085       INCLUDE 'COMMON.IOUNITS'
2086       INCLUDE 'COMMON.LOCAL'
2087       INCLUDE 'COMMON.NAMES'
2088       INCLUDE 'COMMON.VAR'
2089       double precision scalar, facd4, federmaus
2090       alphapol1 = alphapol(itypi,itypj)
2091 c! R1 - distance between head of ith side chain and tail of jth sidechain
2092        R1 = 0.0d0
2093        DO k = 1, 3
2094 c! Calculate head-to-tail distances
2095         R1=R1+(ctail(k,2)-chead(k,1))**2
2096        END DO
2097 c! Pitagoras
2098        R1 = dsqrt(R1)
2099
2100 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2101 c!     &        +dhead(1,1,itypi,itypj))**2))
2102 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2103 c!     &        +dhead(2,1,itypi,itypj))**2))
2104 c--------------------------------------------------------------------
2105 c Polarization energy
2106 c Epol
2107        MomoFac1 = (1.0d0 - chi1 * sqom2)
2108        RR1  = R1 * R1 / MomoFac1
2109        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2110        fgb1 = sqrt( RR1 + a12sq * ee1)
2111        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2112 c!       epol = 0.0d0
2113 c!------------------------------------------------------------------
2114 c! derivative of Epol is Gpol...
2115        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2116      &          / (fgb1 ** 5.0d0)
2117        dFGBdR1 = ( (R1 / MomoFac1)
2118      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2119      &        / ( 2.0d0 * fgb1 )
2120        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2121      &          * (2.0d0 - 0.5d0 * ee1) )
2122      &          / (2.0d0 * fgb1)
2123        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2124 c!       dPOLdR1 = 0.0d0
2125        dPOLdOM1 = 0.0d0
2126        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2127 c!       dPOLdOM2 = 0.0d0
2128 c!-------------------------------------------------------------------
2129 c! Return the results
2130 c! (see comments in Eqq)
2131        DO k = 1, 3
2132         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2133        END DO
2134        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2135        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2136        facd1 = d1 * vbld_inv(i+nres)
2137        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2138
2139        DO k = 1, 3
2140         hawk = (erhead_tail(k,1) +
2141      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2142
2143         gvdwx(k,i) = gvdwx(k,i)
2144      &             - dPOLdR1 * hawk
2145         gvdwx(k,j) = gvdwx(k,j)
2146      &             + dPOLdR1 * (erhead_tail(k,1)
2147      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2148
2149         gvdwc(k,i) = gvdwc(k,i)
2150      &             - dPOLdR1 * erhead_tail(k,1)
2151         gvdwc(k,j) = gvdwc(k,j)
2152      &             + dPOLdR1 * erhead_tail(k,1)
2153
2154        END DO
2155        RETURN
2156       END SUBROUTINE eqn
2157
2158
2159 c!-------------------------------------------------------------------
2160
2161
2162
2163       SUBROUTINE enq(Epol)
2164        IMPLICIT NONE
2165        INCLUDE 'DIMENSIONS'
2166        INCLUDE 'DIMENSIONS.ZSCOPT'
2167        INCLUDE 'COMMON.CALC'
2168        INCLUDE 'COMMON.CHAIN'
2169        INCLUDE 'COMMON.CONTROL'
2170        INCLUDE 'COMMON.DERIV'
2171        INCLUDE 'COMMON.EMP'
2172        INCLUDE 'COMMON.GEO'
2173        INCLUDE 'COMMON.INTERACT'
2174        INCLUDE 'COMMON.IOUNITS'
2175        INCLUDE 'COMMON.LOCAL'
2176        INCLUDE 'COMMON.NAMES'
2177        INCLUDE 'COMMON.VAR'
2178        double precision scalar, facd3, adler
2179        alphapol2 = alphapol(itypj,itypi)
2180 c! R2 - distance between head of jth side chain and tail of ith sidechain
2181        R2 = 0.0d0
2182        DO k = 1, 3
2183 c! Calculate head-to-tail distances
2184         R2=R2+(chead(k,2)-ctail(k,1))**2
2185        END DO
2186 c! Pitagoras
2187        R2 = dsqrt(R2)
2188
2189 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2190 c!     &        +dhead(1,1,itypi,itypj))**2))
2191 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2192 c!     &        +dhead(2,1,itypi,itypj))**2))
2193 c------------------------------------------------------------------------
2194 c Polarization energy
2195        MomoFac2 = (1.0d0 - chi2 * sqom1)
2196        RR2  = R2 * R2 / MomoFac2
2197        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2198        fgb2 = sqrt(RR2  + a12sq * ee2)
2199        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2200 c!       epol = 0.0d0
2201 c!-------------------------------------------------------------------
2202 c! derivative of Epol is Gpol...
2203        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2204      &          / (fgb2 ** 5.0d0)
2205        dFGBdR2 = ( (R2 / MomoFac2)
2206      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2207      &        / (2.0d0 * fgb2)
2208        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2209      &          * (2.0d0 - 0.5d0 * ee2) )
2210      &          / (2.0d0 * fgb2)
2211        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2212 c!       dPOLdR2 = 0.0d0
2213        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2214 c!       dPOLdOM1 = 0.0d0
2215        dPOLdOM2 = 0.0d0
2216 c!-------------------------------------------------------------------
2217 c! Return the results
2218 c! (See comments in Eqq)
2219        DO k = 1, 3
2220         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2221        END DO
2222        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2223        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2224        facd2 = d2 * vbld_inv(j+nres)
2225        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2226        DO k = 1, 3
2227         condor = (erhead_tail(k,2)
2228      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2229
2230         gvdwx(k,i) = gvdwx(k,i)
2231      &             - dPOLdR2 * (erhead_tail(k,2)
2232      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2233         gvdwx(k,j) = gvdwx(k,j)
2234      &             + dPOLdR2 * condor
2235
2236         gvdwc(k,i) = gvdwc(k,i)
2237      &             - dPOLdR2 * erhead_tail(k,2)
2238         gvdwc(k,j) = gvdwc(k,j)
2239      &             + dPOLdR2 * erhead_tail(k,2)
2240
2241        END DO
2242       RETURN
2243       END SUBROUTINE enq
2244
2245
2246 c!-------------------------------------------------------------------
2247
2248
2249       SUBROUTINE eqd(Ecl,Elj,Epol)
2250        IMPLICIT NONE
2251        INCLUDE 'DIMENSIONS'
2252        INCLUDE 'DIMENSIONS.ZSCOPT'
2253        INCLUDE 'COMMON.CALC'
2254        INCLUDE 'COMMON.CHAIN'
2255        INCLUDE 'COMMON.CONTROL'
2256        INCLUDE 'COMMON.DERIV'
2257        INCLUDE 'COMMON.EMP'
2258        INCLUDE 'COMMON.GEO'
2259        INCLUDE 'COMMON.INTERACT'
2260        INCLUDE 'COMMON.IOUNITS'
2261        INCLUDE 'COMMON.LOCAL'
2262        INCLUDE 'COMMON.NAMES'
2263        INCLUDE 'COMMON.VAR'
2264        double precision scalar, facd4, federmaus
2265        alphapol1 = alphapol(itypi,itypj)
2266        w1        = wqdip(1,itypi,itypj)
2267        w2        = wqdip(2,itypi,itypj)
2268        pis       = sig0head(itypi,itypj)
2269        eps_head   = epshead(itypi,itypj)
2270 c!-------------------------------------------------------------------
2271 c! R1 - distance between head of ith side chain and tail of jth sidechain
2272        R1 = 0.0d0
2273        DO k = 1, 3
2274 c! Calculate head-to-tail distances
2275         R1=R1+(ctail(k,2)-chead(k,1))**2
2276        END DO
2277 c! Pitagoras
2278        R1 = dsqrt(R1)
2279
2280 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2281 c!     &        +dhead(1,1,itypi,itypj))**2))
2282 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2283 c!     &        +dhead(2,1,itypi,itypj))**2))
2284
2285 c!-------------------------------------------------------------------
2286 c! ecl
2287        sparrow  = w1 * Qi * om1
2288        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2289        Ecl = sparrow / Rhead**2.0d0
2290      &     - hawk    / Rhead**4.0d0
2291 c!-------------------------------------------------------------------
2292 c! derivative of ecl is Gcl
2293 c! dF/dr part
2294        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2295      &           + 4.0d0 * hawk    / Rhead**5.0d0
2296 c! dF/dom1
2297        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2298 c! dF/dom2
2299        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2300 c--------------------------------------------------------------------
2301 c Polarization energy
2302 c Epol
2303        MomoFac1 = (1.0d0 - chi1 * sqom2)
2304        RR1  = R1 * R1 / MomoFac1
2305        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2306        fgb1 = sqrt( RR1 + a12sq * ee1)
2307        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2308 c!       epol = 0.0d0
2309 c!------------------------------------------------------------------
2310 c! derivative of Epol is Gpol...
2311        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2312      &          / (fgb1 ** 5.0d0)
2313        dFGBdR1 = ( (R1 / MomoFac1)
2314      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2315      &        / ( 2.0d0 * fgb1 )
2316        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2317      &          * (2.0d0 - 0.5d0 * ee1) )
2318      &          / (2.0d0 * fgb1)
2319        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2320 c!       dPOLdR1 = 0.0d0
2321        dPOLdOM1 = 0.0d0
2322        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2323 c!       dPOLdOM2 = 0.0d0
2324 c!-------------------------------------------------------------------
2325 c! Elj
2326        pom = (pis / Rhead)**6.0d0
2327        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2328 c! derivative of Elj is Glj
2329        dGLJdR = 4.0d0 * eps_head
2330      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2331      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2332 c!-------------------------------------------------------------------
2333 c! Return the results
2334        DO k = 1, 3
2335         erhead(k) = Rhead_distance(k)/Rhead
2336         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2337        END DO
2338
2339        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2340        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2341        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2342        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2343        facd1 = d1 * vbld_inv(i+nres)
2344        facd2 = d2 * vbld_inv(j+nres)
2345        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2346
2347        DO k = 1, 3
2348         hawk = (erhead_tail(k,1) +
2349      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2350
2351         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2352         gvdwx(k,i) = gvdwx(k,i)
2353      &             - dGCLdR * pom
2354      &             - dPOLdR1 * hawk
2355      &             - dGLJdR * pom
2356
2357         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2358         gvdwx(k,j) = gvdwx(k,j)
2359      &             + dGCLdR * pom
2360      &             + dPOLdR1 * (erhead_tail(k,1)
2361      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2362      &             + dGLJdR * pom
2363
2364
2365         gvdwc(k,i) = gvdwc(k,i)
2366      &             - dGCLdR * erhead(k)
2367      &             - dPOLdR1 * erhead_tail(k,1)
2368      &             - dGLJdR * erhead(k)
2369
2370         gvdwc(k,j) = gvdwc(k,j)
2371      &             + dGCLdR * erhead(k)
2372      &             + dPOLdR1 * erhead_tail(k,1)
2373      &             + dGLJdR * erhead(k)
2374
2375        END DO
2376        RETURN
2377       END SUBROUTINE eqd
2378
2379
2380 c!-------------------------------------------------------------------
2381
2382
2383       SUBROUTINE edq(Ecl,Elj,Epol)
2384        IMPLICIT NONE
2385        INCLUDE 'DIMENSIONS'
2386        INCLUDE 'DIMENSIONS.ZSCOPT'
2387        INCLUDE 'COMMON.CALC'
2388        INCLUDE 'COMMON.CHAIN'
2389        INCLUDE 'COMMON.CONTROL'
2390        INCLUDE 'COMMON.DERIV'
2391        INCLUDE 'COMMON.EMP'
2392        INCLUDE 'COMMON.GEO'
2393        INCLUDE 'COMMON.INTERACT'
2394        INCLUDE 'COMMON.IOUNITS'
2395        INCLUDE 'COMMON.LOCAL'
2396        INCLUDE 'COMMON.NAMES'
2397        INCLUDE 'COMMON.VAR'
2398        double precision scalar, facd3, adler
2399        alphapol2 = alphapol(itypj,itypi)
2400        w1        = wqdip(1,itypi,itypj)
2401        w2        = wqdip(2,itypi,itypj)
2402        pis       = sig0head(itypi,itypj)
2403        eps_head  = epshead(itypi,itypj)
2404 c!-------------------------------------------------------------------
2405 c! R2 - distance between head of jth side chain and tail of ith sidechain
2406        R2 = 0.0d0
2407        DO k = 1, 3
2408 c! Calculate head-to-tail distances
2409         R2=R2+(chead(k,2)-ctail(k,1))**2
2410        END DO
2411 c! Pitagoras
2412        R2 = dsqrt(R2)
2413
2414 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2415 c!     &        +dhead(1,1,itypi,itypj))**2))
2416 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2417 c!     &        +dhead(2,1,itypi,itypj))**2))
2418
2419
2420 c!-------------------------------------------------------------------
2421 c! ecl
2422        sparrow  = w1 * Qi * om1
2423        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2424        ECL = sparrow / Rhead**2.0d0
2425      &     - hawk    / Rhead**4.0d0
2426 c!-------------------------------------------------------------------
2427 c! derivative of ecl is Gcl
2428 c! dF/dr part
2429        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2430      &           + 4.0d0 * hawk    / Rhead**5.0d0
2431 c! dF/dom1
2432        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2433 c! dF/dom2
2434        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2435 c--------------------------------------------------------------------
2436 c Polarization energy
2437 c Epol
2438        MomoFac2 = (1.0d0 - chi2 * sqom1)
2439        RR2  = R2 * R2 / MomoFac2
2440        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2441        fgb2 = sqrt(RR2  + a12sq * ee2)
2442        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2443 c!       epol = 0.0d0
2444 c! derivative of Epol is Gpol...
2445        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2446      &          / (fgb2 ** 5.0d0)
2447        dFGBdR2 = ( (R2 / MomoFac2)
2448      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2449      &        / (2.0d0 * fgb2)
2450        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2451      &          * (2.0d0 - 0.5d0 * ee2) )
2452      &          / (2.0d0 * fgb2)
2453        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2454 c!       dPOLdR2 = 0.0d0
2455        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2456 c!       dPOLdOM1 = 0.0d0
2457        dPOLdOM2 = 0.0d0
2458 c!-------------------------------------------------------------------
2459 c! Elj
2460        pom = (pis / Rhead)**6.0d0
2461        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2462 c! derivative of Elj is Glj
2463        dGLJdR = 4.0d0 * eps_head
2464      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2465      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2466 c!-------------------------------------------------------------------
2467 c! Return the results
2468 c! (see comments in Eqq)
2469        DO k = 1, 3
2470         erhead(k) = Rhead_distance(k)/Rhead
2471         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2472        END DO
2473        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2474        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2475        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2476        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2477        facd1 = d1 * vbld_inv(i+nres)
2478        facd2 = d2 * vbld_inv(j+nres)
2479        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2480
2481        DO k = 1, 3
2482         condor = (erhead_tail(k,2)
2483      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2484
2485         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2486         gvdwx(k,i) = gvdwx(k,i)
2487      &             - dGCLdR * pom
2488      &             - dPOLdR2 * (erhead_tail(k,2)
2489      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2490      &             - dGLJdR * pom
2491
2492         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2493         gvdwx(k,j) = gvdwx(k,j)
2494      &             + dGCLdR * pom
2495      &             + dPOLdR2 * condor
2496      &             + dGLJdR * pom
2497
2498
2499         gvdwc(k,i) = gvdwc(k,i)
2500      &             - dGCLdR * erhead(k)
2501      &             - dPOLdR2 * erhead_tail(k,2)
2502      &             - dGLJdR * erhead(k)
2503
2504         gvdwc(k,j) = gvdwc(k,j)
2505      &             + dGCLdR * erhead(k)
2506      &             + dPOLdR2 * erhead_tail(k,2)
2507      &             + dGLJdR * erhead(k)
2508
2509        END DO
2510        RETURN
2511       END SUBROUTINE edq
2512
2513
2514 C--------------------------------------------------------------------
2515
2516
2517       SUBROUTINE edd(ECL)
2518        IMPLICIT NONE
2519        INCLUDE 'DIMENSIONS'
2520        INCLUDE 'DIMENSIONS.ZSCOPT'
2521        INCLUDE 'COMMON.CALC'
2522        INCLUDE 'COMMON.CHAIN'
2523        INCLUDE 'COMMON.CONTROL'
2524        INCLUDE 'COMMON.DERIV'
2525        INCLUDE 'COMMON.EMP'
2526        INCLUDE 'COMMON.GEO'
2527        INCLUDE 'COMMON.INTERACT'
2528        INCLUDE 'COMMON.IOUNITS'
2529        INCLUDE 'COMMON.LOCAL'
2530        INCLUDE 'COMMON.NAMES'
2531        INCLUDE 'COMMON.VAR'
2532        double precision scalar
2533 c!       csig = sigiso(itypi,itypj)
2534        w1 = wqdip(1,itypi,itypj)
2535        w2 = wqdip(2,itypi,itypj)
2536 c!-------------------------------------------------------------------
2537 c! ECL
2538        fac = (om12 - 3.0d0 * om1 * om2)
2539        c1 = (w1 / (Rhead**3.0d0)) * fac
2540        c2 = (w2 / Rhead ** 6.0d0)
2541      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2542        ECL = c1 - c2
2543 c!       write (*,*) "w1 = ", w1
2544 c!       write (*,*) "w2 = ", w2
2545 c!       write (*,*) "om1 = ", om1
2546 c!       write (*,*) "om2 = ", om2
2547 c!       write (*,*) "om12 = ", om12
2548 c!       write (*,*) "fac = ", fac
2549 c!       write (*,*) "c1 = ", c1
2550 c!       write (*,*) "c2 = ", c2
2551 c!       write (*,*) "Ecl = ", Ecl
2552 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2553 c!       write (*,*) "c2_2 = ",
2554 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2555 c!-------------------------------------------------------------------
2556 c! dervative of ECL is GCL...
2557 c! dECL/dr
2558        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2559        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2560      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2561        dGCLdR = c1 - c2
2562 c! dECL/dom1
2563        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2564        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2565      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2566        dGCLdOM1 = c1 - c2
2567 c! dECL/dom2
2568        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2569        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2570      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2571        dGCLdOM2 = c1 - c2
2572 c! dECL/dom12
2573        c1 = w1 / (Rhead ** 3.0d0)
2574        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2575        dGCLdOM12 = c1 - c2
2576 c!-------------------------------------------------------------------
2577 c! Return the results
2578 c! (see comments in Eqq)
2579        DO k= 1, 3
2580         erhead(k) = Rhead_distance(k)/Rhead
2581        END DO
2582        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2583        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2584        facd1 = d1 * vbld_inv(i+nres)
2585        facd2 = d2 * vbld_inv(j+nres)
2586        DO k = 1, 3
2587
2588         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2589         gvdwx(k,i) = gvdwx(k,i)
2590      &             - dGCLdR * pom
2591         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2592         gvdwx(k,j) = gvdwx(k,j)
2593      &             + dGCLdR * pom
2594
2595         gvdwc(k,i) = gvdwc(k,i)
2596      &             - dGCLdR * erhead(k)
2597         gvdwc(k,j) = gvdwc(k,j)
2598      &             + dGCLdR * erhead(k)
2599        END DO
2600        RETURN
2601       END SUBROUTINE edd
2602
2603
2604 c!-------------------------------------------------------------------
2605
2606
2607       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2608        IMPLICIT NONE
2609 c! maxres
2610        INCLUDE 'DIMENSIONS'
2611        INCLUDE 'DIMENSIONS.ZSCOPT'
2612 c! itypi, itypj, i, j, k, l, chead,
2613        INCLUDE 'COMMON.CALC'
2614 c! c, nres, dc_norm
2615        INCLUDE 'COMMON.CHAIN'
2616 c! gradc, gradx
2617        INCLUDE 'COMMON.DERIV'
2618 c! electrostatic gradients-specific variables
2619        INCLUDE 'COMMON.EMP'
2620 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2621        INCLUDE 'COMMON.INTERACT'
2622 c! t_bath, Rb
2623 c       INCLUDE 'COMMON.MD'
2624 c! io for debug, disable it in final builds
2625        INCLUDE 'COMMON.IOUNITS'
2626        double precision Rb /1.987D-3/
2627 c!-------------------------------------------------------------------
2628 c! Variable Init
2629
2630 c! what amino acid is the aminoacid j'th?
2631        itypj = itype(j)
2632 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2633 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2634 c!       t_bath = 300
2635 c!       BetaT = 1.0d0 / (t_bath * Rb)
2636        BetaT = 1.0d0 / (298.0d0 * Rb)
2637 c! Gay-berne var's
2638        sig0ij = sigma( itypi,itypj )
2639        chi1   = chi( itypi, itypj )
2640        chi2   = chi( itypj, itypi )
2641        chi12  = chi1 * chi2
2642        chip1  = chipp( itypi, itypj )
2643        chip2  = chipp( itypj, itypi )
2644        chip12 = chip1 * chip2
2645 c! not used by momo potential, but needed by sc_angular which is shared
2646 c! by all energy_potential subroutines
2647        alf1   = 0.0d0
2648        alf2   = 0.0d0
2649        alf12  = 0.0d0
2650 c! location, location, location
2651        xj  = c( 1, nres+j ) - xi
2652        yj  = c( 2, nres+j ) - yi
2653        zj  = c( 3, nres+j ) - zi
2654        dxj = dc_norm( 1, nres+j )
2655        dyj = dc_norm( 2, nres+j )
2656        dzj = dc_norm( 3, nres+j )
2657 c! distance from center of chain(?) to polar/charged head
2658 c!       write (*,*) "istate = ", 1
2659 c!       write (*,*) "ii = ", 1
2660 c!       write (*,*) "jj = ", 1
2661        d1 = dhead(1, 1, itypi, itypj)
2662        d2 = dhead(2, 1, itypi, itypj)
2663 c! ai*aj from Fgb
2664        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2665 c!       a12sq = a12sq * a12sq
2666 c! charge of amino acid itypi is...
2667        Qi  = icharge(itypi)
2668        Qj  = icharge(itypj)
2669        Qij = Qi * Qj
2670 c! chis1,2,12
2671        chis1 = chis(itypi,itypj)
2672        chis2 = chis(itypj,itypi)
2673        chis12 = chis1 * chis2
2674        sig1 = sigmap1(itypi,itypj)
2675        sig2 = sigmap2(itypi,itypj)
2676 c!       write (*,*) "sig1 = ", sig1
2677 c!       write (*,*) "sig2 = ", sig2
2678 c! alpha factors from Fcav/Gcav
2679        b1 = alphasur(1,itypi,itypj)
2680        b2 = alphasur(2,itypi,itypj)
2681        b3 = alphasur(3,itypi,itypj)
2682        b4 = alphasur(4,itypi,itypj)
2683 c! used to determine whether we want to do quadrupole calculations
2684        wqd = wquad(itypi, itypj)
2685 c! used by Fgb
2686        eps_in = epsintab(itypi,itypj)
2687        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2688 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2689 c!-------------------------------------------------------------------
2690 c! tail location and distance calculations
2691        Rtail = 0.0d0
2692        DO k = 1, 3
2693         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2694         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2695        END DO
2696 c! tail distances will be themselves usefull elswhere
2697 c1 (in Gcav, for example)
2698        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2699        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2700        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2701        Rtail = dsqrt(
2702      &     (Rtail_distance(1)*Rtail_distance(1))
2703      &   + (Rtail_distance(2)*Rtail_distance(2))
2704      &   + (Rtail_distance(3)*Rtail_distance(3)))
2705 c!-------------------------------------------------------------------
2706 c! Calculate location and distance between polar heads
2707 c! distance between heads
2708 c! for each one of our three dimensional space...
2709        DO k = 1,3
2710 c! location of polar head is computed by taking hydrophobic centre
2711 c! and moving by a d1 * dc_norm vector
2712 c! see unres publications for very informative images
2713         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2714         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2715 c! distance
2716 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2717 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2718         Rhead_distance(k) = chead(k,2) - chead(k,1)
2719        END DO
2720 c! pitagoras (root of sum of squares)
2721        Rhead = dsqrt(
2722      &     (Rhead_distance(1)*Rhead_distance(1))
2723      &   + (Rhead_distance(2)*Rhead_distance(2))
2724      &   + (Rhead_distance(3)*Rhead_distance(3)))
2725 c!-------------------------------------------------------------------
2726 c! zero everything that should be zero'ed
2727        Egb = 0.0d0
2728        ECL = 0.0d0
2729        Elj = 0.0d0
2730        Equad = 0.0d0
2731        Epol = 0.0d0
2732        eheadtail = 0.0d0
2733        dGCLdOM1 = 0.0d0
2734        dGCLdOM2 = 0.0d0
2735        dGCLdOM12 = 0.0d0
2736        dPOLdOM1 = 0.0d0
2737        dPOLdOM2 = 0.0d0
2738        RETURN
2739       END SUBROUTINE elgrad_init
2740
2741
2742 C-----------------------------------------------------------------------------
2743       subroutine sc_angular
2744 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2745 C om12. Called by ebp, egb, and egbv.
2746       implicit none
2747       include 'COMMON.CALC'
2748       erij(1)=xj*rij
2749       erij(2)=yj*rij
2750       erij(3)=zj*rij
2751       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2752       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2753       om12=dxi*dxj+dyi*dyj+dzi*dzj
2754       chiom12=chi12*om12
2755 C Calculate eps1(om12) and its derivative in om12
2756       faceps1=1.0D0-om12*chiom12
2757       faceps1_inv=1.0D0/faceps1
2758       eps1=dsqrt(faceps1_inv)
2759 C Following variable is eps1*deps1/dom12
2760       eps1_om12=faceps1_inv*chiom12
2761 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2762 C and om12.
2763       om1om2=om1*om2
2764       chiom1=chi1*om1
2765       chiom2=chi2*om2
2766       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2767       sigsq=1.0D0-facsig*faceps1_inv
2768       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2769       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2770       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2771 C Calculate eps2 and its derivatives in om1, om2, and om12.
2772       chipom1=chip1*om1
2773       chipom2=chip2*om2
2774       chipom12=chip12*om12
2775       facp=1.0D0-om12*chipom12
2776       facp_inv=1.0D0/facp
2777       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2778 C Following variable is the square root of eps2
2779       eps2rt=1.0D0-facp1*facp_inv
2780 C Following three variables are the derivatives of the square root of eps
2781 C in om1, om2, and om12.
2782       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2783       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2784       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2785 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2786       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2787 C Calculate whole angle-dependent part of epsilon and contributions
2788 C to its derivatives
2789       return
2790       end
2791 C----------------------------------------------------------------------------
2792       subroutine sc_grad
2793       implicit real*8 (a-h,o-z)
2794       include 'DIMENSIONS'
2795       include 'DIMENSIONS.ZSCOPT'
2796       include 'COMMON.CHAIN'
2797       include 'COMMON.DERIV'
2798       include 'COMMON.CALC'
2799       double precision dcosom1(3),dcosom2(3)
2800       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2801       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2802       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2803      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2804       do k=1,3
2805         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2806         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2807       enddo
2808       do k=1,3
2809         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2810       enddo
2811       do k=1,3
2812         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2813      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2814      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2815         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2816      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2817      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2818       enddo
2819 C
2820 C Calculate the components of the gradient in DC and X
2821 C
2822 c      do k=i,j-1
2823 c        do l=1,3
2824 c          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2825 c        enddo
2826 c      enddo
2827       do l=1,3
2828         gvdwc(l,i)=gvdwc(l,i)-gg(l)!+gg_lipi(l)
2829         gvdwc(l,j)=gvdwc(l,j)+gg(l)!+gg_lipj(l)
2830       enddo
2831
2832       return
2833       end
2834 c------------------------------------------------------------------------------
2835       subroutine vec_and_deriv
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838       include 'DIMENSIONS.ZSCOPT'
2839       include 'COMMON.IOUNITS'
2840       include 'COMMON.GEO'
2841       include 'COMMON.VAR'
2842       include 'COMMON.LOCAL'
2843       include 'COMMON.CHAIN'
2844       include 'COMMON.VECTORS'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2848 C Compute the local reference systems. For reference system (i), the
2849 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2850 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2851       do i=1,nres-1
2852 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2853           if (i.eq.nres-1) then
2854 C Case of the last full residue
2855 C Compute the Z-axis
2856             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2857             costh=dcos(pi-theta(nres))
2858             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2859             do k=1,3
2860               uz(k,i)=fac*uz(k,i)
2861             enddo
2862             if (calc_grad) then
2863 C Compute the derivatives of uz
2864             uzder(1,1,1)= 0.0d0
2865             uzder(2,1,1)=-dc_norm(3,i-1)
2866             uzder(3,1,1)= dc_norm(2,i-1)
2867             uzder(1,2,1)= dc_norm(3,i-1)
2868             uzder(2,2,1)= 0.0d0
2869             uzder(3,2,1)=-dc_norm(1,i-1)
2870             uzder(1,3,1)=-dc_norm(2,i-1)
2871             uzder(2,3,1)= dc_norm(1,i-1)
2872             uzder(3,3,1)= 0.0d0
2873             uzder(1,1,2)= 0.0d0
2874             uzder(2,1,2)= dc_norm(3,i)
2875             uzder(3,1,2)=-dc_norm(2,i)
2876             uzder(1,2,2)=-dc_norm(3,i)
2877             uzder(2,2,2)= 0.0d0
2878             uzder(3,2,2)= dc_norm(1,i)
2879             uzder(1,3,2)= dc_norm(2,i)
2880             uzder(2,3,2)=-dc_norm(1,i)
2881             uzder(3,3,2)= 0.0d0
2882             endif
2883 C Compute the Y-axis
2884             facy=fac
2885             do k=1,3
2886               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2887             enddo
2888             if (calc_grad) then
2889 C Compute the derivatives of uy
2890             do j=1,3
2891               do k=1,3
2892                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2893      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2894                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2895               enddo
2896               uyder(j,j,1)=uyder(j,j,1)-costh
2897               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2898             enddo
2899             do j=1,2
2900               do k=1,3
2901                 do l=1,3
2902                   uygrad(l,k,j,i)=uyder(l,k,j)
2903                   uzgrad(l,k,j,i)=uzder(l,k,j)
2904                 enddo
2905               enddo
2906             enddo
2907             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2908             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2909             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2910             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2911             endif
2912           else
2913 C Other residues
2914 C Compute the Z-axis
2915             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2916             costh=dcos(pi-theta(i+2))
2917             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2918             do k=1,3
2919               uz(k,i)=fac*uz(k,i)
2920             enddo
2921             if (calc_grad) then
2922 C Compute the derivatives of uz
2923             uzder(1,1,1)= 0.0d0
2924             uzder(2,1,1)=-dc_norm(3,i+1)
2925             uzder(3,1,1)= dc_norm(2,i+1)
2926             uzder(1,2,1)= dc_norm(3,i+1)
2927             uzder(2,2,1)= 0.0d0
2928             uzder(3,2,1)=-dc_norm(1,i+1)
2929             uzder(1,3,1)=-dc_norm(2,i+1)
2930             uzder(2,3,1)= dc_norm(1,i+1)
2931             uzder(3,3,1)= 0.0d0
2932             uzder(1,1,2)= 0.0d0
2933             uzder(2,1,2)= dc_norm(3,i)
2934             uzder(3,1,2)=-dc_norm(2,i)
2935             uzder(1,2,2)=-dc_norm(3,i)
2936             uzder(2,2,2)= 0.0d0
2937             uzder(3,2,2)= dc_norm(1,i)
2938             uzder(1,3,2)= dc_norm(2,i)
2939             uzder(2,3,2)=-dc_norm(1,i)
2940             uzder(3,3,2)= 0.0d0
2941             endif
2942 C Compute the Y-axis
2943             facy=fac
2944             do k=1,3
2945               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2946             enddo
2947             if (calc_grad) then
2948 C Compute the derivatives of uy
2949             do j=1,3
2950               do k=1,3
2951                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2952      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2953                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2954               enddo
2955               uyder(j,j,1)=uyder(j,j,1)-costh
2956               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2957             enddo
2958             do j=1,2
2959               do k=1,3
2960                 do l=1,3
2961                   uygrad(l,k,j,i)=uyder(l,k,j)
2962                   uzgrad(l,k,j,i)=uzder(l,k,j)
2963                 enddo
2964               enddo
2965             enddo
2966             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2967             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2968             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2969             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2970           endif
2971           endif
2972       enddo
2973       if (calc_grad) then
2974       do i=1,nres-1
2975         vbld_inv_temp(1)=vbld_inv(i+1)
2976         if (i.lt.nres-1) then
2977           vbld_inv_temp(2)=vbld_inv(i+2)
2978         else
2979           vbld_inv_temp(2)=vbld_inv(i)
2980         endif
2981         do j=1,2
2982           do k=1,3
2983             do l=1,3
2984               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2985               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2986             enddo
2987           enddo
2988         enddo
2989       enddo
2990       endif
2991       return
2992       end
2993 c------------------------------------------------------------------------------
2994       subroutine set_matrices
2995       implicit real*8 (a-h,o-z)
2996       include 'DIMENSIONS'
2997 #ifdef MPI
2998       include "mpif.h"
2999       integer IERR
3000       integer status(MPI_STATUS_SIZE)
3001 #endif
3002       include 'DIMENSIONS.ZSCOPT'
3003       include 'COMMON.IOUNITS'
3004       include 'COMMON.GEO'
3005       include 'COMMON.VAR'
3006       include 'COMMON.LOCAL'
3007       include 'COMMON.CHAIN'
3008       include 'COMMON.DERIV'
3009       include 'COMMON.INTERACT'
3010       include 'COMMON.CONTACTS'
3011       include 'COMMON.TORSION'
3012       include 'COMMON.VECTORS'
3013       include 'COMMON.FFIELD'
3014       double precision auxvec(2),auxmat(2,2)
3015 C
3016 C Compute the virtual-bond-torsional-angle dependent quantities needed
3017 C to calculate the el-loc multibody terms of various order.
3018 C
3019 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3020       do i=3,nres+1
3021         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3022           iti = itype2loc(itype(i-2))
3023         else
3024           iti=nloctyp
3025         endif
3026 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3027         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3028           iti1 = itype2loc(itype(i-1))
3029         else
3030           iti1=nloctyp
3031         endif
3032 #ifdef NEWCORR
3033         cost1=dcos(theta(i-1))
3034         sint1=dsin(theta(i-1))
3035         sint1sq=sint1*sint1
3036         sint1cub=sint1sq*sint1
3037         sint1cost1=2*sint1*cost1
3038 #ifdef DEBUG
3039         write (iout,*) "bnew1",i,iti
3040         write (iout,*) (bnew1(k,1,iti),k=1,3)
3041         write (iout,*) (bnew1(k,2,iti),k=1,3)
3042         write (iout,*) "bnew2",i,iti
3043         write (iout,*) (bnew2(k,1,iti),k=1,3)
3044         write (iout,*) (bnew2(k,2,iti),k=1,3)
3045 #endif
3046         do k=1,2
3047           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3048           b1(k,i-2)=sint1*b1k
3049           gtb1(k,i-2)=cost1*b1k-sint1sq*
3050      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3051           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3052           b2(k,i-2)=sint1*b2k
3053           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3054      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3055         enddo
3056         do k=1,2
3057           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3058           cc(1,k,i-2)=sint1sq*aux
3059           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3060      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3061           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3062           dd(1,k,i-2)=sint1sq*aux
3063           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3064      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3065         enddo
3066         cc(2,1,i-2)=cc(1,2,i-2)
3067         cc(2,2,i-2)=-cc(1,1,i-2)
3068         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3069         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3070         dd(2,1,i-2)=dd(1,2,i-2)
3071         dd(2,2,i-2)=-dd(1,1,i-2)
3072         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3073         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3074         do k=1,2
3075           do l=1,2
3076             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3077             EE(l,k,i-2)=sint1sq*aux
3078             if (calc_grad)
3079      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3080           enddo
3081         enddo
3082         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3083         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3084         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3085         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3086         if (calc_grad) then
3087         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3088         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3089         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3090         endif
3091 c        b1tilde(1,i-2)=b1(1,i-2)
3092 c        b1tilde(2,i-2)=-b1(2,i-2)
3093 c        b2tilde(1,i-2)=b2(1,i-2)
3094 c        b2tilde(2,i-2)=-b2(2,i-2)
3095 #ifdef DEBUG
3096         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3097         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3098         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3099         write (iout,*) 'theta=', theta(i-1)
3100 #endif
3101 #else
3102         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103           iti = itype2loc(itype(i-2))
3104         else
3105           iti=nloctyp
3106         endif
3107 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3108         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3109           iti1 = itype2loc(itype(i-1))
3110         else
3111           iti1=nloctyp
3112         endif
3113         b1(1,i-2)=b(3,iti)
3114         b1(2,i-2)=b(5,iti)
3115         b2(1,i-2)=b(2,iti)
3116         b2(2,i-2)=b(4,iti)
3117         do k=1,2
3118           do l=1,2
3119            CC(k,l,i-2)=ccold(k,l,iti)
3120            DD(k,l,i-2)=ddold(k,l,iti)
3121            EE(k,l,i-2)=eeold(k,l,iti)
3122           enddo
3123         enddo
3124 #endif
3125         b1tilde(1,i-2)= b1(1,i-2)
3126         b1tilde(2,i-2)=-b1(2,i-2)
3127         b2tilde(1,i-2)= b2(1,i-2)
3128         b2tilde(2,i-2)=-b2(2,i-2)
3129 c
3130         Ctilde(1,1,i-2)= CC(1,1,i-2)
3131         Ctilde(1,2,i-2)= CC(1,2,i-2)
3132         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3133         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3134 c
3135         Dtilde(1,1,i-2)= DD(1,1,i-2)
3136         Dtilde(1,2,i-2)= DD(1,2,i-2)
3137         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3138         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3139 c        write(iout,*) "i",i," iti",iti
3140 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3141 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3142       enddo
3143       do i=3,nres+1
3144         if (i .lt. nres+1) then
3145           sin1=dsin(phi(i))
3146           cos1=dcos(phi(i))
3147           sintab(i-2)=sin1
3148           costab(i-2)=cos1
3149           obrot(1,i-2)=cos1
3150           obrot(2,i-2)=sin1
3151           sin2=dsin(2*phi(i))
3152           cos2=dcos(2*phi(i))
3153           sintab2(i-2)=sin2
3154           costab2(i-2)=cos2
3155           obrot2(1,i-2)=cos2
3156           obrot2(2,i-2)=sin2
3157           Ug(1,1,i-2)=-cos1
3158           Ug(1,2,i-2)=-sin1
3159           Ug(2,1,i-2)=-sin1
3160           Ug(2,2,i-2)= cos1
3161           Ug2(1,1,i-2)=-cos2
3162           Ug2(1,2,i-2)=-sin2
3163           Ug2(2,1,i-2)=-sin2
3164           Ug2(2,2,i-2)= cos2
3165         else
3166           costab(i-2)=1.0d0
3167           sintab(i-2)=0.0d0
3168           obrot(1,i-2)=1.0d0
3169           obrot(2,i-2)=0.0d0
3170           obrot2(1,i-2)=0.0d0
3171           obrot2(2,i-2)=0.0d0
3172           Ug(1,1,i-2)=1.0d0
3173           Ug(1,2,i-2)=0.0d0
3174           Ug(2,1,i-2)=0.0d0
3175           Ug(2,2,i-2)=1.0d0
3176           Ug2(1,1,i-2)=0.0d0
3177           Ug2(1,2,i-2)=0.0d0
3178           Ug2(2,1,i-2)=0.0d0
3179           Ug2(2,2,i-2)=0.0d0
3180         endif
3181         if (i .gt. 3 .and. i .lt. nres+1) then
3182           obrot_der(1,i-2)=-sin1
3183           obrot_der(2,i-2)= cos1
3184           Ugder(1,1,i-2)= sin1
3185           Ugder(1,2,i-2)=-cos1
3186           Ugder(2,1,i-2)=-cos1
3187           Ugder(2,2,i-2)=-sin1
3188           dwacos2=cos2+cos2
3189           dwasin2=sin2+sin2
3190           obrot2_der(1,i-2)=-dwasin2
3191           obrot2_der(2,i-2)= dwacos2
3192           Ug2der(1,1,i-2)= dwasin2
3193           Ug2der(1,2,i-2)=-dwacos2
3194           Ug2der(2,1,i-2)=-dwacos2
3195           Ug2der(2,2,i-2)=-dwasin2
3196         else
3197           obrot_der(1,i-2)=0.0d0
3198           obrot_der(2,i-2)=0.0d0
3199           Ugder(1,1,i-2)=0.0d0
3200           Ugder(1,2,i-2)=0.0d0
3201           Ugder(2,1,i-2)=0.0d0
3202           Ugder(2,2,i-2)=0.0d0
3203           obrot2_der(1,i-2)=0.0d0
3204           obrot2_der(2,i-2)=0.0d0
3205           Ug2der(1,1,i-2)=0.0d0
3206           Ug2der(1,2,i-2)=0.0d0
3207           Ug2der(2,1,i-2)=0.0d0
3208           Ug2der(2,2,i-2)=0.0d0
3209         endif
3210 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3211         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3212           iti = itype2loc(itype(i-2))
3213         else
3214           iti=nloctyp
3215         endif
3216 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3217         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3218           iti1 = itype2loc(itype(i-1))
3219         else
3220           iti1=nloctyp
3221         endif
3222 cd        write (iout,*) '*******i',i,' iti1',iti
3223 cd        write (iout,*) 'b1',b1(:,iti)
3224 cd        write (iout,*) 'b2',b2(:,iti)
3225 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3226 c        if (i .gt. iatel_s+2) then
3227         if (i .gt. nnt+2) then
3228           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3229 #ifdef NEWCORR
3230           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3231 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3232 #endif
3233 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3234 c     &    EE(1,2,iti),EE(2,2,i)
3235           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3236           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3237 c          write(iout,*) "Macierz EUG",
3238 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3239 c     &    eug(2,2,i-2)
3240           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3241      &    then
3242           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3243           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3244           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3245           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3246           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3247           endif
3248         else
3249           do k=1,2
3250             Ub2(k,i-2)=0.0d0
3251             Ctobr(k,i-2)=0.0d0
3252             Dtobr2(k,i-2)=0.0d0
3253             do l=1,2
3254               EUg(l,k,i-2)=0.0d0
3255               CUg(l,k,i-2)=0.0d0
3256               DUg(l,k,i-2)=0.0d0
3257               DtUg2(l,k,i-2)=0.0d0
3258             enddo
3259           enddo
3260         endif
3261         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3262         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3263         do k=1,2
3264           muder(k,i-2)=Ub2der(k,i-2)
3265         enddo
3266 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3267         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3268           if (itype(i-1).le.ntyp) then
3269             iti1 = itype2loc(itype(i-1))
3270           else
3271             iti1=nloctyp
3272           endif
3273         else
3274           iti1=nloctyp
3275         endif
3276         do k=1,2
3277           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3278         enddo
3279 #ifdef MUOUT
3280         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3281      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3282      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3283      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3284      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3285      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3286 #endif
3287 cd        write (iout,*) 'mu1',mu1(:,i-2)
3288 cd        write (iout,*) 'mu2',mu2(:,i-2)
3289         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3290      &  then
3291         if (calc_grad) then
3292         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3293         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3294         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3295         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3296         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3297         endif
3298 C Vectors and matrices dependent on a single virtual-bond dihedral.
3299         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3300         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3301         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3302         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3303         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3304         if (calc_grad) then
3305         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3306         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3307         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3308         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3309         endif
3310         endif
3311       enddo
3312 C Matrices dependent on two consecutive virtual-bond dihedrals.
3313 C The order of matrices is from left to right.
3314       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3315      &then
3316       do i=2,nres-1
3317         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3318         if (calc_grad) then
3319         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3320         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3321         endif
3322         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3323         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3324         if (calc_grad) then
3325         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3326         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3327         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3328         endif
3329       enddo
3330       endif
3331       return
3332       end
3333 C--------------------------------------------------------------------------
3334       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3335 C
3336 C This subroutine calculates the average interaction energy and its gradient
3337 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3338 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3339 C The potential depends both on the distance of peptide-group centers and on
3340 C the orientation of the CA-CA virtual bonds.
3341 C
3342       implicit real*8 (a-h,o-z)
3343 #ifdef MPI
3344       include 'mpif.h'
3345 #endif
3346       include 'DIMENSIONS'
3347       include 'DIMENSIONS.ZSCOPT'
3348       include 'COMMON.CONTROL'
3349       include 'COMMON.IOUNITS'
3350       include 'COMMON.GEO'
3351       include 'COMMON.VAR'
3352       include 'COMMON.LOCAL'
3353       include 'COMMON.CHAIN'
3354       include 'COMMON.DERIV'
3355       include 'COMMON.INTERACT'
3356       include 'COMMON.CONTACTS'
3357       include 'COMMON.TORSION'
3358       include 'COMMON.VECTORS'
3359       include 'COMMON.FFIELD'
3360       include 'COMMON.TIME1'
3361       include 'COMMON.SPLITELE'
3362       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3363      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3364       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3365      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3366       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3367      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3368      &    num_conti,j1,j2
3369 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3370 #ifdef MOMENT
3371       double precision scal_el /1.0d0/
3372 #else
3373       double precision scal_el /0.5d0/
3374 #endif
3375 C 12/13/98
3376 C 13-go grudnia roku pamietnego...
3377       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3378      &                   0.0d0,1.0d0,0.0d0,
3379      &                   0.0d0,0.0d0,1.0d0/
3380 cd      write(iout,*) 'In EELEC'
3381 cd      do i=1,nloctyp
3382 cd        write(iout,*) 'Type',i
3383 cd        write(iout,*) 'B1',B1(:,i)
3384 cd        write(iout,*) 'B2',B2(:,i)
3385 cd        write(iout,*) 'CC',CC(:,:,i)
3386 cd        write(iout,*) 'DD',DD(:,:,i)
3387 cd        write(iout,*) 'EE',EE(:,:,i)
3388 cd      enddo
3389 cd      call check_vecgrad
3390 cd      stop
3391       if (icheckgrad.eq.1) then
3392         do i=1,nres-1
3393           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3394           do k=1,3
3395             dc_norm(k,i)=dc(k,i)*fac
3396           enddo
3397 c          write (iout,*) 'i',i,' fac',fac
3398         enddo
3399       endif
3400       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3401      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3402      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3403 c        call vec_and_deriv
3404 #ifdef TIMING
3405         time01=MPI_Wtime()
3406 #endif
3407         call set_matrices
3408 #ifdef TIMING
3409         time_mat=time_mat+MPI_Wtime()-time01
3410 #endif
3411       endif
3412 cd      do i=1,nres-1
3413 cd        write (iout,*) 'i=',i
3414 cd        do k=1,3
3415 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3416 cd        enddo
3417 cd        do k=1,3
3418 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3419 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3420 cd        enddo
3421 cd      enddo
3422       t_eelecij=0.0d0
3423       ees=0.0D0
3424       evdw1=0.0D0
3425       eel_loc=0.0d0
3426       eello_turn3=0.0d0
3427       eello_turn4=0.0d0
3428       ind=0
3429       do i=1,nres
3430         num_cont_hb(i)=0
3431       enddo
3432 cd      print '(a)','Enter EELEC'
3433 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3434       do i=1,nres
3435         gel_loc_loc(i)=0.0d0
3436         gcorr_loc(i)=0.0d0
3437       enddo
3438 c
3439 c
3440 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3441 C
3442 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3443 C
3444 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3445       do i=iturn3_start,iturn3_end
3446 c        if (i.le.1) cycle
3447 C        write(iout,*) "tu jest i",i
3448         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3449 C changes suggested by Ana to avoid out of bounds
3450 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3451 c     & .or.((i+4).gt.nres)
3452 c     & .or.((i-1).le.0)
3453 C end of changes by Ana
3454 C dobra zmiana wycofana
3455      &  .or. itype(i+2).eq.ntyp1
3456      &  .or. itype(i+3).eq.ntyp1) cycle
3457 C Adam: Instructions below will switch off existing interactions
3458 c        if(i.gt.1)then
3459 c          if(itype(i-1).eq.ntyp1)cycle
3460 c        end if
3461 c        if(i.LT.nres-3)then
3462 c          if (itype(i+4).eq.ntyp1) cycle
3463 c        end if
3464         dxi=dc(1,i)
3465         dyi=dc(2,i)
3466         dzi=dc(3,i)
3467         dx_normi=dc_norm(1,i)
3468         dy_normi=dc_norm(2,i)
3469         dz_normi=dc_norm(3,i)
3470         xmedi=c(1,i)+0.5d0*dxi
3471         ymedi=c(2,i)+0.5d0*dyi
3472         zmedi=c(3,i)+0.5d0*dzi
3473           xmedi=mod(xmedi,boxxsize)
3474           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3475           ymedi=mod(ymedi,boxysize)
3476           if (ymedi.lt.0) ymedi=ymedi+boxysize
3477           zmedi=mod(zmedi,boxzsize)
3478           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3479         num_conti=0
3480         call eelecij(i,i+2,ees,evdw1,eel_loc)
3481         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3482         num_cont_hb(i)=num_conti
3483       enddo
3484       do i=iturn4_start,iturn4_end
3485         if (i.lt.1) cycle
3486         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3487 C changes suggested by Ana to avoid out of bounds
3488 c     & .or.((i+5).gt.nres)
3489 c     & .or.((i-1).le.0)
3490 C end of changes suggested by Ana
3491      &    .or. itype(i+3).eq.ntyp1
3492      &    .or. itype(i+4).eq.ntyp1
3493 c     &    .or. itype(i+5).eq.ntyp1
3494 c     &    .or. itype(i).eq.ntyp1
3495 c     &    .or. itype(i-1).eq.ntyp1
3496      &                             ) cycle
3497         dxi=dc(1,i)
3498         dyi=dc(2,i)
3499         dzi=dc(3,i)
3500         dx_normi=dc_norm(1,i)
3501         dy_normi=dc_norm(2,i)
3502         dz_normi=dc_norm(3,i)
3503         xmedi=c(1,i)+0.5d0*dxi
3504         ymedi=c(2,i)+0.5d0*dyi
3505         zmedi=c(3,i)+0.5d0*dzi
3506 C Return atom into box, boxxsize is size of box in x dimension
3507 c  194   continue
3508 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3509 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3510 C Condition for being inside the proper box
3511 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3512 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3513 c        go to 194
3514 c        endif
3515 c  195   continue
3516 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3517 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3518 C Condition for being inside the proper box
3519 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3520 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3521 c        go to 195
3522 c        endif
3523 c  196   continue
3524 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3525 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3526 C Condition for being inside the proper box
3527 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3528 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3529 c        go to 196
3530 c        endif
3531           xmedi=mod(xmedi,boxxsize)
3532           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3533           ymedi=mod(ymedi,boxysize)
3534           if (ymedi.lt.0) ymedi=ymedi+boxysize
3535           zmedi=mod(zmedi,boxzsize)
3536           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3537
3538         num_conti=num_cont_hb(i)
3539 c        write(iout,*) "JESTEM W PETLI"
3540         call eelecij(i,i+3,ees,evdw1,eel_loc)
3541         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3542      &   call eturn4(i,eello_turn4)
3543         num_cont_hb(i)=num_conti
3544       enddo   ! i
3545 C Loop over all neighbouring boxes
3546 C      do xshift=-1,1
3547 C      do yshift=-1,1
3548 C      do zshift=-1,1
3549 c
3550 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3551 c
3552 CTU KURWA
3553       do i=iatel_s,iatel_e
3554 C        do i=75,75
3555 c        if (i.le.1) cycle
3556         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3557 C changes suggested by Ana to avoid out of bounds
3558 c     & .or.((i+2).gt.nres)
3559 c     & .or.((i-1).le.0)
3560 C end of changes by Ana
3561 c     &  .or. itype(i+2).eq.ntyp1
3562 c     &  .or. itype(i-1).eq.ntyp1
3563      &                ) cycle
3564         dxi=dc(1,i)
3565         dyi=dc(2,i)
3566         dzi=dc(3,i)
3567         dx_normi=dc_norm(1,i)
3568         dy_normi=dc_norm(2,i)
3569         dz_normi=dc_norm(3,i)
3570         xmedi=c(1,i)+0.5d0*dxi
3571         ymedi=c(2,i)+0.5d0*dyi
3572         zmedi=c(3,i)+0.5d0*dzi
3573           xmedi=mod(xmedi,boxxsize)
3574           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3575           ymedi=mod(ymedi,boxysize)
3576           if (ymedi.lt.0) ymedi=ymedi+boxysize
3577           zmedi=mod(zmedi,boxzsize)
3578           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3579 C          xmedi=xmedi+xshift*boxxsize
3580 C          ymedi=ymedi+yshift*boxysize
3581 C          zmedi=zmedi+zshift*boxzsize
3582
3583 C Return tom into box, boxxsize is size of box in x dimension
3584 c  164   continue
3585 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3586 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3587 C Condition for being inside the proper box
3588 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3589 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3590 c        go to 164
3591 c        endif
3592 c  165   continue
3593 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3594 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3595 C Condition for being inside the proper box
3596 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3597 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3598 c        go to 165
3599 c        endif
3600 c  166   continue
3601 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3602 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3603 cC Condition for being inside the proper box
3604 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3605 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3606 c        go to 166
3607 c        endif
3608
3609 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3610         num_conti=num_cont_hb(i)
3611 C I TU KURWA
3612         do j=ielstart(i),ielend(i)
3613 C          do j=16,17
3614 C          write (iout,*) i,j
3615 C         if (j.le.1) cycle
3616           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3617 C changes suggested by Ana to avoid out of bounds
3618 c     & .or.((j+2).gt.nres)
3619 c     & .or.((j-1).le.0)
3620 C end of changes by Ana
3621 c     & .or.itype(j+2).eq.ntyp1
3622 c     & .or.itype(j-1).eq.ntyp1
3623      &) cycle
3624           call eelecij(i,j,ees,evdw1,eel_loc)
3625         enddo ! j
3626         num_cont_hb(i)=num_conti
3627       enddo   ! i
3628 C     enddo   ! zshift
3629 C      enddo   ! yshift
3630 C      enddo   ! xshift
3631
3632 c      write (iout,*) "Number of loop steps in EELEC:",ind
3633 cd      do i=1,nres
3634 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3635 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3636 cd      enddo
3637 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3638 ccc      eel_loc=eel_loc+eello_turn3
3639 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3640       return
3641       end
3642 C-------------------------------------------------------------------------------
3643       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3644       implicit real*8 (a-h,o-z)
3645       include 'DIMENSIONS'
3646       include 'DIMENSIONS.ZSCOPT'
3647 #ifdef MPI
3648       include "mpif.h"
3649 #endif
3650       include 'COMMON.CONTROL'
3651       include 'COMMON.IOUNITS'
3652       include 'COMMON.GEO'
3653       include 'COMMON.VAR'
3654       include 'COMMON.LOCAL'
3655       include 'COMMON.CHAIN'
3656       include 'COMMON.DERIV'
3657       include 'COMMON.INTERACT'
3658       include 'COMMON.CONTACTS'
3659       include 'COMMON.TORSION'
3660       include 'COMMON.VECTORS'
3661       include 'COMMON.FFIELD'
3662       include 'COMMON.TIME1'
3663       include 'COMMON.SPLITELE'
3664       include 'COMMON.SHIELD'
3665       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3666      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3667       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3668      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3669      &    gmuij2(4),gmuji2(4)
3670       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3671      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3672      &    num_conti,j1,j2
3673 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3674 #ifdef MOMENT
3675       double precision scal_el /1.0d0/
3676 #else
3677       double precision scal_el /0.5d0/
3678 #endif
3679 C 12/13/98
3680 C 13-go grudnia roku pamietnego...
3681       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3682      &                   0.0d0,1.0d0,0.0d0,
3683      &                   0.0d0,0.0d0,1.0d0/
3684        integer xshift,yshift,zshift
3685 c          time00=MPI_Wtime()
3686 cd      write (iout,*) "eelecij",i,j
3687 c          ind=ind+1
3688           iteli=itel(i)
3689           itelj=itel(j)
3690           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3691           aaa=app(iteli,itelj)
3692           bbb=bpp(iteli,itelj)
3693           ael6i=ael6(iteli,itelj)
3694           ael3i=ael3(iteli,itelj)
3695           dxj=dc(1,j)
3696           dyj=dc(2,j)
3697           dzj=dc(3,j)
3698           dx_normj=dc_norm(1,j)
3699           dy_normj=dc_norm(2,j)
3700           dz_normj=dc_norm(3,j)
3701 C          xj=c(1,j)+0.5D0*dxj-xmedi
3702 C          yj=c(2,j)+0.5D0*dyj-ymedi
3703 C          zj=c(3,j)+0.5D0*dzj-zmedi
3704           xj=c(1,j)+0.5D0*dxj
3705           yj=c(2,j)+0.5D0*dyj
3706           zj=c(3,j)+0.5D0*dzj
3707           xj=mod(xj,boxxsize)
3708           if (xj.lt.0) xj=xj+boxxsize
3709           yj=mod(yj,boxysize)
3710           if (yj.lt.0) yj=yj+boxysize
3711           zj=mod(zj,boxzsize)
3712           if (zj.lt.0) zj=zj+boxzsize
3713           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3714       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3715       xj_safe=xj
3716       yj_safe=yj
3717       zj_safe=zj
3718       isubchap=0
3719       do xshift=-1,1
3720       do yshift=-1,1
3721       do zshift=-1,1
3722           xj=xj_safe+xshift*boxxsize
3723           yj=yj_safe+yshift*boxysize
3724           zj=zj_safe+zshift*boxzsize
3725           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3726           if(dist_temp.lt.dist_init) then
3727             dist_init=dist_temp
3728             xj_temp=xj
3729             yj_temp=yj
3730             zj_temp=zj
3731             isubchap=1
3732           endif
3733        enddo
3734        enddo
3735        enddo
3736        if (isubchap.eq.1) then
3737           xj=xj_temp-xmedi
3738           yj=yj_temp-ymedi
3739           zj=zj_temp-zmedi
3740        else
3741           xj=xj_safe-xmedi
3742           yj=yj_safe-ymedi
3743           zj=zj_safe-zmedi
3744        endif
3745 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3746 c  174   continue
3747 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3748 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3749 C Condition for being inside the proper box
3750 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3751 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3752 c        go to 174
3753 c        endif
3754 c  175   continue
3755 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3756 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3757 C Condition for being inside the proper box
3758 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3759 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3760 c        go to 175
3761 c        endif
3762 c  176   continue
3763 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3764 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3765 C Condition for being inside the proper box
3766 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3767 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3768 c        go to 176
3769 c        endif
3770 C        endif !endPBC condintion
3771 C        xj=xj-xmedi
3772 C        yj=yj-ymedi
3773 C        zj=zj-zmedi
3774           rij=xj*xj+yj*yj+zj*zj
3775
3776             sss=sscale(sqrt(rij))
3777             sssgrad=sscagrad(sqrt(rij))
3778 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3779 c     &       " rlamb",rlamb," sss",sss
3780 c            if (sss.gt.0.0d0) then
3781           rrmij=1.0D0/rij
3782           rij=dsqrt(rij)
3783           rmij=1.0D0/rij
3784           r3ij=rrmij*rmij
3785           r6ij=r3ij*r3ij
3786           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3787           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3788           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3789           fac=cosa-3.0D0*cosb*cosg
3790           ev1=aaa*r6ij*r6ij
3791 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3792           if (j.eq.i+2) ev1=scal_el*ev1
3793           ev2=bbb*r6ij
3794           fac3=ael6i*r6ij
3795           fac4=ael3i*r3ij
3796           evdwij=(ev1+ev2)
3797           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3798           el2=fac4*fac
3799 C MARYSIA
3800 C          eesij=(el1+el2)
3801 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3802           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3803           if (shield_mode.gt.0) then
3804 C          fac_shield(i)=0.4
3805 C          fac_shield(j)=0.6
3806           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3807           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3808           eesij=(el1+el2)
3809           ees=ees+eesij
3810           else
3811           fac_shield(i)=1.0
3812           fac_shield(j)=1.0
3813           eesij=(el1+el2)
3814           ees=ees+eesij
3815           endif
3816           evdw1=evdw1+evdwij*sss
3817 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3818 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3819 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3820 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3821
3822           if (energy_dec) then
3823               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3824      &'evdw1',i,j,evdwij
3825      &,iteli,itelj,aaa,evdw1,sss
3826               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3827      &fac_shield(i),fac_shield(j)
3828           endif
3829
3830 C
3831 C Calculate contributions to the Cartesian gradient.
3832 C
3833 #ifdef SPLITELE
3834           facvdw=-6*rrmij*(ev1+evdwij)*sss
3835           facel=-3*rrmij*(el1+eesij)
3836           fac1=fac
3837           erij(1)=xj*rmij
3838           erij(2)=yj*rmij
3839           erij(3)=zj*rmij
3840
3841 *
3842 * Radial derivatives. First process both termini of the fragment (i,j)
3843 *
3844           if (calc_grad) then
3845           ggg(1)=facel*xj
3846           ggg(2)=facel*yj
3847           ggg(3)=facel*zj
3848           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3849      &  (shield_mode.gt.0)) then
3850 C          print *,i,j
3851           do ilist=1,ishield_list(i)
3852            iresshield=shield_list(ilist,i)
3853            do k=1,3
3854            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3855      &      *2.0
3856            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3857      &              rlocshield
3858      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3859             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3860 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3861 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3862 C             if (iresshield.gt.i) then
3863 C               do ishi=i+1,iresshield-1
3864 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3865 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3866 C
3867 C              enddo
3868 C             else
3869 C               do ishi=iresshield,i
3870 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3871 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3872 C
3873 C               enddo
3874 C              endif
3875            enddo
3876           enddo
3877           do ilist=1,ishield_list(j)
3878            iresshield=shield_list(ilist,j)
3879            do k=1,3
3880            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3881      &     *2.0
3882            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3883      &              rlocshield
3884      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3885            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3886
3887 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3888 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3889 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3890 C             if (iresshield.gt.j) then
3891 C               do ishi=j+1,iresshield-1
3892 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3893 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3894 C
3895 C               enddo
3896 C            else
3897 C               do ishi=iresshield,j
3898 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3899 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3900 C               enddo
3901 C              endif
3902            enddo
3903           enddo
3904
3905           do k=1,3
3906             gshieldc(k,i)=gshieldc(k,i)+
3907      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3908             gshieldc(k,j)=gshieldc(k,j)+
3909      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3910             gshieldc(k,i-1)=gshieldc(k,i-1)+
3911      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3912             gshieldc(k,j-1)=gshieldc(k,j-1)+
3913      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3914
3915            enddo
3916            endif
3917 c          do k=1,3
3918 c            ghalf=0.5D0*ggg(k)
3919 c            gelc(k,i)=gelc(k,i)+ghalf
3920 c            gelc(k,j)=gelc(k,j)+ghalf
3921 c          enddo
3922 c 9/28/08 AL Gradient compotents will be summed only at the end
3923 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3924           do k=1,3
3925             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3926 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3927             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3928 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3929 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3930 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3931 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3932 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3933           enddo
3934 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3935
3936 *
3937 * Loop over residues i+1 thru j-1.
3938 *
3939 cgrad          do k=i+1,j-1
3940 cgrad            do l=1,3
3941 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3942 cgrad            enddo
3943 cgrad          enddo
3944           if (sss.gt.0.0) then
3945           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3946           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3947           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3948           else
3949           ggg(1)=0.0
3950           ggg(2)=0.0
3951           ggg(3)=0.0
3952           endif
3953 c          do k=1,3
3954 c            ghalf=0.5D0*ggg(k)
3955 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3956 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3957 c          enddo
3958 c 9/28/08 AL Gradient compotents will be summed only at the end
3959           do k=1,3
3960             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3961             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3962           enddo
3963 *
3964 * Loop over residues i+1 thru j-1.
3965 *
3966 cgrad          do k=i+1,j-1
3967 cgrad            do l=1,3
3968 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3969 cgrad            enddo
3970 cgrad          enddo
3971           endif ! calc_grad
3972 #else
3973 C MARYSIA
3974           facvdw=(ev1+evdwij)*sss
3975           facel=(el1+eesij)
3976           fac1=fac
3977           fac=-3*rrmij*(facvdw+facvdw+facel)
3978           erij(1)=xj*rmij
3979           erij(2)=yj*rmij
3980           erij(3)=zj*rmij
3981 *
3982 * Radial derivatives. First process both termini of the fragment (i,j)
3983 *
3984           if (calc_grad) then
3985           ggg(1)=fac*xj
3986 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3987           ggg(2)=fac*yj
3988 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3989           ggg(3)=fac*zj
3990 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3991 c          do k=1,3
3992 c            ghalf=0.5D0*ggg(k)
3993 c            gelc(k,i)=gelc(k,i)+ghalf
3994 c            gelc(k,j)=gelc(k,j)+ghalf
3995 c          enddo
3996 c 9/28/08 AL Gradient compotents will be summed only at the end
3997           do k=1,3
3998             gelc_long(k,j)=gelc(k,j)+ggg(k)
3999             gelc_long(k,i)=gelc(k,i)-ggg(k)
4000           enddo
4001 *
4002 * Loop over residues i+1 thru j-1.
4003 *
4004 cgrad          do k=i+1,j-1
4005 cgrad            do l=1,3
4006 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4007 cgrad            enddo
4008 cgrad          enddo
4009 c 9/28/08 AL Gradient compotents will be summed only at the end
4010           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4011           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4012           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4013           do k=1,3
4014             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4015             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4016           enddo
4017           endif ! calc_grad
4018 #endif
4019 *
4020 * Angular part
4021 *
4022           if (calc_grad) then
4023           ecosa=2.0D0*fac3*fac1+fac4
4024           fac4=-3.0D0*fac4
4025           fac3=-6.0D0*fac3
4026           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4027           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4028           do k=1,3
4029             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4030             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4031           enddo
4032 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4033 cd   &          (dcosg(k),k=1,3)
4034           do k=1,3
4035             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4036      &      fac_shield(i)**2*fac_shield(j)**2
4037           enddo
4038 c          do k=1,3
4039 c            ghalf=0.5D0*ggg(k)
4040 c            gelc(k,i)=gelc(k,i)+ghalf
4041 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4042 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4043 c            gelc(k,j)=gelc(k,j)+ghalf
4044 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4045 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4046 c          enddo
4047 cgrad          do k=i+1,j-1
4048 cgrad            do l=1,3
4049 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4050 cgrad            enddo
4051 cgrad          enddo
4052 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4053           do k=1,3
4054             gelc(k,i)=gelc(k,i)
4055      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4056      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4057      &           *fac_shield(i)**2*fac_shield(j)**2
4058             gelc(k,j)=gelc(k,j)
4059      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4060      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4061      &           *fac_shield(i)**2*fac_shield(j)**2
4062             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4063             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4064           enddo
4065 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4066
4067 C MARYSIA
4068 c          endif !sscale
4069           endif ! calc_grad
4070           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4071      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4072      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4073 C
4074 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4075 C   energy of a peptide unit is assumed in the form of a second-order
4076 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4077 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4078 C   are computed for EVERY pair of non-contiguous peptide groups.
4079 C
4080
4081           if (j.lt.nres-1) then
4082             j1=j+1
4083             j2=j-1
4084           else
4085             j1=j-1
4086             j2=j-2
4087           endif
4088           kkk=0
4089           lll=0
4090           do k=1,2
4091             do l=1,2
4092               kkk=kkk+1
4093               muij(kkk)=mu(k,i)*mu(l,j)
4094 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4095 #ifdef NEWCORR
4096              if (calc_grad) then
4097              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4098 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4099              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4100              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4101 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4102              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4103              endif
4104 #endif
4105             enddo
4106           enddo
4107 #ifdef DEBUG
4108           write (iout,*) 'EELEC: i',i,' j',j
4109           write (iout,*) 'j',j,' j1',j1,' j2',j2
4110           write(iout,*) 'muij',muij
4111           write (iout,*) "uy",uy(:,i)
4112           write (iout,*) "uz",uz(:,j)
4113           write (iout,*) "erij",erij
4114 #endif
4115           ury=scalar(uy(1,i),erij)
4116           urz=scalar(uz(1,i),erij)
4117           vry=scalar(uy(1,j),erij)
4118           vrz=scalar(uz(1,j),erij)
4119           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4120           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4121           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4122           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4123           fac=dsqrt(-ael6i)*r3ij
4124           a22=a22*fac
4125           a23=a23*fac
4126           a32=a32*fac
4127           a33=a33*fac
4128 cd          write (iout,'(4i5,4f10.5)')
4129 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4130 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4131 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4132 cd     &      uy(:,j),uz(:,j)
4133 cd          write (iout,'(4f10.5)')
4134 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4135 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4136 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4137 cd           write (iout,'(9f10.5/)')
4138 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4139 C Derivatives of the elements of A in virtual-bond vectors
4140           if (calc_grad) then
4141           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4142           do k=1,3
4143             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4144             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4145             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4146             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4147             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4148             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4149             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4150             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4151             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4152             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4153             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4154             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4155           enddo
4156 C Compute radial contributions to the gradient
4157           facr=-3.0d0*rrmij
4158           a22der=a22*facr
4159           a23der=a23*facr
4160           a32der=a32*facr
4161           a33der=a33*facr
4162           agg(1,1)=a22der*xj
4163           agg(2,1)=a22der*yj
4164           agg(3,1)=a22der*zj
4165           agg(1,2)=a23der*xj
4166           agg(2,2)=a23der*yj
4167           agg(3,2)=a23der*zj
4168           agg(1,3)=a32der*xj
4169           agg(2,3)=a32der*yj
4170           agg(3,3)=a32der*zj
4171           agg(1,4)=a33der*xj
4172           agg(2,4)=a33der*yj
4173           agg(3,4)=a33der*zj
4174 C Add the contributions coming from er
4175           fac3=-3.0d0*fac
4176           do k=1,3
4177             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4178             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4179             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4180             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4181           enddo
4182           do k=1,3
4183 C Derivatives in DC(i)
4184 cgrad            ghalf1=0.5d0*agg(k,1)
4185 cgrad            ghalf2=0.5d0*agg(k,2)
4186 cgrad            ghalf3=0.5d0*agg(k,3)
4187 cgrad            ghalf4=0.5d0*agg(k,4)
4188             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4189      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4190             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4191      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4192             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4193      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4194             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4195      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4196 C Derivatives in DC(i+1)
4197             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4198      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4199             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4200      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4201             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4202      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4203             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4204      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4205 C Derivatives in DC(j)
4206             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4207      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4208             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4209      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4210             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4211      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4212             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4213      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4214 C Derivatives in DC(j+1) or DC(nres-1)
4215             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4216      &      -3.0d0*vryg(k,3)*ury)
4217             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4218      &      -3.0d0*vrzg(k,3)*ury)
4219             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4220      &      -3.0d0*vryg(k,3)*urz)
4221             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4222      &      -3.0d0*vrzg(k,3)*urz)
4223 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4224 cgrad              do l=1,4
4225 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4226 cgrad              enddo
4227 cgrad            endif
4228           enddo
4229           endif ! calc_grad
4230           acipa(1,1)=a22
4231           acipa(1,2)=a23
4232           acipa(2,1)=a32
4233           acipa(2,2)=a33
4234           a22=-a22
4235           a23=-a23
4236           if (calc_grad) then
4237           do l=1,2
4238             do k=1,3
4239               agg(k,l)=-agg(k,l)
4240               aggi(k,l)=-aggi(k,l)
4241               aggi1(k,l)=-aggi1(k,l)
4242               aggj(k,l)=-aggj(k,l)
4243               aggj1(k,l)=-aggj1(k,l)
4244             enddo
4245           enddo
4246           endif ! calc_grad
4247           if (j.lt.nres-1) then
4248             a22=-a22
4249             a32=-a32
4250             do l=1,3,2
4251               do k=1,3
4252                 agg(k,l)=-agg(k,l)
4253                 aggi(k,l)=-aggi(k,l)
4254                 aggi1(k,l)=-aggi1(k,l)
4255                 aggj(k,l)=-aggj(k,l)
4256                 aggj1(k,l)=-aggj1(k,l)
4257               enddo
4258             enddo
4259           else
4260             a22=-a22
4261             a23=-a23
4262             a32=-a32
4263             a33=-a33
4264             do l=1,4
4265               do k=1,3
4266                 agg(k,l)=-agg(k,l)
4267                 aggi(k,l)=-aggi(k,l)
4268                 aggi1(k,l)=-aggi1(k,l)
4269                 aggj(k,l)=-aggj(k,l)
4270                 aggj1(k,l)=-aggj1(k,l)
4271               enddo
4272             enddo
4273           endif
4274           ENDIF ! WCORR
4275           IF (wel_loc.gt.0.0d0) THEN
4276 C Contribution to the local-electrostatic energy coming from the i-j pair
4277           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4278      &     +a33*muij(4)
4279 #ifdef DEBUG
4280           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4281      &     " a33",a33
4282           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4283      &     " wel_loc",wel_loc
4284 #endif
4285           if (shield_mode.eq.0) then
4286            fac_shield(i)=1.0
4287            fac_shield(j)=1.0
4288 C          else
4289 C           fac_shield(i)=0.4
4290 C           fac_shield(j)=0.6
4291           endif
4292           eel_loc_ij=eel_loc_ij
4293      &    *fac_shield(i)*fac_shield(j)
4294           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4295      &            'eelloc',i,j,eel_loc_ij
4296 c           if (eel_loc_ij.ne.0)
4297 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4298 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4299
4300           eel_loc=eel_loc+eel_loc_ij
4301 C Now derivative over eel_loc
4302           if (calc_grad) then
4303           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4304      &  (shield_mode.gt.0)) then
4305 C          print *,i,j
4306
4307           do ilist=1,ishield_list(i)
4308            iresshield=shield_list(ilist,i)
4309            do k=1,3
4310            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4311      &                                          /fac_shield(i)
4312 C     &      *2.0
4313            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4314      &              rlocshield
4315      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4316             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4317      &      +rlocshield
4318            enddo
4319           enddo
4320           do ilist=1,ishield_list(j)
4321            iresshield=shield_list(ilist,j)
4322            do k=1,3
4323            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4324      &                                       /fac_shield(j)
4325 C     &     *2.0
4326            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4327      &              rlocshield
4328      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4329            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4330      &             +rlocshield
4331
4332            enddo
4333           enddo
4334
4335           do k=1,3
4336             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4337      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4338             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4339      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4340             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4341      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4342             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4343      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4344            enddo
4345            endif
4346
4347
4348 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4349 c     &                     ' eel_loc_ij',eel_loc_ij
4350 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4351 C Calculate patrial derivative for theta angle
4352 #ifdef NEWCORR
4353          geel_loc_ij=(a22*gmuij1(1)
4354      &     +a23*gmuij1(2)
4355      &     +a32*gmuij1(3)
4356      &     +a33*gmuij1(4))
4357      &    *fac_shield(i)*fac_shield(j)
4358 c         write(iout,*) "derivative over thatai"
4359 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4360 c     &   a33*gmuij1(4)
4361          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4362      &      geel_loc_ij*wel_loc
4363          gloc_compon(7,nphi+i)=gloc_compon(7,nphi+i)+
4364      &      geel_loc_ij
4365 c         write(iout,*) "derivative over thatai-1"
4366 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4367 c     &   a33*gmuij2(4)
4368          geel_loc_ij=
4369      &     a22*gmuij2(1)
4370      &     +a23*gmuij2(2)
4371      &     +a32*gmuij2(3)
4372      &     +a33*gmuij2(4)
4373          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4374      &      geel_loc_ij*wel_loc
4375      &    *fac_shield(i)*fac_shield(j)
4376          gloc_compon(7,nphi+i-1)=gloc_compon(7,nphi+i-1)+
4377      &      geel_loc_ij*fac_shield(i)*fac_shield(j)
4378
4379 c  Derivative over j residue
4380          geel_loc_ji=a22*gmuji1(1)
4381      &     +a23*gmuji1(2)
4382      &     +a32*gmuji1(3)
4383      &     +a33*gmuji1(4)
4384 c         write(iout,*) "derivative over thataj"
4385 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4386 c     &   a33*gmuji1(4)
4387
4388         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4389      &      geel_loc_ji*wel_loc
4390      &    *fac_shield(i)*fac_shield(j)
4391          gloc_compon(7,nphi+j)=gloc_compon(7,nphi+j)+
4392      &      geel_loc_ji*fac_shield(i)*fac_shield(j)
4393          geel_loc_ji=
4394      &     +a22*gmuji2(1)
4395      &     +a23*gmuji2(2)
4396      &     +a32*gmuji2(3)
4397      &     +a33*gmuji2(4)
4398 c         write(iout,*) "derivative over thataj-1"
4399 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4400 c     &   a33*gmuji2(4)
4401          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4402      &      geel_loc_ji*wel_loc
4403      &    *fac_shield(i)*fac_shield(j)
4404          gloc_compon(7,nphi+j-1)=gloc_compon(7,nphi+j-1)+
4405      &      geel_loc_ji*fac_shield(i)*fac_shield(j)
4406 #endif
4407 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4408
4409 C Partial derivatives in virtual-bond dihedral angles gamma
4410           if (i.gt.1)
4411      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4412      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4413      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4414      &    *fac_shield(i)*fac_shield(j)
4415
4416           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4417      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4418      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4419      &    *fac_shield(i)*fac_shield(j)
4420 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4421           do l=1,3
4422             ggg(l)=(agg(l,1)*muij(1)+
4423      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4424      &    *fac_shield(i)*fac_shield(j)
4425             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4426             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4427 cgrad            ghalf=0.5d0*ggg(l)
4428 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4429 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4430           enddo
4431 cgrad          do k=i+1,j2
4432 cgrad            do l=1,3
4433 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4434 cgrad            enddo
4435 cgrad          enddo
4436 C Remaining derivatives of eello
4437           do l=1,3
4438             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4439      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4440      &    *fac_shield(i)*fac_shield(j)
4441
4442             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4443      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4444      &    *fac_shield(i)*fac_shield(j)
4445
4446             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4447      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4448      &    *fac_shield(i)*fac_shield(j)
4449
4450             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4451      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4452      &    *fac_shield(i)*fac_shield(j)
4453
4454           enddo
4455           endif ! calc_grad
4456           ENDIF
4457
4458
4459 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4460 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4461           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4462      &       .and. num_conti.le.maxconts) then
4463 c            write (iout,*) i,j," entered corr"
4464 C
4465 C Calculate the contact function. The ith column of the array JCONT will
4466 C contain the numbers of atoms that make contacts with the atom I (of numbers
4467 C greater than I). The arrays FACONT and GACONT will contain the values of
4468 C the contact function and its derivative.
4469 c           r0ij=1.02D0*rpp(iteli,itelj)
4470 c           r0ij=1.11D0*rpp(iteli,itelj)
4471             r0ij=2.20D0*rpp(iteli,itelj)
4472 c           r0ij=1.55D0*rpp(iteli,itelj)
4473             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4474             if (fcont.gt.0.0D0) then
4475               num_conti=num_conti+1
4476               if (num_conti.gt.maxconts) then
4477                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4478      &                         ' will skip next contacts for this conf.'
4479               else
4480                 jcont_hb(num_conti,i)=j
4481 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4482 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4483                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4484      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4485 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4486 C  terms.
4487                 d_cont(num_conti,i)=rij
4488 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4489 C     --- Electrostatic-interaction matrix ---
4490                 a_chuj(1,1,num_conti,i)=a22
4491                 a_chuj(1,2,num_conti,i)=a23
4492                 a_chuj(2,1,num_conti,i)=a32
4493                 a_chuj(2,2,num_conti,i)=a33
4494 C     --- Gradient of rij
4495                 if (calc_grad) then
4496                 do kkk=1,3
4497                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4498                 enddo
4499                 kkll=0
4500                 do k=1,2
4501                   do l=1,2
4502                     kkll=kkll+1
4503                     do m=1,3
4504                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4505                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4506                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4507                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4508                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4509                     enddo
4510                   enddo
4511                 enddo
4512                 endif ! calc_grad
4513                 ENDIF
4514                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4515 C Calculate contact energies
4516                 cosa4=4.0D0*cosa
4517                 wij=cosa-3.0D0*cosb*cosg
4518                 cosbg1=cosb+cosg
4519                 cosbg2=cosb-cosg
4520 c               fac3=dsqrt(-ael6i)/r0ij**3
4521                 fac3=dsqrt(-ael6i)*r3ij
4522 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4523                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4524                 if (ees0tmp.gt.0) then
4525                   ees0pij=dsqrt(ees0tmp)
4526                 else
4527                   ees0pij=0
4528                 endif
4529 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4530                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4531                 if (ees0tmp.gt.0) then
4532                   ees0mij=dsqrt(ees0tmp)
4533                 else
4534                   ees0mij=0
4535                 endif
4536 c               ees0mij=0.0D0
4537                 if (shield_mode.eq.0) then
4538                 fac_shield(i)=1.0d0
4539                 fac_shield(j)=1.0d0
4540                 else
4541                 ees0plist(num_conti,i)=j
4542 C                fac_shield(i)=0.4d0
4543 C                fac_shield(j)=0.6d0
4544                 endif
4545                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4546      &          *fac_shield(i)*fac_shield(j)
4547                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4548      &          *fac_shield(i)*fac_shield(j)
4549 C Diagnostics. Comment out or remove after debugging!
4550 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4551 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4552 c               ees0m(num_conti,i)=0.0D0
4553 C End diagnostics.
4554 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4555 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4556 C Angular derivatives of the contact function
4557
4558                 ees0pij1=fac3/ees0pij
4559                 ees0mij1=fac3/ees0mij
4560                 fac3p=-3.0D0*fac3*rrmij
4561                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4562                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4563 c               ees0mij1=0.0D0
4564                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4565                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4566                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4567                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4568                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4569                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4570                 ecosap=ecosa1+ecosa2
4571                 ecosbp=ecosb1+ecosb2
4572                 ecosgp=ecosg1+ecosg2
4573                 ecosam=ecosa1-ecosa2
4574                 ecosbm=ecosb1-ecosb2
4575                 ecosgm=ecosg1-ecosg2
4576 C Diagnostics
4577 c               ecosap=ecosa1
4578 c               ecosbp=ecosb1
4579 c               ecosgp=ecosg1
4580 c               ecosam=0.0D0
4581 c               ecosbm=0.0D0
4582 c               ecosgm=0.0D0
4583 C End diagnostics
4584                 facont_hb(num_conti,i)=fcont
4585
4586                 if (calc_grad) then
4587                 fprimcont=fprimcont/rij
4588 cd              facont_hb(num_conti,i)=1.0D0
4589 C Following line is for diagnostics.
4590 cd              fprimcont=0.0D0
4591                 do k=1,3
4592                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4593                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4594                 enddo
4595                 do k=1,3
4596                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4597                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4598                 enddo
4599                 gggp(1)=gggp(1)+ees0pijp*xj
4600                 gggp(2)=gggp(2)+ees0pijp*yj
4601                 gggp(3)=gggp(3)+ees0pijp*zj
4602                 gggm(1)=gggm(1)+ees0mijp*xj
4603                 gggm(2)=gggm(2)+ees0mijp*yj
4604                 gggm(3)=gggm(3)+ees0mijp*zj
4605 C Derivatives due to the contact function
4606                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4607                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4608                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4609                 do k=1,3
4610 c
4611 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4612 c          following the change of gradient-summation algorithm.
4613 c
4614 cgrad                  ghalfp=0.5D0*gggp(k)
4615 cgrad                  ghalfm=0.5D0*gggm(k)
4616                   gacontp_hb1(k,num_conti,i)=!ghalfp
4617      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4618      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4619      &          *fac_shield(i)*fac_shield(j)
4620
4621                   gacontp_hb2(k,num_conti,i)=!ghalfp
4622      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4623      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4624      &          *fac_shield(i)*fac_shield(j)
4625
4626                   gacontp_hb3(k,num_conti,i)=gggp(k)
4627      &          *fac_shield(i)*fac_shield(j)
4628
4629                   gacontm_hb1(k,num_conti,i)=!ghalfm
4630      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4631      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4632      &          *fac_shield(i)*fac_shield(j)
4633
4634                   gacontm_hb2(k,num_conti,i)=!ghalfm
4635      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4636      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4637      &          *fac_shield(i)*fac_shield(j)
4638
4639                   gacontm_hb3(k,num_conti,i)=gggm(k)
4640      &          *fac_shield(i)*fac_shield(j)
4641
4642                 enddo
4643 C Diagnostics. Comment out or remove after debugging!
4644 cdiag           do k=1,3
4645 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4646 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4647 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4648 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4649 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4650 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4651 cdiag           enddo
4652
4653                  endif ! calc_grad
4654
4655               ENDIF ! wcorr
4656               endif  ! num_conti.le.maxconts
4657             endif  ! fcont.gt.0
4658           endif    ! j.gt.i+1
4659           if (calc_grad) then
4660           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4661             do k=1,4
4662               do l=1,3
4663                 ghalf=0.5d0*agg(l,k)
4664                 aggi(l,k)=aggi(l,k)+ghalf
4665                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4666                 aggj(l,k)=aggj(l,k)+ghalf
4667               enddo
4668             enddo
4669             if (j.eq.nres-1 .and. i.lt.j-2) then
4670               do k=1,4
4671                 do l=1,3
4672                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4673                 enddo
4674               enddo
4675             endif
4676           endif
4677           endif ! calc_grad
4678 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4679       return
4680       end
4681 C-----------------------------------------------------------------------------
4682       subroutine eturn3(i,eello_turn3)
4683 C Third- and fourth-order contributions from turns
4684       implicit real*8 (a-h,o-z)
4685       include 'DIMENSIONS'
4686       include 'DIMENSIONS.ZSCOPT'
4687       include 'COMMON.IOUNITS'
4688       include 'COMMON.GEO'
4689       include 'COMMON.VAR'
4690       include 'COMMON.LOCAL'
4691       include 'COMMON.CHAIN'
4692       include 'COMMON.DERIV'
4693       include 'COMMON.INTERACT'
4694       include 'COMMON.CONTACTS'
4695       include 'COMMON.TORSION'
4696       include 'COMMON.VECTORS'
4697       include 'COMMON.FFIELD'
4698       include 'COMMON.CONTROL'
4699       include 'COMMON.SHIELD'
4700       dimension ggg(3)
4701       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4702      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4703      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4704      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4705      &  auxgmat2(2,2),auxgmatt2(2,2)
4706       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4707      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4708       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4709      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4710      &    num_conti,j1,j2
4711       j=i+2
4712 c      write (iout,*) "eturn3",i,j,j1,j2
4713       a_temp(1,1)=a22
4714       a_temp(1,2)=a23
4715       a_temp(2,1)=a32
4716       a_temp(2,2)=a33
4717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4718 C
4719 C               Third-order contributions
4720 C
4721 C                 (i+2)o----(i+3)
4722 C                      | |
4723 C                      | |
4724 C                 (i+1)o----i
4725 C
4726 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4727 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4728         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4729 c auxalary matices for theta gradient
4730 c auxalary matrix for i+1 and constant i+2
4731         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4732 c auxalary matrix for i+2 and constant i+1
4733         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4734         call transpose2(auxmat(1,1),auxmat1(1,1))
4735         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4736         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4737         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4738         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4739         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4740         if (shield_mode.eq.0) then
4741         fac_shield(i)=1.0
4742         fac_shield(j)=1.0
4743 C        else
4744 C        fac_shield(i)=0.4
4745 C        fac_shield(j)=0.6
4746         endif
4747         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4748      &  *fac_shield(i)*fac_shield(j)
4749         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4750      &  *fac_shield(i)*fac_shield(j)
4751         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4752      &    eello_t3
4753         if (calc_grad) then
4754 C#ifdef NEWCORR
4755 C Derivatives in theta
4756         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4757      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4758      &   *fac_shield(i)*fac_shield(j)
4759         gloc_compon(8,nphi+i)=gloc_compon(8,nphi+i)+
4760      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))
4761      &   *fac_shield(i)*fac_shield(j)
4762         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4763      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4764      &   *fac_shield(i)*fac_shield(j)
4765         gloc_compon(8,nphi+i+1)=gloc_compon(8,nphi+i+1)+
4766      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))
4767      &   *fac_shield(i)*fac_shield(j)
4768 C#endif
4769
4770 C Derivatives in shield mode
4771           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4772      &  (shield_mode.gt.0)) then
4773 C          print *,i,j
4774
4775           do ilist=1,ishield_list(i)
4776            iresshield=shield_list(ilist,i)
4777            do k=1,3
4778            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4779 C     &      *2.0
4780            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4781      &              rlocshield
4782      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4783             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4784      &      +rlocshield
4785            enddo
4786           enddo
4787           do ilist=1,ishield_list(j)
4788            iresshield=shield_list(ilist,j)
4789            do k=1,3
4790            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4791 C     &     *2.0
4792            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4793      &              rlocshield
4794      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4795            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4796      &             +rlocshield
4797
4798            enddo
4799           enddo
4800
4801           do k=1,3
4802             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4803      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4804             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4805      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4806             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4807      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4808             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4809      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4810            enddo
4811            endif
4812
4813 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4814 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4815 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4816 cd     &    ' eello_turn3_num',4*eello_turn3_num
4817 C Derivatives in gamma(i)
4818         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4819         call transpose2(auxmat2(1,1),auxmat3(1,1))
4820         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4821         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4822      &   *fac_shield(i)*fac_shield(j)
4823 C Derivatives in gamma(i+1)
4824         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4825         call transpose2(auxmat2(1,1),auxmat3(1,1))
4826         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4827         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4828      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4829      &   *fac_shield(i)*fac_shield(j)
4830 C Cartesian derivatives
4831         do l=1,3
4832 c            ghalf1=0.5d0*agg(l,1)
4833 c            ghalf2=0.5d0*agg(l,2)
4834 c            ghalf3=0.5d0*agg(l,3)
4835 c            ghalf4=0.5d0*agg(l,4)
4836           a_temp(1,1)=aggi(l,1)!+ghalf1
4837           a_temp(1,2)=aggi(l,2)!+ghalf2
4838           a_temp(2,1)=aggi(l,3)!+ghalf3
4839           a_temp(2,2)=aggi(l,4)!+ghalf4
4840           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4841           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4842      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4843      &   *fac_shield(i)*fac_shield(j)
4844
4845           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4846           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4847           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4848           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4849           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4850           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4851      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4852      &   *fac_shield(i)*fac_shield(j)
4853           a_temp(1,1)=aggj(l,1)!+ghalf1
4854           a_temp(1,2)=aggj(l,2)!+ghalf2
4855           a_temp(2,1)=aggj(l,3)!+ghalf3
4856           a_temp(2,2)=aggj(l,4)!+ghalf4
4857           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4858           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4859      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4860      &   *fac_shield(i)*fac_shield(j)
4861           a_temp(1,1)=aggj1(l,1)
4862           a_temp(1,2)=aggj1(l,2)
4863           a_temp(2,1)=aggj1(l,3)
4864           a_temp(2,2)=aggj1(l,4)
4865           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4866           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4867      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4868      &   *fac_shield(i)*fac_shield(j)
4869         enddo
4870
4871         endif ! calc_grad
4872
4873       return
4874       end
4875 C-------------------------------------------------------------------------------
4876       subroutine eturn4(i,eello_turn4)
4877 C Third- and fourth-order contributions from turns
4878       implicit real*8 (a-h,o-z)
4879       include 'DIMENSIONS'
4880       include 'DIMENSIONS.ZSCOPT'
4881       include 'COMMON.IOUNITS'
4882       include 'COMMON.GEO'
4883       include 'COMMON.VAR'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.CHAIN'
4886       include 'COMMON.DERIV'
4887       include 'COMMON.INTERACT'
4888       include 'COMMON.CONTACTS'
4889       include 'COMMON.TORSION'
4890       include 'COMMON.VECTORS'
4891       include 'COMMON.FFIELD'
4892       include 'COMMON.CONTROL'
4893       include 'COMMON.SHIELD'
4894       dimension ggg(3)
4895       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4896      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4897      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4898      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4899      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4900      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4901      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4902       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4903      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4904       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4905      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4906      &    num_conti,j1,j2
4907       j=i+3
4908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4909 C
4910 C               Fourth-order contributions
4911 C
4912 C                 (i+3)o----(i+4)
4913 C                     /  |
4914 C               (i+2)o   |
4915 C                     \  |
4916 C                 (i+1)o----i
4917 C
4918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4919 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4920 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4921 c        write(iout,*)"WCHODZE W PROGRAM"
4922         a_temp(1,1)=a22
4923         a_temp(1,2)=a23
4924         a_temp(2,1)=a32
4925         a_temp(2,2)=a33
4926         iti1=itype2loc(itype(i+1))
4927         iti2=itype2loc(itype(i+2))
4928         iti3=itype2loc(itype(i+3))
4929 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4930         call transpose2(EUg(1,1,i+1),e1t(1,1))
4931         call transpose2(Eug(1,1,i+2),e2t(1,1))
4932         call transpose2(Eug(1,1,i+3),e3t(1,1))
4933 C Ematrix derivative in theta
4934         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4935         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4936         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4937         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4938 c       eta1 in derivative theta
4939         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4940         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4941 c       auxgvec is derivative of Ub2 so i+3 theta
4942         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4943 c       auxalary matrix of E i+1
4944         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4945 c        s1=0.0
4946 c        gs1=0.0
4947         s1=scalar2(b1(1,i+2),auxvec(1))
4948 c derivative of theta i+2 with constant i+3
4949         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4950 c derivative of theta i+2 with constant i+2
4951         gs32=scalar2(b1(1,i+2),auxgvec(1))
4952 c derivative of E matix in theta of i+1
4953         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4954
4955         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4956 c       ea31 in derivative theta
4957         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4958         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4959 c auxilary matrix auxgvec of Ub2 with constant E matirx
4960         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4961 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4962         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4963
4964 c        s2=0.0
4965 c        gs2=0.0
4966         s2=scalar2(b1(1,i+1),auxvec(1))
4967 c derivative of theta i+1 with constant i+3
4968         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4969 c derivative of theta i+2 with constant i+1
4970         gs21=scalar2(b1(1,i+1),auxgvec(1))
4971 c derivative of theta i+3 with constant i+1
4972         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4973 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4974 c     &  gtb1(1,i+1)
4975         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4976 c two derivatives over diffetent matrices
4977 c gtae3e2 is derivative over i+3
4978         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4979 c ae3gte2 is derivative over i+2
4980         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4981         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4982 c three possible derivative over theta E matices
4983 c i+1
4984         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4985 c i+2
4986         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4987 c i+3
4988         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4989         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4990
4991         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4992         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4993         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4994         if (shield_mode.eq.0) then
4995         fac_shield(i)=1.0
4996         fac_shield(j)=1.0
4997 C        else
4998 C        fac_shield(i)=0.6
4999 C        fac_shield(j)=0.4
5000         endif
5001         eello_turn4=eello_turn4-(s1+s2+s3)
5002      &  *fac_shield(i)*fac_shield(j)
5003         eello_t4=-(s1+s2+s3)
5004      &  *fac_shield(i)*fac_shield(j)
5005 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5006         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5007      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5008 C Now derivative over shield:
5009           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5010      &  (shield_mode.gt.0)) then
5011 C          print *,i,j
5012
5013           do ilist=1,ishield_list(i)
5014            iresshield=shield_list(ilist,i)
5015            do k=1,3
5016            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5017 C     &      *2.0
5018            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5019      &              rlocshield
5020      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5021             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5022      &      +rlocshield
5023            enddo
5024           enddo
5025           do ilist=1,ishield_list(j)
5026            iresshield=shield_list(ilist,j)
5027            do k=1,3
5028            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5029 C     &     *2.0
5030            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5031      &              rlocshield
5032      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5033            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5034      &             +rlocshield
5035
5036            enddo
5037           enddo
5038
5039           do k=1,3
5040             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5041      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5042             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5043      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5044             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5045      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5046             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5047      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5048            enddo
5049            endif
5050 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5051 cd     &    ' eello_turn4_num',8*eello_turn4_num
5052 #ifdef NEWCORR
5053         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5054      &                  -(gs13+gsE13+gsEE1)*wturn4
5055      &  *fac_shield(i)*fac_shield(j)
5056         gloc_compon(9,nphi+i)=gloc_compon(9,nphi+i)
5057      &     -(gs13+gsE13+gsEE1)*fac_shield(i)*fac_shield(j)
5058         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5059      &                    -(gs23+gs21+gsEE2)*wturn4
5060      &  *fac_shield(i)*fac_shield(j)
5061
5062         gloc_compon(9,nphi+i+1)=gloc_compon(9,nphi+i+1)
5063      &     -(gs23+gs21+gsEE2)*fac_shield(i)*fac_shield(j)
5064         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5065      &                    -(gs32+gsE31+gsEE3)*wturn4
5066      &  *fac_shield(i)*fac_shield(j)
5067         gloc_compon(9,nphi+i+2)=gloc_compon(9,nphi+i+2)
5068      &     -(gs32+gsE31+gsEE3)*fac_shield(i)*fac_shield(j)
5069
5070 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5071 c     &   gs2
5072 #endif
5073         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5074      &      'eturn4',i,j,-(s1+s2+s3)
5075 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5076 c     &    ' eello_turn4_num',8*eello_turn4_num
5077 C Derivatives in gamma(i)
5078         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5079         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5080         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5081         s1=scalar2(b1(1,i+2),auxvec(1))
5082         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5083         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5084         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5085      &  *fac_shield(i)*fac_shield(j)
5086 C Derivatives in gamma(i+1)
5087         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5088         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5089         s2=scalar2(b1(1,i+1),auxvec(1))
5090         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5091         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5092         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5093         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5094      &  *fac_shield(i)*fac_shield(j)
5095 C Derivatives in gamma(i+2)
5096         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5097         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5098         s1=scalar2(b1(1,i+2),auxvec(1))
5099         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5100         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5101         s2=scalar2(b1(1,i+1),auxvec(1))
5102         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5103         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5104         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5105         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5106      &  *fac_shield(i)*fac_shield(j)
5107         if (calc_grad) then
5108 C Cartesian derivatives
5109 C Derivatives of this turn contributions in DC(i+2)
5110         if (j.lt.nres-1) then
5111           do l=1,3
5112             a_temp(1,1)=agg(l,1)
5113             a_temp(1,2)=agg(l,2)
5114             a_temp(2,1)=agg(l,3)
5115             a_temp(2,2)=agg(l,4)
5116             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5117             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5118             s1=scalar2(b1(1,i+2),auxvec(1))
5119             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5120             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5121             s2=scalar2(b1(1,i+1),auxvec(1))
5122             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5123             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5124             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5125             ggg(l)=-(s1+s2+s3)
5126             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5127      &  *fac_shield(i)*fac_shield(j)
5128           enddo
5129         endif
5130 C Remaining derivatives of this turn contribution
5131         do l=1,3
5132           a_temp(1,1)=aggi(l,1)
5133           a_temp(1,2)=aggi(l,2)
5134           a_temp(2,1)=aggi(l,3)
5135           a_temp(2,2)=aggi(l,4)
5136           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5137           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5138           s1=scalar2(b1(1,i+2),auxvec(1))
5139           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5140           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5141           s2=scalar2(b1(1,i+1),auxvec(1))
5142           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5143           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5144           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5145           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5146      &  *fac_shield(i)*fac_shield(j)
5147           a_temp(1,1)=aggi1(l,1)
5148           a_temp(1,2)=aggi1(l,2)
5149           a_temp(2,1)=aggi1(l,3)
5150           a_temp(2,2)=aggi1(l,4)
5151           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5152           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5153           s1=scalar2(b1(1,i+2),auxvec(1))
5154           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5155           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5156           s2=scalar2(b1(1,i+1),auxvec(1))
5157           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5158           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5159           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5160           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5161      &  *fac_shield(i)*fac_shield(j)
5162           a_temp(1,1)=aggj(l,1)
5163           a_temp(1,2)=aggj(l,2)
5164           a_temp(2,1)=aggj(l,3)
5165           a_temp(2,2)=aggj(l,4)
5166           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5167           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5168           s1=scalar2(b1(1,i+2),auxvec(1))
5169           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5170           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5171           s2=scalar2(b1(1,i+1),auxvec(1))
5172           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5173           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5174           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5175           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5176      &  *fac_shield(i)*fac_shield(j)
5177           a_temp(1,1)=aggj1(l,1)
5178           a_temp(1,2)=aggj1(l,2)
5179           a_temp(2,1)=aggj1(l,3)
5180           a_temp(2,2)=aggj1(l,4)
5181           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5182           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5183           s1=scalar2(b1(1,i+2),auxvec(1))
5184           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5185           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5186           s2=scalar2(b1(1,i+1),auxvec(1))
5187           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5188           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5189           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5190 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5191           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5192      &  *fac_shield(i)*fac_shield(j)
5193         enddo
5194
5195         endif ! calc_grad
5196
5197       return
5198       end
5199 C-----------------------------------------------------------------------------
5200       subroutine vecpr(u,v,w)
5201       implicit real*8(a-h,o-z)
5202       dimension u(3),v(3),w(3)
5203       w(1)=u(2)*v(3)-u(3)*v(2)
5204       w(2)=-u(1)*v(3)+u(3)*v(1)
5205       w(3)=u(1)*v(2)-u(2)*v(1)
5206       return
5207       end
5208 C-----------------------------------------------------------------------------
5209       subroutine unormderiv(u,ugrad,unorm,ungrad)
5210 C This subroutine computes the derivatives of a normalized vector u, given
5211 C the derivatives computed without normalization conditions, ugrad. Returns
5212 C ungrad.
5213       implicit none
5214       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5215       double precision vec(3)
5216       double precision scalar
5217       integer i,j
5218 c      write (2,*) 'ugrad',ugrad
5219 c      write (2,*) 'u',u
5220       do i=1,3
5221         vec(i)=scalar(ugrad(1,i),u(1))
5222       enddo
5223 c      write (2,*) 'vec',vec
5224       do i=1,3
5225         do j=1,3
5226           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5227         enddo
5228       enddo
5229 c      write (2,*) 'ungrad',ungrad
5230       return
5231       end
5232 C-----------------------------------------------------------------------------
5233       subroutine escp(evdw2,evdw2_14)
5234 C
5235 C This subroutine calculates the excluded-volume interaction energy between
5236 C peptide-group centers and side chains and its gradient in virtual-bond and
5237 C side-chain vectors.
5238 C
5239       implicit real*8 (a-h,o-z)
5240       include 'DIMENSIONS'
5241       include 'DIMENSIONS.ZSCOPT'
5242       include 'COMMON.GEO'
5243       include 'COMMON.VAR'
5244       include 'COMMON.LOCAL'
5245       include 'COMMON.CHAIN'
5246       include 'COMMON.DERIV'
5247       include 'COMMON.INTERACT'
5248       include 'COMMON.FFIELD'
5249       include 'COMMON.IOUNITS'
5250       dimension ggg(3)
5251       evdw2=0.0D0
5252       evdw2_14=0.0d0
5253 cd    print '(a)','Enter ESCP'
5254 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5255 c     &  ' scal14',scal14
5256       do i=iatscp_s,iatscp_e
5257         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5258         iteli=itel(i)
5259 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5260 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5261         if (iteli.eq.0) goto 1225
5262         xi=0.5D0*(c(1,i)+c(1,i+1))
5263         yi=0.5D0*(c(2,i)+c(2,i+1))
5264         zi=0.5D0*(c(3,i)+c(3,i+1))
5265 C Returning the ith atom to box
5266           xi=mod(xi,boxxsize)
5267           if (xi.lt.0) xi=xi+boxxsize
5268           yi=mod(yi,boxysize)
5269           if (yi.lt.0) yi=yi+boxysize
5270           zi=mod(zi,boxzsize)
5271           if (zi.lt.0) zi=zi+boxzsize
5272         do iint=1,nscp_gr(i)
5273
5274         do j=iscpstart(i,iint),iscpend(i,iint)
5275           itypj=iabs(itype(j))
5276           if (itypj.eq.ntyp1) cycle
5277 C Uncomment following three lines for SC-p interactions
5278 c         xj=c(1,nres+j)-xi
5279 c         yj=c(2,nres+j)-yi
5280 c         zj=c(3,nres+j)-zi
5281 C Uncomment following three lines for Ca-p interactions
5282           xj=c(1,j)
5283           yj=c(2,j)
5284           zj=c(3,j)
5285 C returning the jth atom to box
5286           xj=mod(xj,boxxsize)
5287           if (xj.lt.0) xj=xj+boxxsize
5288           yj=mod(yj,boxysize)
5289           if (yj.lt.0) yj=yj+boxysize
5290           zj=mod(zj,boxzsize)
5291           if (zj.lt.0) zj=zj+boxzsize
5292       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5293       xj_safe=xj
5294       yj_safe=yj
5295       zj_safe=zj
5296       subchap=0
5297 C Finding the closest jth atom
5298       do xshift=-1,1
5299       do yshift=-1,1
5300       do zshift=-1,1
5301           xj=xj_safe+xshift*boxxsize
5302           yj=yj_safe+yshift*boxysize
5303           zj=zj_safe+zshift*boxzsize
5304           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5305           if(dist_temp.lt.dist_init) then
5306             dist_init=dist_temp
5307             xj_temp=xj
5308             yj_temp=yj
5309             zj_temp=zj
5310             subchap=1
5311           endif
5312        enddo
5313        enddo
5314        enddo
5315        if (subchap.eq.1) then
5316           xj=xj_temp-xi
5317           yj=yj_temp-yi
5318           zj=zj_temp-zi
5319        else
5320           xj=xj_safe-xi
5321           yj=yj_safe-yi
5322           zj=zj_safe-zi
5323        endif
5324           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5325 C sss is scaling function for smoothing the cutoff gradient otherwise
5326 C the gradient would not be continuouse
5327           sss=sscale(1.0d0/(dsqrt(rrij)))
5328           if (sss.le.0.0d0) cycle
5329           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5330           fac=rrij**expon2
5331           e1=fac*fac*aad(itypj,iteli)
5332           e2=fac*bad(itypj,iteli)
5333           if (iabs(j-i) .le. 2) then
5334             e1=scal14*e1
5335             e2=scal14*e2
5336             evdw2_14=evdw2_14+(e1+e2)*sss
5337           endif
5338           evdwij=e1+e2
5339 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5340 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5341 c     &       bad(itypj,iteli)
5342           evdw2=evdw2+evdwij*sss
5343           if (calc_grad) then
5344 C
5345 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5346 C
5347           fac=-(evdwij+e1)*rrij*sss
5348           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5349           ggg(1)=xj*fac
5350           ggg(2)=yj*fac
5351           ggg(3)=zj*fac
5352 c          if (j.lt.i) then
5353 cd          write (iout,*) 'j<i'
5354 C Uncomment following three lines for SC-p interactions
5355 c           do k=1,3
5356 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5357 c           enddo
5358 c          else
5359 cd          write (iout,*) 'j>i'
5360 c            do k=1,3
5361 c              ggg(k)=-ggg(k)
5362 C Uncomment following line for SC-p interactions
5363 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5364 c            enddo
5365 c          endif
5366           do k=1,3
5367             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5368             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5369           enddo
5370           kstart=min0(i+1,j)
5371           kend=max0(i-1,j-1)
5372 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5373 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5374 c          do k=kstart,kend
5375 c            do l=1,3
5376 c              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5377 c            enddo
5378 c          enddo
5379           endif ! calc_grad
5380         enddo
5381         enddo ! iint
5382  1225   continue
5383       enddo ! i
5384       do i=1,nct
5385         do j=1,3
5386           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5387           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5388           gradx_scp(j,i)=expon*gradx_scp(j,i)
5389         enddo
5390       enddo
5391 C******************************************************************************
5392 C
5393 C                              N O T E !!!
5394 C
5395 C To save time the factor EXPON has been extracted from ALL components
5396 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5397 C use!
5398 C
5399 C******************************************************************************
5400 c      write (iout,*) "gvdwc_scp"
5401 c      do i=1,nres
5402 c        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gvdwc_scp(j,i),j=1,3),
5403 c     &    (gvdwc_scpp(j,i),j=1,3)
5404 c      enddo
5405       return
5406       end
5407 C--------------------------------------------------------------------------
5408       subroutine edis(ehpb)
5409 C
5410 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5411 C
5412       implicit real*8 (a-h,o-z)
5413       include 'DIMENSIONS'
5414       include 'DIMENSIONS.ZSCOPT'
5415       include 'COMMON.SBRIDGE'
5416       include 'COMMON.CHAIN'
5417       include 'COMMON.DERIV'
5418       include 'COMMON.VAR'
5419       include 'COMMON.INTERACT'
5420       include 'COMMON.CONTROL'
5421       include 'COMMON.IOUNITS'
5422       dimension ggg(3)
5423       ehpb=0.0D0
5424 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5425 cd    print *,'link_start=',link_start,' link_end=',link_end
5426 C      write(iout,*) link_end, "link_end"
5427       if (link_end.eq.0) return
5428       do i=link_start,link_end
5429 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5430 C CA-CA distance used in regularization of structure.
5431         ii=ihpb(i)
5432         jj=jhpb(i)
5433 C iii and jjj point to the residues for which the distance is assigned.
5434         if (ii.gt.nres) then
5435           iii=ii-nres
5436           jjj=jj-nres
5437         else
5438           iii=ii
5439           jjj=jj
5440         endif
5441 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5442 C    distance and angle dependent SS bond potential.
5443 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5444 C     & iabs(itype(jjj)).eq.1) then
5445 C       write(iout,*) constr_dist,"const"
5446        if (.not.dyn_ss .and. i.le.nss) then
5447          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5448      & iabs(itype(jjj)).eq.1) then
5449           call ssbond_ene(iii,jjj,eij)
5450           ehpb=ehpb+2*eij
5451            endif !ii.gt.neres
5452         else if (ii.gt.nres .and. jj.gt.nres) then
5453 c Restraints from contact prediction
5454           dd=dist(ii,jj)
5455           if (constr_dist.eq.11) then
5456 C            ehpb=ehpb+fordepth(i)**4.0d0
5457 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5458             ehpb=ehpb+fordepth(i)**4.0d0
5459      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5460             fac=fordepth(i)**4.0d0
5461      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5462 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5463 C     &    ehpb,fordepth(i),dd
5464 C            write(iout,*) ehpb,"atu?"
5465 C            ehpb,"tu?"
5466 C            fac=fordepth(i)**4.0d0
5467 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5468            else
5469           if (dhpb1(i).gt.0.0d0) then
5470             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5471             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5472 c            write (iout,*) "beta nmr",
5473 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5474           else
5475             dd=dist(ii,jj)
5476             rdis=dd-dhpb(i)
5477 C Get the force constant corresponding to this distance.
5478             waga=forcon(i)
5479 C Calculate the contribution to energy.
5480             ehpb=ehpb+waga*rdis*rdis
5481 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5482 C
5483 C Evaluate gradient.
5484 C
5485             fac=waga*rdis/dd
5486           endif !end dhpb1(i).gt.0
5487           endif !end const_dist=11
5488           do j=1,3
5489             ggg(j)=fac*(c(j,jj)-c(j,ii))
5490           enddo
5491           do j=1,3
5492             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5493             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5494           enddo
5495           do k=1,3
5496             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5497             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5498           enddo
5499         else !ii.gt.nres
5500 C          write(iout,*) "before"
5501           dd=dist(ii,jj)
5502 C          write(iout,*) "after",dd
5503           if (constr_dist.eq.11) then
5504             ehpb=ehpb+fordepth(i)**4.0d0
5505      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5506             fac=fordepth(i)**4.0d0
5507      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5508 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5509 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5510 C            print *,ehpb,"tu?"
5511 C            write(iout,*) ehpb,"btu?",
5512 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5513 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5514 C     &    ehpb,fordepth(i),dd
5515            else
5516           if (dhpb1(i).gt.0.0d0) then
5517             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5518             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5519 c            write (iout,*) "alph nmr",
5520 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5521           else
5522             rdis=dd-dhpb(i)
5523 C Get the force constant corresponding to this distance.
5524             waga=forcon(i)
5525 C Calculate the contribution to energy.
5526             ehpb=ehpb+waga*rdis*rdis
5527 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5528 C
5529 C Evaluate gradient.
5530 C
5531             fac=waga*rdis/dd
5532           endif
5533           endif
5534
5535         do j=1,3
5536           ggg(j)=fac*(c(j,jj)-c(j,ii))
5537         enddo
5538 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5539 C If this is a SC-SC distance, we need to calculate the contributions to the
5540 C Cartesian gradient in the SC vectors (ghpbx).
5541         if (iii.lt.ii) then
5542           do j=1,3
5543             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5544             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5545           enddo
5546         endif
5547         do j=iii,jjj-1
5548           do k=1,3
5549             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5550           enddo
5551         enddo
5552         endif
5553       enddo
5554       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5555       return
5556       end
5557 C--------------------------------------------------------------------------
5558       subroutine ssbond_ene(i,j,eij)
5559 C
5560 C Calculate the distance and angle dependent SS-bond potential energy
5561 C using a free-energy function derived based on RHF/6-31G** ab initio
5562 C calculations of diethyl disulfide.
5563 C
5564 C A. Liwo and U. Kozlowska, 11/24/03
5565 C
5566       implicit real*8 (a-h,o-z)
5567       include 'DIMENSIONS'
5568       include 'DIMENSIONS.ZSCOPT'
5569       include 'COMMON.SBRIDGE'
5570       include 'COMMON.CHAIN'
5571       include 'COMMON.DERIV'
5572       include 'COMMON.LOCAL'
5573       include 'COMMON.INTERACT'
5574       include 'COMMON.VAR'
5575       include 'COMMON.IOUNITS'
5576       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5577       itypi=iabs(itype(i))
5578       xi=c(1,nres+i)
5579       yi=c(2,nres+i)
5580       zi=c(3,nres+i)
5581       dxi=dc_norm(1,nres+i)
5582       dyi=dc_norm(2,nres+i)
5583       dzi=dc_norm(3,nres+i)
5584       dsci_inv=dsc_inv(itypi)
5585       itypj=iabs(itype(j))
5586       dscj_inv=dsc_inv(itypj)
5587       xj=c(1,nres+j)-xi
5588       yj=c(2,nres+j)-yi
5589       zj=c(3,nres+j)-zi
5590       dxj=dc_norm(1,nres+j)
5591       dyj=dc_norm(2,nres+j)
5592       dzj=dc_norm(3,nres+j)
5593       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5594       rij=dsqrt(rrij)
5595       erij(1)=xj*rij
5596       erij(2)=yj*rij
5597       erij(3)=zj*rij
5598       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5599       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5600       om12=dxi*dxj+dyi*dyj+dzi*dzj
5601       do k=1,3
5602         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5603         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5604       enddo
5605       rij=1.0d0/rij
5606       deltad=rij-d0cm
5607       deltat1=1.0d0-om1
5608       deltat2=1.0d0+om2
5609       deltat12=om2-om1+2.0d0
5610       cosphi=om12-om1*om2
5611       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5612      &  +akct*deltad*deltat12
5613      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5614 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5615 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5616 c     &  " deltat12",deltat12," eij",eij
5617       ed=2*akcm*deltad+akct*deltat12
5618       pom1=akct*deltad
5619       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5620       eom1=-2*akth*deltat1-pom1-om2*pom2
5621       eom2= 2*akth*deltat2+pom1-om1*pom2
5622       eom12=pom2
5623       do k=1,3
5624         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5625       enddo
5626       do k=1,3
5627         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5628      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5629         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5630      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5631       enddo
5632 C
5633 C Calculate the components of the gradient in DC and X
5634 C
5635       do k=i,j-1
5636         do l=1,3
5637           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5638         enddo
5639       enddo
5640       return
5641       end
5642 C--------------------------------------------------------------------------
5643       subroutine ebond(estr)
5644 c
5645 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5646 c
5647       implicit real*8 (a-h,o-z)
5648       include 'DIMENSIONS'
5649       include 'DIMENSIONS.ZSCOPT'
5650       include 'COMMON.LOCAL'
5651       include 'COMMON.GEO'
5652       include 'COMMON.INTERACT'
5653       include 'COMMON.DERIV'
5654       include 'COMMON.VAR'
5655       include 'COMMON.CHAIN'
5656       include 'COMMON.IOUNITS'
5657       include 'COMMON.NAMES'
5658       include 'COMMON.FFIELD'
5659       include 'COMMON.CONTROL'
5660       double precision u(3),ud(3)
5661       estr=0.0d0
5662       estr1=0.0d0
5663 c      write (iout,*) "distchainmax",distchainmax
5664       do i=nnt+1,nct
5665         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5666 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5667 C          do j=1,3
5668 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5669 C     &      *dc(j,i-1)/vbld(i)
5670 C          enddo
5671 C          if (energy_dec) write(iout,*)
5672 C     &       "estr1",i,vbld(i),distchainmax,
5673 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5674 C        else
5675          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5676         diff = vbld(i)-vbldpDUM
5677 C         write(iout,*) i,diff
5678          else
5679           diff = vbld(i)-vbldp0
5680 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5681          endif
5682           estr=estr+diff*diff
5683           do j=1,3
5684             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5685           enddo
5686 C        endif
5687 C        write (iout,'(a7,i5,4f7.3)')
5688 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5689       enddo
5690       estr=0.5d0*AKP*estr+estr1
5691 c
5692 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5693 c
5694       do i=nnt,nct
5695         iti=iabs(itype(i))
5696         if (iti.ne.10 .and. iti.ne.ntyp1) then
5697           nbi=nbondterm(iti)
5698           if (nbi.eq.1) then
5699             diff=vbld(i+nres)-vbldsc0(1,iti)
5700 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5701 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5702             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5703             do j=1,3
5704               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5705             enddo
5706           else
5707             do j=1,nbi
5708               diff=vbld(i+nres)-vbldsc0(j,iti)
5709               ud(j)=aksc(j,iti)*diff
5710               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5711             enddo
5712             uprod=u(1)
5713             do j=2,nbi
5714               uprod=uprod*u(j)
5715             enddo
5716             usum=0.0d0
5717             usumsqder=0.0d0
5718             do j=1,nbi
5719               uprod1=1.0d0
5720               uprod2=1.0d0
5721               do k=1,nbi
5722                 if (k.ne.j) then
5723                   uprod1=uprod1*u(k)
5724                   uprod2=uprod2*u(k)*u(k)
5725                 endif
5726               enddo
5727               usum=usum+uprod1
5728               usumsqder=usumsqder+ud(j)*uprod2
5729             enddo
5730 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5731 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5732             estr=estr+uprod/usum
5733             do j=1,3
5734              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5735             enddo
5736           endif
5737         endif
5738       enddo
5739       return
5740       end
5741 #ifdef CRYST_THETA
5742 C--------------------------------------------------------------------------
5743       subroutine ebend(etheta,ethetacnstr)
5744 C
5745 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5746 C angles gamma and its derivatives in consecutive thetas and gammas.
5747 C
5748       implicit real*8 (a-h,o-z)
5749       include 'DIMENSIONS'
5750       include 'DIMENSIONS.ZSCOPT'
5751       include 'COMMON.LOCAL'
5752       include 'COMMON.GEO'
5753       include 'COMMON.INTERACT'
5754       include 'COMMON.DERIV'
5755       include 'COMMON.VAR'
5756       include 'COMMON.CHAIN'
5757       include 'COMMON.IOUNITS'
5758       include 'COMMON.NAMES'
5759       include 'COMMON.FFIELD'
5760       include 'COMMON.TORCNSTR'
5761       common /calcthet/ term1,term2,termm,diffak,ratak,
5762      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5763      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5764       double precision y(2),z(2)
5765       delta=0.02d0*pi
5766 c      time11=dexp(-2*time)
5767 c      time12=1.0d0
5768       etheta=0.0D0
5769 c      write (iout,*) "nres",nres
5770 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5771 c      write (iout,*) ithet_start,ithet_end
5772       do i=ithet_start,ithet_end
5773 C        if (itype(i-1).eq.ntyp1) cycle
5774         if (i.le.2) cycle
5775         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5776      &  .or.itype(i).eq.ntyp1) cycle
5777 C Zero the energy function and its derivative at 0 or pi.
5778         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5779         it=itype(i-1)
5780         ichir1=isign(1,itype(i-2))
5781         ichir2=isign(1,itype(i))
5782          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5783          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5784          if (itype(i-1).eq.10) then
5785           itype1=isign(10,itype(i-2))
5786           ichir11=isign(1,itype(i-2))
5787           ichir12=isign(1,itype(i-2))
5788           itype2=isign(10,itype(i))
5789           ichir21=isign(1,itype(i))
5790           ichir22=isign(1,itype(i))
5791          endif
5792          if (i.eq.3) then
5793           y(1)=0.0D0
5794           y(2)=0.0D0
5795           else
5796
5797         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5798 #ifdef OSF
5799           phii=phi(i)
5800 c          icrc=0
5801 c          call proc_proc(phii,icrc)
5802           if (icrc.eq.1) phii=150.0
5803 #else
5804           phii=phi(i)
5805 #endif
5806           y(1)=dcos(phii)
5807           y(2)=dsin(phii)
5808         else
5809           y(1)=0.0D0
5810           y(2)=0.0D0
5811         endif
5812         endif
5813         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5814 #ifdef OSF
5815           phii1=phi(i+1)
5816 c          icrc=0
5817 c          call proc_proc(phii1,icrc)
5818           if (icrc.eq.1) phii1=150.0
5819           phii1=pinorm(phii1)
5820           z(1)=cos(phii1)
5821 #else
5822           phii1=phi(i+1)
5823           z(1)=dcos(phii1)
5824 #endif
5825           z(2)=dsin(phii1)
5826         else
5827           z(1)=0.0D0
5828           z(2)=0.0D0
5829         endif
5830 C Calculate the "mean" value of theta from the part of the distribution
5831 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5832 C In following comments this theta will be referred to as t_c.
5833         thet_pred_mean=0.0d0
5834         do k=1,2
5835             athetk=athet(k,it,ichir1,ichir2)
5836             bthetk=bthet(k,it,ichir1,ichir2)
5837           if (it.eq.10) then
5838              athetk=athet(k,itype1,ichir11,ichir12)
5839              bthetk=bthet(k,itype2,ichir21,ichir22)
5840           endif
5841           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5842         enddo
5843 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5844         dthett=thet_pred_mean*ssd
5845         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5846 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5847 C Derivatives of the "mean" values in gamma1 and gamma2.
5848         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5849      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5850          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5851      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5852          if (it.eq.10) then
5853       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5854      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5855         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5856      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5857          endif
5858         if (theta(i).gt.pi-delta) then
5859           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5860      &         E_tc0)
5861           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5862           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5863           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5864      &        E_theta)
5865           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5866      &        E_tc)
5867         else if (theta(i).lt.delta) then
5868           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5869           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5870           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5871      &        E_theta)
5872           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5873           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5874      &        E_tc)
5875         else
5876           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5877      &        E_theta,E_tc)
5878         endif
5879         etheta=etheta+ethetai
5880 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5881 c     &      'ebend',i,ethetai,theta(i),itype(i)
5882 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5883 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5884         if (i.gt.3) then
5885           gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5886           gloc_compon(11,i-3)=gloc_compon(11,i-3)+E_tc*dthetg1
5887         endif
5888         if (i.lt.nres) then
5889           gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5890           gloc_compon(11,i-2)=gloc_compon(11,i-2)+E_tc*dthetg2
5891         endif
5892         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5893         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)
5894      &     +E_theta+E_tc*dthett
5895 c 1215   continue
5896       enddo
5897       ethetacnstr=0.0d0
5898 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5899       do i=1,ntheta_constr
5900         itheta=itheta_constr(i)
5901         thetiii=theta(itheta)
5902         difi=pinorm(thetiii-theta_constr0(i))
5903         if (difi.gt.theta_drange(i)) then
5904           difi=difi-theta_drange(i)
5905           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5906           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5907      &    +for_thet_constr(i)*difi**3
5908           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
5909      &    +for_thet_constr(i)*difi**3
5910         else if (difi.lt.-drange(i)) then
5911           difi=difi+drange(i)
5912           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5913           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5914      &    +for_thet_constr(i)*difi**3
5915           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
5916      &    +for_thet_constr(i)*difi**3
5917         else
5918           difi=0.0
5919         endif
5920 C       if (energy_dec) then
5921 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5922 C     &    i,itheta,rad2deg*thetiii,
5923 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5924 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5925 C     &    gloc(itheta+nphi-2,icg)
5926 C        endif
5927       enddo
5928 C Ufff.... We've done all this!!!
5929       return
5930       end
5931 C---------------------------------------------------------------------------
5932       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5933      &     E_tc)
5934       implicit real*8 (a-h,o-z)
5935       include 'DIMENSIONS'
5936       include 'COMMON.LOCAL'
5937       include 'COMMON.IOUNITS'
5938       common /calcthet/ term1,term2,termm,diffak,ratak,
5939      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5940      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5941 C Calculate the contributions to both Gaussian lobes.
5942 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5943 C The "polynomial part" of the "standard deviation" of this part of
5944 C the distribution.
5945         sig=polthet(3,it)
5946         do j=2,0,-1
5947           sig=sig*thet_pred_mean+polthet(j,it)
5948         enddo
5949 C Derivative of the "interior part" of the "standard deviation of the"
5950 C gamma-dependent Gaussian lobe in t_c.
5951         sigtc=3*polthet(3,it)
5952         do j=2,1,-1
5953           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5954         enddo
5955         sigtc=sig*sigtc
5956 C Set the parameters of both Gaussian lobes of the distribution.
5957 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5958         fac=sig*sig+sigc0(it)
5959         sigcsq=fac+fac
5960         sigc=1.0D0/sigcsq
5961 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5962         sigsqtc=-4.0D0*sigcsq*sigtc
5963 c       print *,i,sig,sigtc,sigsqtc
5964 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5965         sigtc=-sigtc/(fac*fac)
5966 C Following variable is sigma(t_c)**(-2)
5967         sigcsq=sigcsq*sigcsq
5968         sig0i=sig0(it)
5969         sig0inv=1.0D0/sig0i**2
5970         delthec=thetai-thet_pred_mean
5971         delthe0=thetai-theta0i
5972         term1=-0.5D0*sigcsq*delthec*delthec
5973         term2=-0.5D0*sig0inv*delthe0*delthe0
5974 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5975 C NaNs in taking the logarithm. We extract the largest exponent which is added
5976 C to the energy (this being the log of the distribution) at the end of energy
5977 C term evaluation for this virtual-bond angle.
5978         if (term1.gt.term2) then
5979           termm=term1
5980           term2=dexp(term2-termm)
5981           term1=1.0d0
5982         else
5983           termm=term2
5984           term1=dexp(term1-termm)
5985           term2=1.0d0
5986         endif
5987 C The ratio between the gamma-independent and gamma-dependent lobes of
5988 C the distribution is a Gaussian function of thet_pred_mean too.
5989         diffak=gthet(2,it)-thet_pred_mean
5990         ratak=diffak/gthet(3,it)**2
5991         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5992 C Let's differentiate it in thet_pred_mean NOW.
5993         aktc=ak*ratak
5994 C Now put together the distribution terms to make complete distribution.
5995         termexp=term1+ak*term2
5996         termpre=sigc+ak*sig0i
5997 C Contribution of the bending energy from this theta is just the -log of
5998 C the sum of the contributions from the two lobes and the pre-exponential
5999 C factor. Simple enough, isn't it?
6000         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6001 C NOW the derivatives!!!
6002 C 6/6/97 Take into account the deformation.
6003         E_theta=(delthec*sigcsq*term1
6004      &       +ak*delthe0*sig0inv*term2)/termexp
6005         E_tc=((sigtc+aktc*sig0i)/termpre
6006      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6007      &       aktc*term2)/termexp)
6008       return
6009       end
6010 c-----------------------------------------------------------------------------
6011       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6012       implicit real*8 (a-h,o-z)
6013       include 'DIMENSIONS'
6014       include 'COMMON.LOCAL'
6015       include 'COMMON.IOUNITS'
6016       common /calcthet/ term1,term2,termm,diffak,ratak,
6017      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6018      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6019       delthec=thetai-thet_pred_mean
6020       delthe0=thetai-theta0i
6021 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6022       t3 = thetai-thet_pred_mean
6023       t6 = t3**2
6024       t9 = term1
6025       t12 = t3*sigcsq
6026       t14 = t12+t6*sigsqtc
6027       t16 = 1.0d0
6028       t21 = thetai-theta0i
6029       t23 = t21**2
6030       t26 = term2
6031       t27 = t21*t26
6032       t32 = termexp
6033       t40 = t32**2
6034       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6035      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6036      & *(-t12*t9-ak*sig0inv*t27)
6037       return
6038       end
6039 #else
6040 C--------------------------------------------------------------------------
6041       subroutine ebend(etheta)
6042 C
6043 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6044 C angles gamma and its derivatives in consecutive thetas and gammas.
6045 C ab initio-derived potentials from
6046 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6047 C
6048       implicit real*8 (a-h,o-z)
6049       include 'DIMENSIONS'
6050       include 'DIMENSIONS.ZSCOPT'
6051       include 'COMMON.LOCAL'
6052       include 'COMMON.GEO'
6053       include 'COMMON.INTERACT'
6054       include 'COMMON.DERIV'
6055       include 'COMMON.VAR'
6056       include 'COMMON.CHAIN'
6057       include 'COMMON.IOUNITS'
6058       include 'COMMON.NAMES'
6059       include 'COMMON.FFIELD'
6060       include 'COMMON.CONTROL'
6061       include 'COMMON.TORCNSTR'
6062       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6063      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6064      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6065      & sinph1ph2(maxdouble,maxdouble)
6066       logical lprn /.false./, lprn1 /.false./
6067       etheta=0.0D0
6068 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6069       do i=ithet_start,ithet_end
6070 C         if (i.eq.2) cycle
6071 C        if (itype(i-1).eq.ntyp1) cycle
6072         if (i.le.2) cycle
6073         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6074      &  .or.itype(i).eq.ntyp1) cycle
6075         if (iabs(itype(i+1)).eq.20) iblock=2
6076         if (iabs(itype(i+1)).ne.20) iblock=1
6077         dethetai=0.0d0
6078         dephii=0.0d0
6079         dephii1=0.0d0
6080         theti2=0.5d0*theta(i)
6081         ityp2=ithetyp((itype(i-1)))
6082         do k=1,nntheterm
6083           coskt(k)=dcos(k*theti2)
6084           sinkt(k)=dsin(k*theti2)
6085         enddo
6086         if (i.eq.3) then
6087           phii=0.0d0
6088           ityp1=nthetyp+1
6089           do k=1,nsingle
6090             cosph1(k)=0.0d0
6091             sinph1(k)=0.0d0
6092           enddo
6093         else
6094         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6095 #ifdef OSF
6096           phii=phi(i)
6097           if (phii.ne.phii) phii=150.0
6098 #else
6099           phii=phi(i)
6100 #endif
6101           ityp1=ithetyp((itype(i-2)))
6102           do k=1,nsingle
6103             cosph1(k)=dcos(k*phii)
6104             sinph1(k)=dsin(k*phii)
6105           enddo
6106         else
6107           phii=0.0d0
6108 c          ityp1=nthetyp+1
6109           do k=1,nsingle
6110             ityp1=ithetyp((itype(i-2)))
6111             cosph1(k)=0.0d0
6112             sinph1(k)=0.0d0
6113           enddo
6114         endif
6115         endif
6116         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6117 #ifdef OSF
6118           phii1=phi(i+1)
6119           if (phii1.ne.phii1) phii1=150.0
6120           phii1=pinorm(phii1)
6121 #else
6122           phii1=phi(i+1)
6123 #endif
6124           ityp3=ithetyp((itype(i)))
6125           do k=1,nsingle
6126             cosph2(k)=dcos(k*phii1)
6127             sinph2(k)=dsin(k*phii1)
6128           enddo
6129         else
6130           phii1=0.0d0
6131 c          ityp3=nthetyp+1
6132           ityp3=ithetyp((itype(i)))
6133           do k=1,nsingle
6134             cosph2(k)=0.0d0
6135             sinph2(k)=0.0d0
6136           enddo
6137         endif
6138 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6139 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6140 c        call flush(iout)
6141         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6142         do k=1,ndouble
6143           do l=1,k-1
6144             ccl=cosph1(l)*cosph2(k-l)
6145             ssl=sinph1(l)*sinph2(k-l)
6146             scl=sinph1(l)*cosph2(k-l)
6147             csl=cosph1(l)*sinph2(k-l)
6148             cosph1ph2(l,k)=ccl-ssl
6149             cosph1ph2(k,l)=ccl+ssl
6150             sinph1ph2(l,k)=scl+csl
6151             sinph1ph2(k,l)=scl-csl
6152           enddo
6153         enddo
6154         if (lprn) then
6155         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6156      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6157         write (iout,*) "coskt and sinkt"
6158         do k=1,nntheterm
6159           write (iout,*) k,coskt(k),sinkt(k)
6160         enddo
6161         endif
6162         do k=1,ntheterm
6163           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6164           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6165      &      *coskt(k)
6166           if (lprn)
6167      &    write (iout,*) "k",k,"
6168      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6169      &     " ethetai",ethetai
6170         enddo
6171         if (lprn) then
6172         write (iout,*) "cosph and sinph"
6173         do k=1,nsingle
6174           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6175         enddo
6176         write (iout,*) "cosph1ph2 and sinph2ph2"
6177         do k=2,ndouble
6178           do l=1,k-1
6179             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6180      &         sinph1ph2(l,k),sinph1ph2(k,l)
6181           enddo
6182         enddo
6183         write(iout,*) "ethetai",ethetai
6184         endif
6185         do m=1,ntheterm2
6186           do k=1,nsingle
6187             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6188      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6189      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6190      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6191             ethetai=ethetai+sinkt(m)*aux
6192             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6193             dephii=dephii+k*sinkt(m)*(
6194      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6195      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6196             dephii1=dephii1+k*sinkt(m)*(
6197      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6198      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6199             if (lprn)
6200      &      write (iout,*) "m",m," k",k," bbthet",
6201      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6202      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6203      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6204      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6205           enddo
6206         enddo
6207         if (lprn)
6208      &  write(iout,*) "ethetai",ethetai
6209         do m=1,ntheterm3
6210           do k=2,ndouble
6211             do l=1,k-1
6212               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6213      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6214      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6215      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6216               ethetai=ethetai+sinkt(m)*aux
6217               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6218               dephii=dephii+l*sinkt(m)*(
6219      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6220      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6221      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6222      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6223               dephii1=dephii1+(k-l)*sinkt(m)*(
6224      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6225      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6226      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6227      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6228               if (lprn) then
6229               write (iout,*) "m",m," k",k," l",l," ffthet",
6230      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6231      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6232      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6233      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6234      &            " ethetai",ethetai
6235               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6236      &            cosph1ph2(k,l)*sinkt(m),
6237      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6238               endif
6239             enddo
6240           enddo
6241         enddo
6242 10      continue
6243         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6244      &   i,theta(i)*rad2deg,phii*rad2deg,
6245      &   phii1*rad2deg,ethetai
6246         etheta=etheta+ethetai
6247         if (i.gt.3) then
6248           gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6249           gloc_compon(11,i-3)=gloc_compon(11,i-3)+dephii
6250         endif
6251         if (i.lt.nres) then
6252           gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6253           gloc_compon(11,i-2)=gloc_compon(11,i-2)+dephii1
6254         endif
6255 c        gloc(nphi+i-2,icg)=wang*dethetai
6256         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6257         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)+dethetai
6258       enddo
6259       return
6260       end
6261 #endif
6262 #ifdef CRYST_SC
6263 c-----------------------------------------------------------------------------
6264       subroutine esc(escloc)
6265 C Calculate the local energy of a side chain and its derivatives in the
6266 C corresponding virtual-bond valence angles THETA and the spherical angles
6267 C ALPHA and OMEGA.
6268       implicit real*8 (a-h,o-z)
6269       include 'DIMENSIONS'
6270       include 'DIMENSIONS.ZSCOPT'
6271       include 'COMMON.GEO'
6272       include 'COMMON.LOCAL'
6273       include 'COMMON.VAR'
6274       include 'COMMON.INTERACT'
6275       include 'COMMON.DERIV'
6276       include 'COMMON.CHAIN'
6277       include 'COMMON.IOUNITS'
6278       include 'COMMON.NAMES'
6279       include 'COMMON.FFIELD'
6280       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6281      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6282       common /sccalc/ time11,time12,time112,theti,it,nlobit
6283       delta=0.02d0*pi
6284       escloc=0.0D0
6285 C      write (iout,*) 'ESC'
6286       do i=loc_start,loc_end
6287         it=itype(i)
6288         if (it.eq.ntyp1) cycle
6289         if (it.eq.10) goto 1
6290         nlobit=nlob(iabs(it))
6291 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6292 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6293         theti=theta(i+1)-pipol
6294         x(1)=dtan(theti)
6295         x(2)=alph(i)
6296         x(3)=omeg(i)
6297 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6298
6299         if (x(2).gt.pi-delta) then
6300           xtemp(1)=x(1)
6301           xtemp(2)=pi-delta
6302           xtemp(3)=x(3)
6303           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6304           xtemp(2)=pi
6305           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6306           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6307      &        escloci,dersc(2))
6308           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6309      &        ddersc0(1),dersc(1))
6310           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6311      &        ddersc0(3),dersc(3))
6312           xtemp(2)=pi-delta
6313           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6314           xtemp(2)=pi
6315           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6316           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6317      &            dersc0(2),esclocbi,dersc02)
6318           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6319      &            dersc12,dersc01)
6320           call splinthet(x(2),0.5d0*delta,ss,ssd)
6321           dersc0(1)=dersc01
6322           dersc0(2)=dersc02
6323           dersc0(3)=0.0d0
6324           do k=1,3
6325             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6326           enddo
6327           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6328           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6329      &             esclocbi,ss,ssd
6330           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6331 c         escloci=esclocbi
6332 c         write (iout,*) escloci
6333         else if (x(2).lt.delta) then
6334           xtemp(1)=x(1)
6335           xtemp(2)=delta
6336           xtemp(3)=x(3)
6337           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6338           xtemp(2)=0.0d0
6339           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6340           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6341      &        escloci,dersc(2))
6342           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6343      &        ddersc0(1),dersc(1))
6344           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6345      &        ddersc0(3),dersc(3))
6346           xtemp(2)=delta
6347           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6348           xtemp(2)=0.0d0
6349           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6350           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6351      &            dersc0(2),esclocbi,dersc02)
6352           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6353      &            dersc12,dersc01)
6354           dersc0(1)=dersc01
6355           dersc0(2)=dersc02
6356           dersc0(3)=0.0d0
6357           call splinthet(x(2),0.5d0*delta,ss,ssd)
6358           do k=1,3
6359             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6360           enddo
6361           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6362 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6363 c     &             esclocbi,ss,ssd
6364           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6365 C         write (iout,*) 'i=',i, escloci
6366         else
6367           call enesc(x,escloci,dersc,ddummy,.false.)
6368         endif
6369
6370         escloc=escloc+escloci
6371 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6372             write (iout,'(a6,i5,0pf7.3)')
6373      &     'escloc',i,escloci
6374
6375         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6376      &   wscloc*dersc(1)
6377         gloc_compon(12,nphi+i-1)=gloc_compon(12,nphi+i-1)+dersc(1)
6378         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6379         gloc_compon(12,ialph(i,1))=gloc_compon(12,ialph(i,1))+dersc(2)
6380         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6381         gloc_compon(12,ialph(i,1))=gloc_compon(12,ialph(i,1))+dersc(3)
6382     1   continue
6383       enddo
6384       return
6385       end
6386 C---------------------------------------------------------------------------
6387       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6388       implicit real*8 (a-h,o-z)
6389       include 'DIMENSIONS'
6390       include 'COMMON.GEO'
6391       include 'COMMON.LOCAL'
6392       include 'COMMON.IOUNITS'
6393       common /sccalc/ time11,time12,time112,theti,it,nlobit
6394       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6395       double precision contr(maxlob,-1:1)
6396       logical mixed
6397 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6398         escloc_i=0.0D0
6399         do j=1,3
6400           dersc(j)=0.0D0
6401           if (mixed) ddersc(j)=0.0d0
6402         enddo
6403         x3=x(3)
6404
6405 C Because of periodicity of the dependence of the SC energy in omega we have
6406 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6407 C To avoid underflows, first compute & store the exponents.
6408
6409         do iii=-1,1
6410
6411           x(3)=x3+iii*dwapi
6412
6413           do j=1,nlobit
6414             do k=1,3
6415               z(k)=x(k)-censc(k,j,it)
6416             enddo
6417             do k=1,3
6418               Axk=0.0D0
6419               do l=1,3
6420                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6421               enddo
6422               Ax(k,j,iii)=Axk
6423             enddo
6424             expfac=0.0D0
6425             do k=1,3
6426               expfac=expfac+Ax(k,j,iii)*z(k)
6427             enddo
6428             contr(j,iii)=expfac
6429           enddo ! j
6430
6431         enddo ! iii
6432
6433         x(3)=x3
6434 C As in the case of ebend, we want to avoid underflows in exponentiation and
6435 C subsequent NaNs and INFs in energy calculation.
6436 C Find the largest exponent
6437         emin=contr(1,-1)
6438         do iii=-1,1
6439           do j=1,nlobit
6440             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6441           enddo
6442         enddo
6443         emin=0.5D0*emin
6444 cd      print *,'it=',it,' emin=',emin
6445
6446 C Compute the contribution to SC energy and derivatives
6447         do iii=-1,1
6448
6449           do j=1,nlobit
6450             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6451 cd          print *,'j=',j,' expfac=',expfac
6452             escloc_i=escloc_i+expfac
6453             do k=1,3
6454               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6455             enddo
6456             if (mixed) then
6457               do k=1,3,2
6458                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6459      &            +gaussc(k,2,j,it))*expfac
6460               enddo
6461             endif
6462           enddo
6463
6464         enddo ! iii
6465
6466         dersc(1)=dersc(1)/cos(theti)**2
6467         ddersc(1)=ddersc(1)/cos(theti)**2
6468         ddersc(3)=ddersc(3)
6469
6470         escloci=-(dlog(escloc_i)-emin)
6471         do j=1,3
6472           dersc(j)=dersc(j)/escloc_i
6473         enddo
6474         if (mixed) then
6475           do j=1,3,2
6476             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6477           enddo
6478         endif
6479       return
6480       end
6481 C------------------------------------------------------------------------------
6482       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6483       implicit real*8 (a-h,o-z)
6484       include 'DIMENSIONS'
6485       include 'COMMON.GEO'
6486       include 'COMMON.LOCAL'
6487       include 'COMMON.IOUNITS'
6488       common /sccalc/ time11,time12,time112,theti,it,nlobit
6489       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6490       double precision contr(maxlob)
6491       logical mixed
6492
6493       escloc_i=0.0D0
6494
6495       do j=1,3
6496         dersc(j)=0.0D0
6497       enddo
6498
6499       do j=1,nlobit
6500         do k=1,2
6501           z(k)=x(k)-censc(k,j,it)
6502         enddo
6503         z(3)=dwapi
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)=Axk
6510         enddo
6511         expfac=0.0D0
6512         do k=1,3
6513           expfac=expfac+Ax(k,j)*z(k)
6514         enddo
6515         contr(j)=expfac
6516       enddo ! j
6517
6518 C As in the case of ebend, we want to avoid underflows in exponentiation and
6519 C subsequent NaNs and INFs in energy calculation.
6520 C Find the largest exponent
6521       emin=contr(1)
6522       do j=1,nlobit
6523         if (emin.gt.contr(j)) emin=contr(j)
6524       enddo
6525       emin=0.5D0*emin
6526
6527 C Compute the contribution to SC energy and derivatives
6528
6529       dersc12=0.0d0
6530       do j=1,nlobit
6531         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6532         escloc_i=escloc_i+expfac
6533         do k=1,2
6534           dersc(k)=dersc(k)+Ax(k,j)*expfac
6535         enddo
6536         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6537      &            +gaussc(1,2,j,it))*expfac
6538         dersc(3)=0.0d0
6539       enddo
6540
6541       dersc(1)=dersc(1)/cos(theti)**2
6542       dersc12=dersc12/cos(theti)**2
6543       escloci=-(dlog(escloc_i)-emin)
6544       do j=1,2
6545         dersc(j)=dersc(j)/escloc_i
6546       enddo
6547       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6548       return
6549       end
6550 #else
6551 c----------------------------------------------------------------------------------
6552       subroutine esc(escloc)
6553 C Calculate the local energy of a side chain and its derivatives in the
6554 C corresponding virtual-bond valence angles THETA and the spherical angles
6555 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6556 C added by Urszula Kozlowska. 07/11/2007
6557 C
6558       implicit real*8 (a-h,o-z)
6559       include 'DIMENSIONS'
6560       include 'DIMENSIONS.ZSCOPT'
6561       include 'COMMON.GEO'
6562       include 'COMMON.LOCAL'
6563       include 'COMMON.VAR'
6564       include 'COMMON.SCROT'
6565       include 'COMMON.INTERACT'
6566       include 'COMMON.DERIV'
6567       include 'COMMON.CHAIN'
6568       include 'COMMON.IOUNITS'
6569       include 'COMMON.NAMES'
6570       include 'COMMON.FFIELD'
6571       include 'COMMON.CONTROL'
6572       include 'COMMON.VECTORS'
6573       double precision x_prime(3),y_prime(3),z_prime(3)
6574      &    , sumene,dsc_i,dp2_i,x(65),
6575      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6576      &    de_dxx,de_dyy,de_dzz,de_dt
6577       double precision s1_t,s1_6_t,s2_t,s2_6_t
6578       double precision
6579      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6580      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6581      & dt_dCi(3),dt_dCi1(3)
6582       common /sccalc/ time11,time12,time112,theti,it,nlobit
6583       delta=0.02d0*pi
6584       escloc=0.0D0
6585       do i=loc_start,loc_end
6586         if (itype(i).eq.ntyp1) cycle
6587         costtab(i+1) =dcos(theta(i+1))
6588         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6589         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6590         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6591         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6592         cosfac=dsqrt(cosfac2)
6593         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6594         sinfac=dsqrt(sinfac2)
6595         it=iabs(itype(i))
6596         if (it.eq.10) goto 1
6597 c
6598 C  Compute the axes of tghe local cartesian coordinates system; store in
6599 c   x_prime, y_prime and z_prime
6600 c
6601         do j=1,3
6602           x_prime(j) = 0.00
6603           y_prime(j) = 0.00
6604           z_prime(j) = 0.00
6605         enddo
6606 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6607 C     &   dc_norm(3,i+nres)
6608         do j = 1,3
6609           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6610           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6611         enddo
6612         do j = 1,3
6613           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6614         enddo
6615 c       write (2,*) "i",i
6616 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6617 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6618 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6619 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6620 c      & " xy",scalar(x_prime(1),y_prime(1)),
6621 c      & " xz",scalar(x_prime(1),z_prime(1)),
6622 c      & " yy",scalar(y_prime(1),y_prime(1)),
6623 c      & " yz",scalar(y_prime(1),z_prime(1)),
6624 c      & " zz",scalar(z_prime(1),z_prime(1))
6625 c
6626 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6627 C to local coordinate system. Store in xx, yy, zz.
6628 c
6629         xx=0.0d0
6630         yy=0.0d0
6631         zz=0.0d0
6632         do j = 1,3
6633           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6634           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6635           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6636         enddo
6637
6638         xxtab(i)=xx
6639         yytab(i)=yy
6640         zztab(i)=zz
6641 C
6642 C Compute the energy of the ith side cbain
6643 C
6644 c        write (2,*) "xx",xx," yy",yy," zz",zz
6645         it=iabs(itype(i))
6646         do j = 1,65
6647           x(j) = sc_parmin(j,it)
6648         enddo
6649 #ifdef CHECK_COORD
6650 Cc diagnostics - remove later
6651         xx1 = dcos(alph(2))
6652         yy1 = dsin(alph(2))*dcos(omeg(2))
6653         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6654         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6655      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6656      &    xx1,yy1,zz1
6657 C,"  --- ", xx_w,yy_w,zz_w
6658 c end diagnostics
6659 #endif
6660         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6661      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6662      &   + x(10)*yy*zz
6663         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6664      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6665      & + x(20)*yy*zz
6666         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6667      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6668      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6669      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6670      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6671      &  +x(40)*xx*yy*zz
6672         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6673      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6674      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6675      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6676      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6677      &  +x(60)*xx*yy*zz
6678         dsc_i   = 0.743d0+x(61)
6679         dp2_i   = 1.9d0+x(62)
6680         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6681      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6682         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6683      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6684         s1=(1+x(63))/(0.1d0 + dscp1)
6685         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6686         s2=(1+x(65))/(0.1d0 + dscp2)
6687         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6688         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6689      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6690 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6691 c     &   sumene4,
6692 c     &   dscp1,dscp2,sumene
6693 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6694         escloc = escloc + sumene
6695 c        write (2,*) "escloc",escloc
6696 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6697 c     &  zz,xx,yy
6698         if (.not. calc_grad) goto 1
6699 #ifdef DEBUG
6700 C
6701 C This section to check the numerical derivatives of the energy of ith side
6702 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6703 C #define DEBUG in the code to turn it on.
6704 C
6705         write (2,*) "sumene               =",sumene
6706         aincr=1.0d-7
6707         xxsave=xx
6708         xx=xx+aincr
6709         write (2,*) xx,yy,zz
6710         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6711         de_dxx_num=(sumenep-sumene)/aincr
6712         xx=xxsave
6713         write (2,*) "xx+ sumene from enesc=",sumenep
6714         yysave=yy
6715         yy=yy+aincr
6716         write (2,*) xx,yy,zz
6717         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6718         de_dyy_num=(sumenep-sumene)/aincr
6719         yy=yysave
6720         write (2,*) "yy+ sumene from enesc=",sumenep
6721         zzsave=zz
6722         zz=zz+aincr
6723         write (2,*) xx,yy,zz
6724         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6725         de_dzz_num=(sumenep-sumene)/aincr
6726         zz=zzsave
6727         write (2,*) "zz+ sumene from enesc=",sumenep
6728         costsave=cost2tab(i+1)
6729         sintsave=sint2tab(i+1)
6730         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6731         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6732         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6733         de_dt_num=(sumenep-sumene)/aincr
6734         write (2,*) " t+ sumene from enesc=",sumenep
6735         cost2tab(i+1)=costsave
6736         sint2tab(i+1)=sintsave
6737 C End of diagnostics section.
6738 #endif
6739 C
6740 C Compute the gradient of esc
6741 C
6742         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6743         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6744         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6745         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6746         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6747         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6748         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6749         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6750         pom1=(sumene3*sint2tab(i+1)+sumene1)
6751      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6752         pom2=(sumene4*cost2tab(i+1)+sumene2)
6753      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6754         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6755         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6756      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6757      &  +x(40)*yy*zz
6758         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6759         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6760      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6761      &  +x(60)*yy*zz
6762         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6763      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6764      &        +(pom1+pom2)*pom_dx
6765 #ifdef DEBUG
6766         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6767 #endif
6768 C
6769         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6770         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6771      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6772      &  +x(40)*xx*zz
6773         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6774         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6775      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6776      &  +x(59)*zz**2 +x(60)*xx*zz
6777         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6778      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6779      &        +(pom1-pom2)*pom_dy
6780 #ifdef DEBUG
6781         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6782 #endif
6783 C
6784         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6785      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6786      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6787      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6788      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6789      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6790      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6791      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6792 #ifdef DEBUG
6793         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6794 #endif
6795 C
6796         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6797      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6798      &  +pom1*pom_dt1+pom2*pom_dt2
6799 #ifdef DEBUG
6800         write(2,*), "de_dt = ", de_dt,de_dt_num
6801 #endif
6802 c
6803 C
6804        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6805        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6806        cosfac2xx=cosfac2*xx
6807        sinfac2yy=sinfac2*yy
6808        do k = 1,3
6809          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6810      &      vbld_inv(i+1)
6811          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6812      &      vbld_inv(i)
6813          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6814          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6815 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6816 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6817 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6818 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6819          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6820          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6821          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6822          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6823          dZZ_Ci1(k)=0.0d0
6824          dZZ_Ci(k)=0.0d0
6825          do j=1,3
6826            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6827      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6828            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6829      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6830          enddo
6831
6832          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6833          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6834          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6835 c
6836          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6837          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6838        enddo
6839
6840        do k=1,3
6841          dXX_Ctab(k,i)=dXX_Ci(k)
6842          dXX_C1tab(k,i)=dXX_Ci1(k)
6843          dYY_Ctab(k,i)=dYY_Ci(k)
6844          dYY_C1tab(k,i)=dYY_Ci1(k)
6845          dZZ_Ctab(k,i)=dZZ_Ci(k)
6846          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6847          dXX_XYZtab(k,i)=dXX_XYZ(k)
6848          dYY_XYZtab(k,i)=dYY_XYZ(k)
6849          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6850        enddo
6851
6852        do k = 1,3
6853 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6854 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6855 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6856 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6857 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6858 c     &    dt_dci(k)
6859 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6860 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6861          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6862      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6863          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6864      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6865          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6866      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6867        enddo
6868 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6869 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6870
6871 C to check gradient call subroutine check_grad
6872
6873     1 continue
6874       enddo
6875       return
6876       end
6877 #endif
6878 c------------------------------------------------------------------------------
6879       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6880 C
6881 C This procedure calculates two-body contact function g(rij) and its derivative:
6882 C
6883 C           eps0ij                                     !       x < -1
6884 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6885 C            0                                         !       x > 1
6886 C
6887 C where x=(rij-r0ij)/delta
6888 C
6889 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6890 C
6891       implicit none
6892       double precision rij,r0ij,eps0ij,fcont,fprimcont
6893       double precision x,x2,x4,delta
6894 c     delta=0.02D0*r0ij
6895 c      delta=0.2D0*r0ij
6896       x=(rij-r0ij)/delta
6897       if (x.lt.-1.0D0) then
6898         fcont=eps0ij
6899         fprimcont=0.0D0
6900       else if (x.le.1.0D0) then
6901         x2=x*x
6902         x4=x2*x2
6903         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6904         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6905       else
6906         fcont=0.0D0
6907         fprimcont=0.0D0
6908       endif
6909       return
6910       end
6911 c------------------------------------------------------------------------------
6912       subroutine splinthet(theti,delta,ss,ssder)
6913       implicit real*8 (a-h,o-z)
6914       include 'DIMENSIONS'
6915       include 'DIMENSIONS.ZSCOPT'
6916       include 'COMMON.VAR'
6917       include 'COMMON.GEO'
6918       thetup=pi-delta
6919       thetlow=delta
6920       if (theti.gt.pipol) then
6921         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6922       else
6923         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6924         ssder=-ssder
6925       endif
6926       return
6927       end
6928 c------------------------------------------------------------------------------
6929       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6930       implicit none
6931       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6932       double precision ksi,ksi2,ksi3,a1,a2,a3
6933       a1=fprim0*delta/(f1-f0)
6934       a2=3.0d0-2.0d0*a1
6935       a3=a1-2.0d0
6936       ksi=(x-x0)/delta
6937       ksi2=ksi*ksi
6938       ksi3=ksi2*ksi
6939       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6940       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6941       return
6942       end
6943 c------------------------------------------------------------------------------
6944       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6945       implicit none
6946       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6947       double precision ksi,ksi2,ksi3,a1,a2,a3
6948       ksi=(x-x0)/delta
6949       ksi2=ksi*ksi
6950       ksi3=ksi2*ksi
6951       a1=fprim0x*delta
6952       a2=3*(f1x-f0x)-2*fprim0x*delta
6953       a3=fprim0x*delta-2*(f1x-f0x)
6954       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6955       return
6956       end
6957 C-----------------------------------------------------------------------------
6958 #ifdef CRYST_TOR
6959 C-----------------------------------------------------------------------------
6960       subroutine etor(etors)
6961       implicit real*8 (a-h,o-z)
6962       include 'DIMENSIONS'
6963       include 'DIMENSIONS.ZSCOPT'
6964       include 'COMMON.VAR'
6965       include 'COMMON.GEO'
6966       include 'COMMON.LOCAL'
6967       include 'COMMON.TORSION'
6968       include 'COMMON.INTERACT'
6969       include 'COMMON.DERIV'
6970       include 'COMMON.CHAIN'
6971       include 'COMMON.NAMES'
6972       include 'COMMON.IOUNITS'
6973       include 'COMMON.FFIELD'
6974       include 'COMMON.TORCNSTR'
6975       logical lprn
6976 C Set lprn=.true. for debugging
6977       lprn=.false.
6978 c      lprn=.true.
6979       etors=0.0D0
6980       do i=iphi_start,iphi_end
6981         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6982      &      .or. itype(i).eq.ntyp1) cycle
6983         itori=itortyp(itype(i-2))
6984         itori1=itortyp(itype(i-1))
6985         phii=phi(i)
6986         gloci=0.0D0
6987 C Proline-Proline pair is a special case...
6988         if (itori.eq.3 .and. itori1.eq.3) then
6989           if (phii.gt.-dwapi3) then
6990             cosphi=dcos(3*phii)
6991             fac=1.0D0/(1.0D0-cosphi)
6992             etorsi=v1(1,3,3)*fac
6993             etorsi=etorsi+etorsi
6994             etors=etors+etorsi-v1(1,3,3)
6995             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6996           endif
6997           do j=1,3
6998             v1ij=v1(j+1,itori,itori1)
6999             v2ij=v2(j+1,itori,itori1)
7000             cosphi=dcos(j*phii)
7001             sinphi=dsin(j*phii)
7002             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7003             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7004           enddo
7005         else
7006           do j=1,nterm_old
7007             v1ij=v1(j,itori,itori1)
7008             v2ij=v2(j,itori,itori1)
7009             cosphi=dcos(j*phii)
7010             sinphi=dsin(j*phii)
7011             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7012             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7013           enddo
7014         endif
7015         if (lprn)
7016      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7017      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7018      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7019         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7020         gloc_compon(13,i-3)=gloc_compon(13,i-3)+gloci
7021 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7022       enddo
7023       return
7024       end
7025 c------------------------------------------------------------------------------
7026 #else
7027       subroutine etor(etors)
7028       implicit real*8 (a-h,o-z)
7029       include 'DIMENSIONS'
7030       include 'DIMENSIONS.ZSCOPT'
7031       include 'COMMON.VAR'
7032       include 'COMMON.GEO'
7033       include 'COMMON.LOCAL'
7034       include 'COMMON.TORSION'
7035       include 'COMMON.INTERACT'
7036       include 'COMMON.DERIV'
7037       include 'COMMON.CHAIN'
7038       include 'COMMON.NAMES'
7039       include 'COMMON.IOUNITS'
7040       include 'COMMON.FFIELD'
7041       include 'COMMON.TORCNSTR'
7042       include 'COMMON.WEIGHTS'
7043       include 'COMMON.WEIGHTDER'
7044       logical lprn
7045 C Set lprn=.true. for debugging
7046       lprn=.false.
7047 c      lprn=.true.
7048       etors=0.0D0
7049       do iblock=1,2
7050       do i=-ntyp+1,ntyp-1
7051         do j=-ntyp+1,ntyp-1
7052           do k=0,3
7053             do l=0,2*maxterm
7054               etor_temp(l,k,j,i,iblock)=0.0d0
7055             enddo
7056           enddo
7057         enddo
7058       enddo
7059       enddo
7060       do i=iphi_start,iphi_end
7061         if (i.le.2) cycle
7062         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7063      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7064         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7065         if (iabs(itype(i)).eq.20) then
7066           iblock=2
7067         else
7068           iblock=1
7069         endif
7070         itori=itortyp(itype(i-2))
7071         itori1=itortyp(itype(i-1))
7072         weitori=weitor(0,itori,itori1,iblock)
7073         phii=phi(i)
7074         gloci=0.0D0
7075         etori=0.0d0
7076 C Regular cosine and sine terms
7077         do j=1,nterm(itori,itori1,iblock)
7078           v1ij=v1(j,itori,itori1,iblock)
7079           v2ij=v2(j,itori,itori1,iblock)
7080           cosphi=dcos(j*phii)
7081           sinphi=dsin(j*phii)
7082           etori=etori+v1ij*cosphi+v2ij*sinphi
7083           etor_temp(j,0,itori,itori1,iblock)=
7084      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7085           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7086      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7087      &      sinphi*ww(13)
7088           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7089         enddo
7090 C Lorentz terms
7091 C                         v1
7092 C  E = SUM ----------------------------------- - v1
7093 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7094 C
7095         cosphi=dcos(0.5d0*phii)
7096         sinphi=dsin(0.5d0*phii)
7097         do j=1,nlor(itori,itori1,iblock)
7098           vl1ij=vlor1(j,itori,itori1)
7099           vl2ij=vlor2(j,itori,itori1)
7100           vl3ij=vlor3(j,itori,itori1)
7101           pom=vl2ij*cosphi+vl3ij*sinphi
7102           pom1=1.0d0/(pom*pom+1.0d0)
7103           etori=etori+vl1ij*pom1
7104           pom=-pom*pom1*pom1
7105           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7106         enddo
7107 C Subtract the constant term
7108         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7109         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7110      &    (etori-v0(itori,itori1,iblock))*ww(13)
7111
7112         if (lprn) then
7113         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7114      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7115      &  weitori,v0(itori,itori1,iblock)*weitori,
7116      &  (v1(j,itori,itori1,iblock)*weitori,
7117      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7118         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7119      &    iloctyp(itori1)," etor_temp",
7120      &    etor_temp(0,0,itori,itori1,1)
7121         call flush(iout)
7122         endif
7123         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7124         gloc_compon(13,i-3)=gloc_compon(13,i-3)+gloci
7125 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7126  1215   continue
7127       enddo
7128       return
7129       end
7130 c----------------------------------------------------------------------------
7131       subroutine etor_d(etors_d)
7132 C 6/23/01 Compute double torsional energy
7133       implicit real*8 (a-h,o-z)
7134       include 'DIMENSIONS'
7135       include 'DIMENSIONS.ZSCOPT'
7136       include 'COMMON.VAR'
7137       include 'COMMON.GEO'
7138       include 'COMMON.LOCAL'
7139       include 'COMMON.TORSION'
7140       include 'COMMON.INTERACT'
7141       include 'COMMON.DERIV'
7142       include 'COMMON.CHAIN'
7143       include 'COMMON.NAMES'
7144       include 'COMMON.IOUNITS'
7145       include 'COMMON.FFIELD'
7146       include 'COMMON.TORCNSTR'
7147       logical lprn
7148 C Set lprn=.true. for debugging
7149       lprn=.false.
7150 c     lprn=.true.
7151       etors_d=0.0D0
7152       do i=iphi_start,iphi_end-1
7153         if (i.le.3) cycle
7154 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7155 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7156          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7157      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7158      &  (itype(i+1).eq.ntyp1)) cycle
7159         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7160      &     goto 1215
7161         itori=itortyp(itype(i-2))
7162         itori1=itortyp(itype(i-1))
7163         itori2=itortyp(itype(i))
7164         phii=phi(i)
7165         phii1=phi(i+1)
7166         gloci1=0.0D0
7167         gloci2=0.0D0
7168         iblock=1
7169         if (iabs(itype(i+1)).eq.20) iblock=2
7170 C Regular cosine and sine terms
7171         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7172           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7173           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7174           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7175           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7176           cosphi1=dcos(j*phii)
7177           sinphi1=dsin(j*phii)
7178           cosphi2=dcos(j*phii1)
7179           sinphi2=dsin(j*phii1)
7180           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7181      &     v2cij*cosphi2+v2sij*sinphi2
7182           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7183           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7184         enddo
7185         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7186           do l=1,k-1
7187             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7188             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7189             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7190             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7191             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7192             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7193             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7194             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7195             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7196      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7197             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7198      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7199             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7200      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7201           enddo
7202         enddo
7203         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7204         gloc_compon(14,i-3)=gloc_compon(14,i-3)+gloci1
7205         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7206         gloc_compon(14,i-2)=gloc_compon(14,i-2)+gloci2
7207  1215   continue
7208       enddo
7209       return
7210       end
7211 #endif
7212 c---------------------------------------------------------------------------
7213 C The rigorous attempt to derive energy function
7214       subroutine etor_kcc(etors)
7215       implicit real*8 (a-h,o-z)
7216       include 'DIMENSIONS'
7217       include 'DIMENSIONS.ZSCOPT'
7218       include 'COMMON.VAR'
7219       include 'COMMON.GEO'
7220       include 'COMMON.LOCAL'
7221       include 'COMMON.TORSION'
7222       include 'COMMON.INTERACT'
7223       include 'COMMON.DERIV'
7224       include 'COMMON.CHAIN'
7225       include 'COMMON.NAMES'
7226       include 'COMMON.IOUNITS'
7227       include 'COMMON.FFIELD'
7228       include 'COMMON.TORCNSTR'
7229       include 'COMMON.CONTROL'
7230       include 'COMMON.WEIGHTS'
7231       include 'COMMON.WEIGHTDER'
7232       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7233       logical lprn
7234 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7235 C Set lprn=.true. for debugging
7236       lprn=energy_dec
7237 c      lprn=.true.
7238       if (lprn) write (iout,*)"ETOR_KCC"
7239       do iblock=1,2
7240       do i=-ntyp+1,ntyp-1
7241         do j=-ntyp+1,ntyp-1
7242           do k=0,3
7243             do l=0,2*maxterm
7244               etor_temp(l,k,j,i,iblock)=0.0d0
7245             enddo
7246           enddo
7247         enddo
7248       enddo
7249       enddo
7250       do i=-ntyp+1,ntyp-1
7251         do j=-ntyp+1,ntyp-1
7252           do k=0,2*maxtor_kcc
7253             do l=1,maxval_kcc
7254               do ll=1,maxval_kcc
7255                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7256               enddo
7257             enddo
7258           enddo
7259         enddo
7260       enddo
7261       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7262       etors=0.0D0
7263       do i=iphi_start,iphi_end
7264 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7265 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7266 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7267 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7268         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7269      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7270         itori=itortyp(itype(i-2))
7271         itori1=itortyp(itype(i-1))
7272         weitori=weitor(0,itori,itori1,1)
7273         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7274         phii=phi(i)
7275         glocig=0.0D0
7276         glocit1=0.0d0
7277         glocit2=0.0d0
7278 C to avoid multiple devision by 2
7279 c        theti22=0.5d0*theta(i)
7280 C theta 12 is the theta_1 /2
7281 C theta 22 is theta_2 /2
7282 c        theti12=0.5d0*theta(i-1)
7283 C and appropriate sinus function
7284         sinthet1=dsin(theta(i-1))
7285         sinthet2=dsin(theta(i))
7286         costhet1=dcos(theta(i-1))
7287         costhet2=dcos(theta(i))
7288 C to speed up lets store its mutliplication
7289         sint1t2=sinthet2*sinthet1
7290         sint1t2n=1.0d0
7291 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7292 C +d_n*sin(n*gamma)) *
7293 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7294 C we have two sum 1) Non-Chebyshev which is with n and gamma
7295         nval=nterm_kcc_Tb(itori,itori1)
7296         c1(0)=0.0d0
7297         c2(0)=0.0d0
7298         c1(1)=1.0d0
7299         c2(1)=1.0d0
7300         do j=2,nval
7301           c1(j)=c1(j-1)*costhet1
7302           c2(j)=c2(j-1)*costhet2
7303         enddo
7304         etori=0.0d0
7305         do j=1,nterm_kcc(itori,itori1)
7306           cosphi=dcos(j*phii)
7307           sinphi=dsin(j*phii)
7308           sint1t2n1=sint1t2n
7309           sint1t2n=sint1t2n*sint1t2
7310           sumvalc=0.0d0
7311           gradvalct1=0.0d0
7312           gradvalct2=0.0d0
7313           do k=1,nval
7314             do l=1,nval
7315               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7316               etor_temp_kcc(l,k,j,itori,itori1)=
7317      &           etor_temp_kcc(l,k,j,itori,itori1)+
7318      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7319               gradvalct1=gradvalct1+
7320      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7321               gradvalct2=gradvalct2+
7322      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7323             enddo
7324           enddo
7325           gradvalct1=-gradvalct1*sinthet1
7326           gradvalct2=-gradvalct2*sinthet2
7327           sumvals=0.0d0
7328           gradvalst1=0.0d0
7329           gradvalst2=0.0d0
7330           do k=1,nval
7331             do l=1,nval
7332               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7333               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7334      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7335      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7336               gradvalst1=gradvalst1+
7337      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7338               gradvalst2=gradvalst2+
7339      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7340             enddo
7341           enddo
7342           gradvalst1=-gradvalst1*sinthet1
7343           gradvalst2=-gradvalst2*sinthet2
7344           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7345           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7346      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7347 C glocig is the gradient local i site in gamma
7348           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7349 C now gradient over theta_1
7350           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7351      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7352           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7353      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7354         enddo ! j
7355         etors=etors+etori*weitori
7356 C derivative over gamma
7357         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7358         gloc_compon(13,i-3)=gloc_compon(13,i-3)+glocig
7359 C derivative over theta1
7360         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7361         gloc_compon(13,nphi+i-3)=gloc_compon(13,nphi+i-3)+glocit1
7362 C now derivative over theta2
7363         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7364         gloc_compon(13,nphi+i-2)=gloc_compon(13,nphi+i-2)+glocit2
7365         if (lprn)
7366      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7367      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7368       enddo
7369       return
7370       end
7371 c---------------------------------------------------------------------------------------------
7372       subroutine etor_constr(edihcnstr)
7373       implicit real*8 (a-h,o-z)
7374       include 'DIMENSIONS'
7375       include 'DIMENSIONS.ZSCOPT'
7376       include 'COMMON.VAR'
7377       include 'COMMON.GEO'
7378       include 'COMMON.LOCAL'
7379       include 'COMMON.TORSION'
7380       include 'COMMON.INTERACT'
7381       include 'COMMON.DERIV'
7382       include 'COMMON.CHAIN'
7383       include 'COMMON.NAMES'
7384       include 'COMMON.IOUNITS'
7385       include 'COMMON.FFIELD'
7386       include 'COMMON.TORCNSTR'
7387       include 'COMMON.CONTROL'
7388 ! 6/20/98 - dihedral angle constraints
7389       edihcnstr=0.0d0
7390 c      do i=1,ndih_constr
7391 c      write (iout,*) "idihconstr_start",idihconstr_start,
7392 c     &  " idihconstr_end",idihconstr_end
7393       do i=idihconstr_start,idihconstr_end
7394         itori=idih_constr(i)
7395         phii=phi(itori)
7396         difi=pinorm(phii-phi0(i))
7397         if (difi.gt.drange(i)) then
7398           difi=difi-drange(i)
7399           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7400           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7401           gloc_compon(13,itori-3)=gloc_compon(13,itori-3)
7402      &        +ftors(i)*difi**3
7403         else if (difi.lt.-drange(i)) then
7404           difi=difi+drange(i)
7405           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7406           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7407           gloc_compon(13,itori-3)=gloc_compon(13,itori-3)
7408      &        +ftors(i)*difi**3
7409         else
7410           difi=0.0
7411         endif
7412       enddo
7413       return
7414       end
7415 c----------------------------------------------------------------------------
7416 C The rigorous attempt to derive energy function
7417       subroutine ebend_kcc(etheta)
7418
7419       implicit real*8 (a-h,o-z)
7420       include 'DIMENSIONS'
7421       include 'DIMENSIONS.ZSCOPT'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       include 'COMMON.LOCAL'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.INTERACT'
7427       include 'COMMON.DERIV'
7428       include 'COMMON.CHAIN'
7429       include 'COMMON.NAMES'
7430       include 'COMMON.IOUNITS'
7431       include 'COMMON.FFIELD'
7432       include 'COMMON.TORCNSTR'
7433       include 'COMMON.CONTROL'
7434       include 'COMMON.WEIGHTDER'
7435       logical lprn
7436       double precision thybt1(maxang_kcc)
7437 C Set lprn=.true. for debugging
7438       lprn=energy_dec
7439 c     lprn=.true.
7440 C      print *,"wchodze kcc"
7441       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7442       do i=0,ntyp
7443         do j=1,maxang_kcc
7444           ebend_temp_kcc(j,i)=0.0d0
7445         enddo
7446       enddo
7447       etheta=0.0D0
7448       do i=ithet_start,ithet_end
7449 c        print *,i,itype(i-1),itype(i),itype(i-2)
7450         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7451      &  .or.itype(i).eq.ntyp1) cycle
7452         iti=iabs(itortyp(itype(i-1)))
7453         sinthet=dsin(theta(i))
7454         costhet=dcos(theta(i))
7455         do j=1,nbend_kcc_Tb(iti)
7456           thybt1(j)=v1bend_chyb(j,iti)
7457           ebend_temp_kcc(j,iabs(iti))=
7458      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7459         enddo
7460         sumth1thyb=v1bend_chyb(0,iti)+
7461      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7462         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7463      &    sumth1thyb
7464         ihelp=nbend_kcc_Tb(iti)-1
7465         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7466         etheta=etheta+sumth1thyb
7467 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7468         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7469         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)
7470      &    -gradthybt1*sinthet
7471       enddo
7472       return
7473       end
7474 c-------------------------------------------------------------------------------------
7475       subroutine etheta_constr(ethetacnstr)
7476
7477       implicit real*8 (a-h,o-z)
7478       include 'DIMENSIONS'
7479       include 'DIMENSIONS.ZSCOPT'
7480       include 'COMMON.VAR'
7481       include 'COMMON.GEO'
7482       include 'COMMON.LOCAL'
7483       include 'COMMON.TORSION'
7484       include 'COMMON.INTERACT'
7485       include 'COMMON.DERIV'
7486       include 'COMMON.CHAIN'
7487       include 'COMMON.NAMES'
7488       include 'COMMON.IOUNITS'
7489       include 'COMMON.FFIELD'
7490       include 'COMMON.TORCNSTR'
7491       include 'COMMON.CONTROL'
7492       ethetacnstr=0.0d0
7493 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7494       do i=ithetaconstr_start,ithetaconstr_end
7495         itheta=itheta_constr(i)
7496         thetiii=theta(itheta)
7497         difi=pinorm(thetiii-theta_constr0(i))
7498         if (difi.gt.theta_drange(i)) then
7499           difi=difi-theta_drange(i)
7500           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7501           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7502      &    +for_thet_constr(i)*difi**3
7503           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
7504      &      +for_thet_constr(i)*difi**3
7505         else if (difi.lt.-drange(i)) then
7506           difi=difi+drange(i)
7507           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7508           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7509      &    +for_thet_constr(i)*difi**3
7510           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
7511      &    +for_thet_constr(i)*difi**3
7512         else
7513           difi=0.0
7514         endif
7515        if (energy_dec) then
7516         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7517      &    i,itheta,rad2deg*thetiii,
7518      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7519      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7520      &    gloc(itheta+nphi-2,icg)
7521         endif
7522       enddo
7523       return
7524       end
7525 c------------------------------------------------------------------------------
7526       subroutine eback_sc_corr(esccor)
7527 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7528 c        conformational states; temporarily implemented as differences
7529 c        between UNRES torsional potentials (dependent on three types of
7530 c        residues) and the torsional potentials dependent on all 20 types
7531 c        of residues computed from AM1 energy surfaces of terminally-blocked
7532 c        amino-acid residues.
7533       implicit real*8 (a-h,o-z)
7534       include 'DIMENSIONS'
7535       include 'DIMENSIONS.ZSCOPT'
7536       include 'COMMON.VAR'
7537       include 'COMMON.GEO'
7538       include 'COMMON.LOCAL'
7539       include 'COMMON.TORSION'
7540       include 'COMMON.SCCOR'
7541       include 'COMMON.INTERACT'
7542       include 'COMMON.DERIV'
7543       include 'COMMON.CHAIN'
7544       include 'COMMON.NAMES'
7545       include 'COMMON.IOUNITS'
7546       include 'COMMON.FFIELD'
7547       include 'COMMON.CONTROL'
7548       logical lprn
7549 C Set lprn=.true. for debugging
7550       lprn=.false.
7551 c      lprn=.true.
7552 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7553       esccor=0.0D0
7554       do i=itau_start,itau_end
7555         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7556         esccor_ii=0.0D0
7557         isccori=isccortyp(itype(i-2))
7558         isccori1=isccortyp(itype(i-1))
7559         phii=phi(i)
7560         do intertyp=1,3 !intertyp
7561 cc Added 09 May 2012 (Adasko)
7562 cc  Intertyp means interaction type of backbone mainchain correlation:
7563 c   1 = SC...Ca...Ca...Ca
7564 c   2 = Ca...Ca...Ca...SC
7565 c   3 = SC...Ca...Ca...SCi
7566         gloci=0.0D0
7567         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7568      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7569      &      (itype(i-1).eq.ntyp1)))
7570      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7571      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7572      &     .or.(itype(i).eq.ntyp1)))
7573      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7574      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7575      &      (itype(i-3).eq.ntyp1)))) cycle
7576         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7577         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7578      & cycle
7579        do j=1,nterm_sccor(isccori,isccori1)
7580           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7581           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7582           cosphi=dcos(j*tauangle(intertyp,i))
7583           sinphi=dsin(j*tauangle(intertyp,i))
7584            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7585            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7586          enddo
7587 C      write (iout,*)"EBACK_SC_COR",esccor,i
7588 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7589 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7590 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7591         if (lprn)
7592      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7593      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7594      &  (v1sccor(j,1,itori,itori1),j=1,6)
7595      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7596 c        gsccor_loc(i-3)=gloci
7597        enddo !intertyp
7598       enddo
7599       return
7600       end
7601 c------------------------------------------------------------------------------
7602       subroutine multibody(ecorr)
7603 C This subroutine calculates multi-body contributions to energy following
7604 C the idea of Skolnick et al. If side chains I and J make a contact and
7605 C at the same time side chains I+1 and J+1 make a contact, an extra
7606 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7607       implicit real*8 (a-h,o-z)
7608       include 'DIMENSIONS'
7609       include 'DIMENSIONS.ZSCOPT'
7610       include 'COMMON.IOUNITS'
7611       include 'COMMON.DERIV'
7612       include 'COMMON.INTERACT'
7613       include 'COMMON.CONTACTS'
7614       double precision gx(3),gx1(3)
7615       logical lprn
7616
7617 C Set lprn=.true. for debugging
7618       lprn=.false.
7619
7620       if (lprn) then
7621         write (iout,'(a)') 'Contact function values:'
7622         do i=nnt,nct-2
7623           write (iout,'(i2,20(1x,i2,f10.5))')
7624      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7625         enddo
7626       endif
7627       ecorr=0.0D0
7628       do i=nnt,nct
7629         do j=1,3
7630           gradcorr(j,i)=0.0D0
7631           gradxorr(j,i)=0.0D0
7632         enddo
7633       enddo
7634       do i=nnt,nct-2
7635
7636         DO ISHIFT = 3,4
7637
7638         i1=i+ishift
7639         num_conti=num_cont(i)
7640         num_conti1=num_cont(i1)
7641         do jj=1,num_conti
7642           j=jcont(jj,i)
7643           do kk=1,num_conti1
7644             j1=jcont(kk,i1)
7645             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7646 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7647 cd   &                   ' ishift=',ishift
7648 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7649 C The system gains extra energy.
7650               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7651             endif   ! j1==j+-ishift
7652           enddo     ! kk
7653         enddo       ! jj
7654
7655         ENDDO ! ISHIFT
7656
7657       enddo         ! i
7658       return
7659       end
7660 c------------------------------------------------------------------------------
7661       double precision function esccorr(i,j,k,l,jj,kk)
7662       implicit real*8 (a-h,o-z)
7663       include 'DIMENSIONS'
7664       include 'DIMENSIONS.ZSCOPT'
7665       include 'COMMON.IOUNITS'
7666       include 'COMMON.DERIV'
7667       include 'COMMON.INTERACT'
7668       include 'COMMON.CONTACTS'
7669       double precision gx(3),gx1(3)
7670       logical lprn
7671       lprn=.false.
7672       eij=facont(jj,i)
7673       ekl=facont(kk,k)
7674 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7675 C Calculate the multi-body contribution to energy.
7676 C Calculate multi-body contributions to the gradient.
7677 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7678 cd   & k,l,(gacont(m,kk,k),m=1,3)
7679       do m=1,3
7680         gx(m) =ekl*gacont(m,jj,i)
7681         gx1(m)=eij*gacont(m,kk,k)
7682         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7683         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7684         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7685         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7686       enddo
7687       do m=i,j-1
7688         do ll=1,3
7689           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7690         enddo
7691       enddo
7692       do m=k,l-1
7693         do ll=1,3
7694           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7695         enddo
7696       enddo
7697       esccorr=-eij*ekl
7698       return
7699       end
7700 c------------------------------------------------------------------------------
7701       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7702 C This subroutine calculates multi-body contributions to hydrogen-bonding
7703       implicit real*8 (a-h,o-z)
7704       include 'DIMENSIONS'
7705       include 'DIMENSIONS.ZSCOPT'
7706       include 'COMMON.IOUNITS'
7707       include 'COMMON.FFIELD'
7708       include 'COMMON.DERIV'
7709       include 'COMMON.INTERACT'
7710       include 'COMMON.CONTACTS'
7711       double precision gx(3),gx1(3)
7712       logical lprn,ldone
7713
7714 C Set lprn=.true. for debugging
7715       lprn=.false.
7716       if (lprn) then
7717         write (iout,'(a)') 'Contact function values:'
7718         do i=nnt,nct-2
7719           write (iout,'(2i3,50(1x,i2,f5.2))')
7720      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7721      &    j=1,num_cont_hb(i))
7722         enddo
7723       endif
7724       ecorr=0.0D0
7725 C Remove the loop below after debugging !!!
7726       do i=nnt,nct
7727         do j=1,3
7728           gradcorr(j,i)=0.0D0
7729           gradxorr(j,i)=0.0D0
7730         enddo
7731       enddo
7732 C Calculate the local-electrostatic correlation terms
7733       do i=iatel_s,iatel_e+1
7734         i1=i+1
7735         num_conti=num_cont_hb(i)
7736         num_conti1=num_cont_hb(i+1)
7737         do jj=1,num_conti
7738           j=jcont_hb(jj,i)
7739           do kk=1,num_conti1
7740             j1=jcont_hb(kk,i1)
7741 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7742 c     &         ' jj=',jj,' kk=',kk
7743             if (j1.eq.j+1 .or. j1.eq.j-1) then
7744 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7745 C The system gains extra energy.
7746               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7747               n_corr=n_corr+1
7748             else if (j1.eq.j) then
7749 C Contacts I-J and I-(J+1) occur simultaneously.
7750 C The system loses extra energy.
7751 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7752             endif
7753           enddo ! kk
7754           do kk=1,num_conti
7755             j1=jcont_hb(kk,i)
7756 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7757 c    &         ' jj=',jj,' kk=',kk
7758             if (j1.eq.j+1) then
7759 C Contacts I-J and (I+1)-J occur simultaneously.
7760 C The system loses extra energy.
7761 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7762             endif ! j1==j+1
7763           enddo ! kk
7764         enddo ! jj
7765       enddo ! i
7766       return
7767       end
7768 c------------------------------------------------------------------------------
7769       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7770      &  n_corr1)
7771 C This subroutine calculates multi-body contributions to hydrogen-bonding
7772       implicit real*8 (a-h,o-z)
7773       include 'DIMENSIONS'
7774       include 'DIMENSIONS.ZSCOPT'
7775       include 'COMMON.IOUNITS'
7776 #ifdef MPI
7777       include "mpif.h"
7778 #endif
7779       include 'COMMON.FFIELD'
7780       include 'COMMON.DERIV'
7781       include 'COMMON.LOCAL'
7782       include 'COMMON.INTERACT'
7783       include 'COMMON.CONTACTS'
7784       include 'COMMON.CHAIN'
7785       include 'COMMON.CONTROL'
7786       include 'COMMON.SHIELD'
7787       double precision gx(3),gx1(3)
7788       integer num_cont_hb_old(maxres)
7789       logical lprn,ldone
7790       double precision eello4,eello5,eelo6,eello_turn6
7791       external eello4,eello5,eello6,eello_turn6
7792 C Set lprn=.true. for debugging
7793       lprn=.false.
7794       eturn6=0.0d0
7795       if (lprn) then
7796         write (iout,'(a)') 'Contact function values:'
7797         do i=nnt,nct-2
7798           write (iout,'(2i3,50(1x,i2,5f6.3))')
7799      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7800      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7801         enddo
7802       endif
7803       ecorr=0.0D0
7804       ecorr5=0.0d0
7805       ecorr6=0.0d0
7806 C Remove the loop below after debugging !!!
7807       do i=nnt,nct
7808         do j=1,3
7809           gradcorr(j,i)=0.0D0
7810           gradxorr(j,i)=0.0D0
7811         enddo
7812       enddo
7813 C Calculate the dipole-dipole interaction energies
7814       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7815       do i=iatel_s,iatel_e+1
7816         num_conti=num_cont_hb(i)
7817         do jj=1,num_conti
7818           j=jcont_hb(jj,i)
7819 #ifdef MOMENT
7820           call dipole(i,j,jj)
7821 #endif
7822         enddo
7823       enddo
7824       endif
7825 C Calculate the local-electrostatic correlation terms
7826 c                write (iout,*) "gradcorr5 in eello5 before loop"
7827 c                do iii=1,nres
7828 c                  write (iout,'(i5,3f10.5)')
7829 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7830 c                enddo
7831       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7832 c        write (iout,*) "corr loop i",i
7833         i1=i+1
7834         num_conti=num_cont_hb(i)
7835         num_conti1=num_cont_hb(i+1)
7836         do jj=1,num_conti
7837           j=jcont_hb(jj,i)
7838           jp=iabs(j)
7839           do kk=1,num_conti1
7840             j1=jcont_hb(kk,i1)
7841             jp1=iabs(j1)
7842 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7843 c     &         ' jj=',jj,' kk=',kk
7844 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7845             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7846      &          .or. j.lt.0 .and. j1.gt.0) .and.
7847      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7848 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7849 C The system gains extra energy.
7850               n_corr=n_corr+1
7851               sqd1=dsqrt(d_cont(jj,i))
7852               sqd2=dsqrt(d_cont(kk,i1))
7853               sred_geom = sqd1*sqd2
7854               IF (sred_geom.lt.cutoff_corr) THEN
7855                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7856      &            ekont,fprimcont)
7857 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7858 cd     &         ' jj=',jj,' kk=',kk
7859                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7860                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7861                 do l=1,3
7862                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7863                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7864                 enddo
7865                 n_corr1=n_corr1+1
7866 cd               write (iout,*) 'sred_geom=',sred_geom,
7867 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7868 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7869 cd               write (iout,*) "g_contij",g_contij
7870 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7871 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7872                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7873                 if (wcorr4.gt.0.0d0)
7874      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7875 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7876                   if (energy_dec.and.wcorr4.gt.0.0d0)
7877      1                 write (iout,'(a6,4i5,0pf7.3)')
7878      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7879 c                write (iout,*) "gradcorr5 before eello5"
7880 c                do iii=1,nres
7881 c                  write (iout,'(i5,3f10.5)')
7882 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7883 c                enddo
7884                 if (wcorr5.gt.0.0d0)
7885      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7886 c                write (iout,*) "gradcorr5 after eello5"
7887 c                do iii=1,nres
7888 c                  write (iout,'(i5,3f10.5)')
7889 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7890 c                enddo
7891                   if (energy_dec.and.wcorr5.gt.0.0d0)
7892      1                 write (iout,'(a6,4i5,0pf7.3)')
7893      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7894 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7895 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7896                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7897      &               .or. wturn6.eq.0.0d0))then
7898 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7899                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7900                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7901      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7902 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7903 cd     &            'ecorr6=',ecorr6
7904 cd                write (iout,'(4e15.5)') sred_geom,
7905 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7906 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7907 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7908                 else if (wturn6.gt.0.0d0
7909      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7910 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7911                   eturn6=eturn6+eello_turn6(i,jj,kk)
7912                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7913      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7914 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7915                 endif
7916               ENDIF
7917 1111          continue
7918             endif
7919           enddo ! kk
7920         enddo ! jj
7921       enddo ! i
7922       do i=1,nres
7923         num_cont_hb(i)=num_cont_hb_old(i)
7924       enddo
7925 c                write (iout,*) "gradcorr5 in eello5"
7926 c                do iii=1,nres
7927 c                  write (iout,'(i5,3f10.5)')
7928 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7929 c                enddo
7930       return
7931       end
7932 c------------------------------------------------------------------------------
7933       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7934       implicit real*8 (a-h,o-z)
7935       include 'DIMENSIONS'
7936       include 'DIMENSIONS.ZSCOPT'
7937       include 'COMMON.IOUNITS'
7938       include 'COMMON.DERIV'
7939       include 'COMMON.INTERACT'
7940       include 'COMMON.CONTACTS'
7941       include 'COMMON.SHIELD'
7942       include 'COMMON.CONTROL'
7943       double precision gx(3),gx1(3)
7944       logical lprn
7945       lprn=.false.
7946 C      print *,"wchodze",fac_shield(i),shield_mode
7947       eij=facont_hb(jj,i)
7948       ekl=facont_hb(kk,k)
7949       ees0pij=ees0p(jj,i)
7950       ees0pkl=ees0p(kk,k)
7951       ees0mij=ees0m(jj,i)
7952       ees0mkl=ees0m(kk,k)
7953       ekont=eij*ekl
7954       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7955 C*
7956 C     & fac_shield(i)**2*fac_shield(j)**2
7957 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7958 C Following 4 lines for diagnostics.
7959 cd    ees0pkl=0.0D0
7960 cd    ees0pij=1.0D0
7961 cd    ees0mkl=0.0D0
7962 cd    ees0mij=1.0D0
7963 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7964 c     & 'Contacts ',i,j,
7965 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7966 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7967 c     & 'gradcorr_long'
7968 C Calculate the multi-body contribution to energy.
7969 C      ecorr=ecorr+ekont*ees
7970 C Calculate multi-body contributions to the gradient.
7971       coeffpees0pij=coeffp*ees0pij
7972       coeffmees0mij=coeffm*ees0mij
7973       coeffpees0pkl=coeffp*ees0pkl
7974       coeffmees0mkl=coeffm*ees0mkl
7975       do ll=1,3
7976 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7977         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7978      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7979      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7980         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7981      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7982      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7983 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7984         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7985      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7986      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7987         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7988      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7989      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7990         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7991      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7992      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7993         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7994         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7995         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7996      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7997      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7998         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7999         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8000 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8001       enddo
8002 c      write (iout,*)
8003 cgrad      do m=i+1,j-1
8004 cgrad        do ll=1,3
8005 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8006 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8007 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8008 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8009 cgrad        enddo
8010 cgrad      enddo
8011 cgrad      do m=k+1,l-1
8012 cgrad        do ll=1,3
8013 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8014 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8015 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8016 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8017 cgrad        enddo
8018 cgrad      enddo
8019 c      write (iout,*) "ehbcorr",ekont*ees
8020 C      print *,ekont,ees,i,k
8021       ehbcorr=ekont*ees
8022 C now gradient over shielding
8023 C      return
8024       if (shield_mode.gt.0) then
8025        j=ees0plist(jj,i)
8026        l=ees0plist(kk,k)
8027 C        print *,i,j,fac_shield(i),fac_shield(j),
8028 C     &fac_shield(k),fac_shield(l)
8029         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8030      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8031           do ilist=1,ishield_list(i)
8032            iresshield=shield_list(ilist,i)
8033            do m=1,3
8034            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8035 C     &      *2.0
8036            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8037      &              rlocshield
8038      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8039             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8040      &+rlocshield
8041            enddo
8042           enddo
8043           do ilist=1,ishield_list(j)
8044            iresshield=shield_list(ilist,j)
8045            do m=1,3
8046            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8047 C     &     *2.0
8048            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8049      &              rlocshield
8050      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8051            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8052      &     +rlocshield
8053            enddo
8054           enddo
8055
8056           do ilist=1,ishield_list(k)
8057            iresshield=shield_list(ilist,k)
8058            do m=1,3
8059            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8060 C     &     *2.0
8061            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8062      &              rlocshield
8063      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8064            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8065      &     +rlocshield
8066            enddo
8067           enddo
8068           do ilist=1,ishield_list(l)
8069            iresshield=shield_list(ilist,l)
8070            do m=1,3
8071            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8072 C     &     *2.0
8073            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8074      &              rlocshield
8075      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8076            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8077      &     +rlocshield
8078            enddo
8079           enddo
8080 C          print *,gshieldx(m,iresshield)
8081           do m=1,3
8082             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8083      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8084             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8085      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8086             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8087      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8088             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8089      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8090
8091             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8092      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8093             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8094      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8095             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8096      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8097             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8098      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8099
8100            enddo
8101       endif
8102       endif
8103       return
8104       end
8105 #ifdef MOMENT
8106 C---------------------------------------------------------------------------
8107       subroutine dipole(i,j,jj)
8108       implicit real*8 (a-h,o-z)
8109       include 'DIMENSIONS'
8110       include 'DIMENSIONS.ZSCOPT'
8111       include 'COMMON.IOUNITS'
8112       include 'COMMON.CHAIN'
8113       include 'COMMON.FFIELD'
8114       include 'COMMON.DERIV'
8115       include 'COMMON.INTERACT'
8116       include 'COMMON.CONTACTS'
8117       include 'COMMON.TORSION'
8118       include 'COMMON.VAR'
8119       include 'COMMON.GEO'
8120       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8121      &  auxmat(2,2)
8122       iti1 = itortyp(itype(i+1))
8123       if (j.lt.nres-1) then
8124         itj1 = itype2loc(itype(j+1))
8125       else
8126         itj1=nloctyp
8127       endif
8128       do iii=1,2
8129         dipi(iii,1)=Ub2(iii,i)
8130         dipderi(iii)=Ub2der(iii,i)
8131         dipi(iii,2)=b1(iii,i+1)
8132         dipj(iii,1)=Ub2(iii,j)
8133         dipderj(iii)=Ub2der(iii,j)
8134         dipj(iii,2)=b1(iii,j+1)
8135       enddo
8136       kkk=0
8137       do iii=1,2
8138         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8139         do jjj=1,2
8140           kkk=kkk+1
8141           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8142         enddo
8143       enddo
8144       do kkk=1,5
8145         do lll=1,3
8146           mmm=0
8147           do iii=1,2
8148             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8149      &        auxvec(1))
8150             do jjj=1,2
8151               mmm=mmm+1
8152               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8153             enddo
8154           enddo
8155         enddo
8156       enddo
8157       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8158       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8159       do iii=1,2
8160         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8161       enddo
8162       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8163       do iii=1,2
8164         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8165       enddo
8166       return
8167       end
8168 #endif
8169 C---------------------------------------------------------------------------
8170       subroutine calc_eello(i,j,k,l,jj,kk)
8171 C
8172 C This subroutine computes matrices and vectors needed to calculate
8173 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8174 C
8175       implicit real*8 (a-h,o-z)
8176       include 'DIMENSIONS'
8177       include 'DIMENSIONS.ZSCOPT'
8178       include 'COMMON.IOUNITS'
8179       include 'COMMON.CHAIN'
8180       include 'COMMON.DERIV'
8181       include 'COMMON.INTERACT'
8182       include 'COMMON.CONTACTS'
8183       include 'COMMON.TORSION'
8184       include 'COMMON.VAR'
8185       include 'COMMON.GEO'
8186       include 'COMMON.FFIELD'
8187       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8188      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8189       logical lprn
8190       common /kutas/ lprn
8191 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8192 cd     & ' jj=',jj,' kk=',kk
8193 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8194 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8195 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8196       do iii=1,2
8197         do jjj=1,2
8198           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8199           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8200         enddo
8201       enddo
8202       call transpose2(aa1(1,1),aa1t(1,1))
8203       call transpose2(aa2(1,1),aa2t(1,1))
8204       do kkk=1,5
8205         do lll=1,3
8206           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8207      &      aa1tder(1,1,lll,kkk))
8208           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8209      &      aa2tder(1,1,lll,kkk))
8210         enddo
8211       enddo
8212       if (l.eq.j+1) then
8213 C parallel orientation of the two CA-CA-CA frames.
8214         if (i.gt.1) then
8215           iti=itype2loc(itype(i))
8216         else
8217           iti=nloctyp
8218         endif
8219         itk1=itype2loc(itype(k+1))
8220         itj=itype2loc(itype(j))
8221         if (l.lt.nres-1) then
8222           itl1=itype2loc(itype(l+1))
8223         else
8224           itl1=nloctyp
8225         endif
8226 C A1 kernel(j+1) A2T
8227 cd        do iii=1,2
8228 cd          write (iout,'(3f10.5,5x,3f10.5)')
8229 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8230 cd        enddo
8231         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8232      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8233      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8234 C Following matrices are needed only for 6-th order cumulants
8235         IF (wcorr6.gt.0.0d0) THEN
8236         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8237      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8238      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8239         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8240      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8241      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8242      &   ADtEAderx(1,1,1,1,1,1))
8243         lprn=.false.
8244         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8245      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8246      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8247      &   ADtEA1derx(1,1,1,1,1,1))
8248         ENDIF
8249 C End 6-th order cumulants
8250 cd        lprn=.false.
8251 cd        if (lprn) then
8252 cd        write (2,*) 'In calc_eello6'
8253 cd        do iii=1,2
8254 cd          write (2,*) 'iii=',iii
8255 cd          do kkk=1,5
8256 cd            write (2,*) 'kkk=',kkk
8257 cd            do jjj=1,2
8258 cd              write (2,'(3(2f10.5),5x)')
8259 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8260 cd            enddo
8261 cd          enddo
8262 cd        enddo
8263 cd        endif
8264         call transpose2(EUgder(1,1,k),auxmat(1,1))
8265         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8266         call transpose2(EUg(1,1,k),auxmat(1,1))
8267         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8268         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8269         do iii=1,2
8270           do kkk=1,5
8271             do lll=1,3
8272               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8273      &          EAEAderx(1,1,lll,kkk,iii,1))
8274             enddo
8275           enddo
8276         enddo
8277 C A1T kernel(i+1) A2
8278         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8279      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8280      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8281 C Following matrices are needed only for 6-th order cumulants
8282         IF (wcorr6.gt.0.0d0) THEN
8283         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8284      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8285      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8286         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8287      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8288      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8289      &   ADtEAderx(1,1,1,1,1,2))
8290         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8291      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8292      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8293      &   ADtEA1derx(1,1,1,1,1,2))
8294         ENDIF
8295 C End 6-th order cumulants
8296         call transpose2(EUgder(1,1,l),auxmat(1,1))
8297         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8298         call transpose2(EUg(1,1,l),auxmat(1,1))
8299         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8300         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8301         do iii=1,2
8302           do kkk=1,5
8303             do lll=1,3
8304               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8305      &          EAEAderx(1,1,lll,kkk,iii,2))
8306             enddo
8307           enddo
8308         enddo
8309 C AEAb1 and AEAb2
8310 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8311 C They are needed only when the fifth- or the sixth-order cumulants are
8312 C indluded.
8313         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8314         call transpose2(AEA(1,1,1),auxmat(1,1))
8315         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8316         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8317         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8318         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8319         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8320         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8321         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8322         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8323         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8324         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8325         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8326         call transpose2(AEA(1,1,2),auxmat(1,1))
8327         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8328         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8329         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8330         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8331         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8332         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8333         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8334         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8335         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8336         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8337         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8338 C Calculate the Cartesian derivatives of the vectors.
8339         do iii=1,2
8340           do kkk=1,5
8341             do lll=1,3
8342               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8343               call matvec2(auxmat(1,1),b1(1,i),
8344      &          AEAb1derx(1,lll,kkk,iii,1,1))
8345               call matvec2(auxmat(1,1),Ub2(1,i),
8346      &          AEAb2derx(1,lll,kkk,iii,1,1))
8347               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8348      &          AEAb1derx(1,lll,kkk,iii,2,1))
8349               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8350      &          AEAb2derx(1,lll,kkk,iii,2,1))
8351               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8352               call matvec2(auxmat(1,1),b1(1,j),
8353      &          AEAb1derx(1,lll,kkk,iii,1,2))
8354               call matvec2(auxmat(1,1),Ub2(1,j),
8355      &          AEAb2derx(1,lll,kkk,iii,1,2))
8356               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8357      &          AEAb1derx(1,lll,kkk,iii,2,2))
8358               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8359      &          AEAb2derx(1,lll,kkk,iii,2,2))
8360             enddo
8361           enddo
8362         enddo
8363         ENDIF
8364 C End vectors
8365       else
8366 C Antiparallel orientation of the two CA-CA-CA frames.
8367         if (i.gt.1) then
8368           iti=itype2loc(itype(i))
8369         else
8370           iti=nloctyp
8371         endif
8372         itk1=itype2loc(itype(k+1))
8373         itl=itype2loc(itype(l))
8374         itj=itype2loc(itype(j))
8375         if (j.lt.nres-1) then
8376           itj1=itype2loc(itype(j+1))
8377         else
8378           itj1=nloctyp
8379         endif
8380 C A2 kernel(j-1)T A1T
8381         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8382      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8383      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8384 C Following matrices are needed only for 6-th order cumulants
8385         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8386      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8387         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8388      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8389      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8390         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8391      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8392      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8393      &   ADtEAderx(1,1,1,1,1,1))
8394         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8395      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8396      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8397      &   ADtEA1derx(1,1,1,1,1,1))
8398         ENDIF
8399 C End 6-th order cumulants
8400         call transpose2(EUgder(1,1,k),auxmat(1,1))
8401         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8402         call transpose2(EUg(1,1,k),auxmat(1,1))
8403         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8404         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8405         do iii=1,2
8406           do kkk=1,5
8407             do lll=1,3
8408               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8409      &          EAEAderx(1,1,lll,kkk,iii,1))
8410             enddo
8411           enddo
8412         enddo
8413 C A2T kernel(i+1)T A1
8414         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8415      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8416      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8417 C Following matrices are needed only for 6-th order cumulants
8418         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8419      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8420         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8421      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8422      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8423         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8424      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8425      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8426      &   ADtEAderx(1,1,1,1,1,2))
8427         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8428      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8429      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8430      &   ADtEA1derx(1,1,1,1,1,2))
8431         ENDIF
8432 C End 6-th order cumulants
8433         call transpose2(EUgder(1,1,j),auxmat(1,1))
8434         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8435         call transpose2(EUg(1,1,j),auxmat(1,1))
8436         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8437         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8438         do iii=1,2
8439           do kkk=1,5
8440             do lll=1,3
8441               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8442      &          EAEAderx(1,1,lll,kkk,iii,2))
8443             enddo
8444           enddo
8445         enddo
8446 C AEAb1 and AEAb2
8447 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8448 C They are needed only when the fifth- or the sixth-order cumulants are
8449 C indluded.
8450         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8451      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8452         call transpose2(AEA(1,1,1),auxmat(1,1))
8453         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8454         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8455         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8456         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8457         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8458         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8459         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8460         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8461         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8462         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8463         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8464         call transpose2(AEA(1,1,2),auxmat(1,1))
8465         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8466         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8467         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8468         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8469         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8470         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8471         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8472         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8473         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8474         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8475         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8476 C Calculate the Cartesian derivatives of the vectors.
8477         do iii=1,2
8478           do kkk=1,5
8479             do lll=1,3
8480               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8481               call matvec2(auxmat(1,1),b1(1,i),
8482      &          AEAb1derx(1,lll,kkk,iii,1,1))
8483               call matvec2(auxmat(1,1),Ub2(1,i),
8484      &          AEAb2derx(1,lll,kkk,iii,1,1))
8485               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8486      &          AEAb1derx(1,lll,kkk,iii,2,1))
8487               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8488      &          AEAb2derx(1,lll,kkk,iii,2,1))
8489               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8490               call matvec2(auxmat(1,1),b1(1,l),
8491      &          AEAb1derx(1,lll,kkk,iii,1,2))
8492               call matvec2(auxmat(1,1),Ub2(1,l),
8493      &          AEAb2derx(1,lll,kkk,iii,1,2))
8494               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8495      &          AEAb1derx(1,lll,kkk,iii,2,2))
8496               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8497      &          AEAb2derx(1,lll,kkk,iii,2,2))
8498             enddo
8499           enddo
8500         enddo
8501         ENDIF
8502 C End vectors
8503       endif
8504       return
8505       end
8506 C---------------------------------------------------------------------------
8507       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8508      &  KK,KKderg,AKA,AKAderg,AKAderx)
8509       implicit none
8510       integer nderg
8511       logical transp
8512       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8513      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8514      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8515       integer iii,kkk,lll
8516       integer jjj,mmm
8517       logical lprn
8518       common /kutas/ lprn
8519       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8520       do iii=1,nderg
8521         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8522      &    AKAderg(1,1,iii))
8523       enddo
8524 cd      if (lprn) write (2,*) 'In kernel'
8525       do kkk=1,5
8526 cd        if (lprn) write (2,*) 'kkk=',kkk
8527         do lll=1,3
8528           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8529      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8530 cd          if (lprn) then
8531 cd            write (2,*) 'lll=',lll
8532 cd            write (2,*) 'iii=1'
8533 cd            do jjj=1,2
8534 cd              write (2,'(3(2f10.5),5x)')
8535 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8536 cd            enddo
8537 cd          endif
8538           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8539      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8540 cd          if (lprn) then
8541 cd            write (2,*) 'lll=',lll
8542 cd            write (2,*) 'iii=2'
8543 cd            do jjj=1,2
8544 cd              write (2,'(3(2f10.5),5x)')
8545 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8546 cd            enddo
8547 cd          endif
8548         enddo
8549       enddo
8550       return
8551       end
8552 C---------------------------------------------------------------------------
8553       double precision function eello4(i,j,k,l,jj,kk)
8554       implicit real*8 (a-h,o-z)
8555       include 'DIMENSIONS'
8556       include 'DIMENSIONS.ZSCOPT'
8557       include 'COMMON.IOUNITS'
8558       include 'COMMON.CHAIN'
8559       include 'COMMON.DERIV'
8560       include 'COMMON.INTERACT'
8561       include 'COMMON.CONTACTS'
8562       include 'COMMON.TORSION'
8563       include 'COMMON.VAR'
8564       include 'COMMON.GEO'
8565       double precision pizda(2,2),ggg1(3),ggg2(3)
8566 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8567 cd        eello4=0.0d0
8568 cd        return
8569 cd      endif
8570 cd      print *,'eello4:',i,j,k,l,jj,kk
8571 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8572 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8573 cold      eij=facont_hb(jj,i)
8574 cold      ekl=facont_hb(kk,k)
8575 cold      ekont=eij*ekl
8576       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8577       if (calc_grad) then
8578 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8579       gcorr_loc(k-1)=gcorr_loc(k-1)
8580      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8581       if (l.eq.j+1) then
8582         gcorr_loc(l-1)=gcorr_loc(l-1)
8583      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8584       else
8585         gcorr_loc(j-1)=gcorr_loc(j-1)
8586      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8587       endif
8588       do iii=1,2
8589         do kkk=1,5
8590           do lll=1,3
8591             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8592      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8593 cd            derx(lll,kkk,iii)=0.0d0
8594           enddo
8595         enddo
8596       enddo
8597 cd      gcorr_loc(l-1)=0.0d0
8598 cd      gcorr_loc(j-1)=0.0d0
8599 cd      gcorr_loc(k-1)=0.0d0
8600 cd      eel4=1.0d0
8601 cd      write (iout,*)'Contacts have occurred for peptide groups',
8602 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8603 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8604       if (j.lt.nres-1) then
8605         j1=j+1
8606         j2=j-1
8607       else
8608         j1=j-1
8609         j2=j-2
8610       endif
8611       if (l.lt.nres-1) then
8612         l1=l+1
8613         l2=l-1
8614       else
8615         l1=l-1
8616         l2=l-2
8617       endif
8618       do ll=1,3
8619 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8620 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8621         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8622         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8623 cgrad        ghalf=0.5d0*ggg1(ll)
8624         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8625         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8626         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8627         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8628         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8629         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8630 cgrad        ghalf=0.5d0*ggg2(ll)
8631         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8632         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8633         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8634         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8635         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8636         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8637       enddo
8638 cgrad      do m=i+1,j-1
8639 cgrad        do ll=1,3
8640 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8641 cgrad        enddo
8642 cgrad      enddo
8643 cgrad      do m=k+1,l-1
8644 cgrad        do ll=1,3
8645 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8646 cgrad        enddo
8647 cgrad      enddo
8648 cgrad      do m=i+2,j2
8649 cgrad        do ll=1,3
8650 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8651 cgrad        enddo
8652 cgrad      enddo
8653 cgrad      do m=k+2,l2
8654 cgrad        do ll=1,3
8655 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8656 cgrad        enddo
8657 cgrad      enddo
8658 cd      do iii=1,nres-3
8659 cd        write (2,*) iii,gcorr_loc(iii)
8660 cd      enddo
8661       endif ! calc_grad
8662       eello4=ekont*eel4
8663 cd      write (2,*) 'ekont',ekont
8664 cd      write (iout,*) 'eello4',ekont*eel4
8665       return
8666       end
8667 C---------------------------------------------------------------------------
8668       double precision function eello5(i,j,k,l,jj,kk)
8669       implicit real*8 (a-h,o-z)
8670       include 'DIMENSIONS'
8671       include 'DIMENSIONS.ZSCOPT'
8672       include 'COMMON.IOUNITS'
8673       include 'COMMON.CHAIN'
8674       include 'COMMON.DERIV'
8675       include 'COMMON.INTERACT'
8676       include 'COMMON.CONTACTS'
8677       include 'COMMON.TORSION'
8678       include 'COMMON.VAR'
8679       include 'COMMON.GEO'
8680       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8681       double precision ggg1(3),ggg2(3)
8682 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8683 C                                                                              C
8684 C                            Parallel chains                                   C
8685 C                                                                              C
8686 C          o             o                   o             o                   C
8687 C         /l\           / \             \   / \           / \   /              C
8688 C        /   \         /   \             \ /   \         /   \ /               C
8689 C       j| o |l1       | o |              o| o |         | o |o                C
8690 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8691 C      \i/   \         /   \ /             /   \         /   \                 C
8692 C       o    k1             o                                                  C
8693 C         (I)          (II)                (III)          (IV)                 C
8694 C                                                                              C
8695 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8696 C                                                                              C
8697 C                            Antiparallel chains                               C
8698 C                                                                              C
8699 C          o             o                   o             o                   C
8700 C         /j\           / \             \   / \           / \   /              C
8701 C        /   \         /   \             \ /   \         /   \ /               C
8702 C      j1| o |l        | o |              o| o |         | o |o                C
8703 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8704 C      \i/   \         /   \ /             /   \         /   \                 C
8705 C       o     k1            o                                                  C
8706 C         (I)          (II)                (III)          (IV)                 C
8707 C                                                                              C
8708 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8709 C                                                                              C
8710 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8711 C                                                                              C
8712 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8713 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8714 cd        eello5=0.0d0
8715 cd        return
8716 cd      endif
8717 cd      write (iout,*)
8718 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8719 cd     &   ' and',k,l
8720       itk=itype2loc(itype(k))
8721       itl=itype2loc(itype(l))
8722       itj=itype2loc(itype(j))
8723       eello5_1=0.0d0
8724       eello5_2=0.0d0
8725       eello5_3=0.0d0
8726       eello5_4=0.0d0
8727 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8728 cd     &   eel5_3_num,eel5_4_num)
8729       do iii=1,2
8730         do kkk=1,5
8731           do lll=1,3
8732             derx(lll,kkk,iii)=0.0d0
8733           enddo
8734         enddo
8735       enddo
8736 cd      eij=facont_hb(jj,i)
8737 cd      ekl=facont_hb(kk,k)
8738 cd      ekont=eij*ekl
8739 cd      write (iout,*)'Contacts have occurred for peptide groups',
8740 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8741 cd      goto 1111
8742 C Contribution from the graph I.
8743 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8744 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8745       call transpose2(EUg(1,1,k),auxmat(1,1))
8746       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8747       vv(1)=pizda(1,1)-pizda(2,2)
8748       vv(2)=pizda(1,2)+pizda(2,1)
8749       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8750      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8751       if (calc_grad) then
8752 C Explicit gradient in virtual-dihedral angles.
8753       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8754      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8755      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8756       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8757       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8758       vv(1)=pizda(1,1)-pizda(2,2)
8759       vv(2)=pizda(1,2)+pizda(2,1)
8760       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8761      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8762      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8763       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8764       vv(1)=pizda(1,1)-pizda(2,2)
8765       vv(2)=pizda(1,2)+pizda(2,1)
8766       if (l.eq.j+1) then
8767         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8768      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8769      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8770       else
8771         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8772      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8773      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8774       endif
8775 C Cartesian gradient
8776       do iii=1,2
8777         do kkk=1,5
8778           do lll=1,3
8779             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8780      &        pizda(1,1))
8781             vv(1)=pizda(1,1)-pizda(2,2)
8782             vv(2)=pizda(1,2)+pizda(2,1)
8783             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8784      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8785      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8786           enddo
8787         enddo
8788       enddo
8789       endif ! calc_grad
8790 c      goto 1112
8791 c1111  continue
8792 C Contribution from graph II
8793       call transpose2(EE(1,1,k),auxmat(1,1))
8794       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8795       vv(1)=pizda(1,1)+pizda(2,2)
8796       vv(2)=pizda(2,1)-pizda(1,2)
8797       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8798      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8799       if (calc_grad) then
8800 C Explicit gradient in virtual-dihedral angles.
8801       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8802      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8803       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8804       vv(1)=pizda(1,1)+pizda(2,2)
8805       vv(2)=pizda(2,1)-pizda(1,2)
8806       if (l.eq.j+1) then
8807         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8808      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8809      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8810       else
8811         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8812      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8813      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8814       endif
8815 C Cartesian gradient
8816       do iii=1,2
8817         do kkk=1,5
8818           do lll=1,3
8819             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8820      &        pizda(1,1))
8821             vv(1)=pizda(1,1)+pizda(2,2)
8822             vv(2)=pizda(2,1)-pizda(1,2)
8823             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8824      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8825      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8826           enddo
8827         enddo
8828       enddo
8829       endif ! calc_grad
8830 cd      goto 1112
8831 cd1111  continue
8832       if (l.eq.j+1) then
8833 cd        goto 1110
8834 C Parallel orientation
8835 C Contribution from graph III
8836         call transpose2(EUg(1,1,l),auxmat(1,1))
8837         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8838         vv(1)=pizda(1,1)-pizda(2,2)
8839         vv(2)=pizda(1,2)+pizda(2,1)
8840         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8841      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8842         if (calc_grad) then
8843 C Explicit gradient in virtual-dihedral angles.
8844         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8845      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8846      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8847         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8848         vv(1)=pizda(1,1)-pizda(2,2)
8849         vv(2)=pizda(1,2)+pizda(2,1)
8850         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8851      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8852      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8853         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8854         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8855         vv(1)=pizda(1,1)-pizda(2,2)
8856         vv(2)=pizda(1,2)+pizda(2,1)
8857         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8858      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8859      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8860 C Cartesian gradient
8861         do iii=1,2
8862           do kkk=1,5
8863             do lll=1,3
8864               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8865      &          pizda(1,1))
8866               vv(1)=pizda(1,1)-pizda(2,2)
8867               vv(2)=pizda(1,2)+pizda(2,1)
8868               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8869      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8870      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8871             enddo
8872           enddo
8873         enddo
8874 cd        goto 1112
8875 C Contribution from graph IV
8876 cd1110    continue
8877         call transpose2(EE(1,1,l),auxmat(1,1))
8878         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8879         vv(1)=pizda(1,1)+pizda(2,2)
8880         vv(2)=pizda(2,1)-pizda(1,2)
8881         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8882      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8883 C Explicit gradient in virtual-dihedral angles.
8884         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8885      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8886         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8887         vv(1)=pizda(1,1)+pizda(2,2)
8888         vv(2)=pizda(2,1)-pizda(1,2)
8889         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8890      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8891      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8892 C Cartesian gradient
8893         do iii=1,2
8894           do kkk=1,5
8895             do lll=1,3
8896               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8897      &          pizda(1,1))
8898               vv(1)=pizda(1,1)+pizda(2,2)
8899               vv(2)=pizda(2,1)-pizda(1,2)
8900               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8901      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8902      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8903             enddo
8904           enddo
8905         enddo
8906         endif ! calc_grad
8907       else
8908 C Antiparallel orientation
8909 C Contribution from graph III
8910 c        goto 1110
8911         call transpose2(EUg(1,1,j),auxmat(1,1))
8912         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8913         vv(1)=pizda(1,1)-pizda(2,2)
8914         vv(2)=pizda(1,2)+pizda(2,1)
8915         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8916      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8917         if (calc_grad) then
8918 C Explicit gradient in virtual-dihedral angles.
8919         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8920      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8921      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8922         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8923         vv(1)=pizda(1,1)-pizda(2,2)
8924         vv(2)=pizda(1,2)+pizda(2,1)
8925         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8926      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8927      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8928         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8929         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8930         vv(1)=pizda(1,1)-pizda(2,2)
8931         vv(2)=pizda(1,2)+pizda(2,1)
8932         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8933      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8934      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8935 C Cartesian gradient
8936         do iii=1,2
8937           do kkk=1,5
8938             do lll=1,3
8939               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8940      &          pizda(1,1))
8941               vv(1)=pizda(1,1)-pizda(2,2)
8942               vv(2)=pizda(1,2)+pizda(2,1)
8943               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8944      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8945      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8946             enddo
8947           enddo
8948         enddo
8949         endif ! calc_grad
8950 cd        goto 1112
8951 C Contribution from graph IV
8952 1110    continue
8953         call transpose2(EE(1,1,j),auxmat(1,1))
8954         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8955         vv(1)=pizda(1,1)+pizda(2,2)
8956         vv(2)=pizda(2,1)-pizda(1,2)
8957         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8958      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8959         if (calc_grad) then
8960 C Explicit gradient in virtual-dihedral angles.
8961         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8962      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8963         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8964         vv(1)=pizda(1,1)+pizda(2,2)
8965         vv(2)=pizda(2,1)-pizda(1,2)
8966         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8967      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8968      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8969 C Cartesian gradient
8970         do iii=1,2
8971           do kkk=1,5
8972             do lll=1,3
8973               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8974      &          pizda(1,1))
8975               vv(1)=pizda(1,1)+pizda(2,2)
8976               vv(2)=pizda(2,1)-pizda(1,2)
8977               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8978      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8979      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8980             enddo
8981           enddo
8982         enddo
8983         endif ! calc_grad
8984       endif
8985 1112  continue
8986       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8987 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8988 cd        write (2,*) 'ijkl',i,j,k,l
8989 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8990 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8991 cd      endif
8992 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8993 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8994 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8995 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8996       if (calc_grad) then
8997       if (j.lt.nres-1) then
8998         j1=j+1
8999         j2=j-1
9000       else
9001         j1=j-1
9002         j2=j-2
9003       endif
9004       if (l.lt.nres-1) then
9005         l1=l+1
9006         l2=l-1
9007       else
9008         l1=l-1
9009         l2=l-2
9010       endif
9011 cd      eij=1.0d0
9012 cd      ekl=1.0d0
9013 cd      ekont=1.0d0
9014 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9015 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9016 C        summed up outside the subrouine as for the other subroutines
9017 C        handling long-range interactions. The old code is commented out
9018 C        with "cgrad" to keep track of changes.
9019       do ll=1,3
9020 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9021 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9022         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9023         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9024 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9025 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9026 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9027 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9028 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9029 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9030 c     &   gradcorr5ij,
9031 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9032 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9033 cgrad        ghalf=0.5d0*ggg1(ll)
9034 cd        ghalf=0.0d0
9035         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9036         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9037         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9038         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9039         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9040         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9041 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9042 cgrad        ghalf=0.5d0*ggg2(ll)
9043 cd        ghalf=0.0d0
9044         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9045         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9046         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9047         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9048         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9049         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9050       enddo
9051       endif ! calc_grad
9052 cd      goto 1112
9053 cgrad      do m=i+1,j-1
9054 cgrad        do ll=1,3
9055 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9056 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9057 cgrad        enddo
9058 cgrad      enddo
9059 cgrad      do m=k+1,l-1
9060 cgrad        do ll=1,3
9061 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9062 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9063 cgrad        enddo
9064 cgrad      enddo
9065 c1112  continue
9066 cgrad      do m=i+2,j2
9067 cgrad        do ll=1,3
9068 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9069 cgrad        enddo
9070 cgrad      enddo
9071 cgrad      do m=k+2,l2
9072 cgrad        do ll=1,3
9073 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9074 cgrad        enddo
9075 cgrad      enddo
9076 cd      do iii=1,nres-3
9077 cd        write (2,*) iii,g_corr5_loc(iii)
9078 cd      enddo
9079       eello5=ekont*eel5
9080 cd      write (2,*) 'ekont',ekont
9081 cd      write (iout,*) 'eello5',ekont*eel5
9082       return
9083       end
9084 c--------------------------------------------------------------------------
9085       double precision function eello6(i,j,k,l,jj,kk)
9086       implicit real*8 (a-h,o-z)
9087       include 'DIMENSIONS'
9088       include 'DIMENSIONS.ZSCOPT'
9089       include 'COMMON.IOUNITS'
9090       include 'COMMON.CHAIN'
9091       include 'COMMON.DERIV'
9092       include 'COMMON.INTERACT'
9093       include 'COMMON.CONTACTS'
9094       include 'COMMON.TORSION'
9095       include 'COMMON.VAR'
9096       include 'COMMON.GEO'
9097       include 'COMMON.FFIELD'
9098       double precision ggg1(3),ggg2(3)
9099 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9100 cd        eello6=0.0d0
9101 cd        return
9102 cd      endif
9103 cd      write (iout,*)
9104 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9105 cd     &   ' and',k,l
9106       eello6_1=0.0d0
9107       eello6_2=0.0d0
9108       eello6_3=0.0d0
9109       eello6_4=0.0d0
9110       eello6_5=0.0d0
9111       eello6_6=0.0d0
9112 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9113 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9114       do iii=1,2
9115         do kkk=1,5
9116           do lll=1,3
9117             derx(lll,kkk,iii)=0.0d0
9118           enddo
9119         enddo
9120       enddo
9121 cd      eij=facont_hb(jj,i)
9122 cd      ekl=facont_hb(kk,k)
9123 cd      ekont=eij*ekl
9124 cd      eij=1.0d0
9125 cd      ekl=1.0d0
9126 cd      ekont=1.0d0
9127       if (l.eq.j+1) then
9128         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9129         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9130         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9131         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9132         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9133         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9134       else
9135         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9136         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9137         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9138         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9139         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9140           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9141         else
9142           eello6_5=0.0d0
9143         endif
9144         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9145       endif
9146 C If turn contributions are considered, they will be handled separately.
9147       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9148 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9149 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9150 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9151 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9152 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9153 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9154 cd      goto 1112
9155       if (calc_grad) then
9156       if (j.lt.nres-1) then
9157         j1=j+1
9158         j2=j-1
9159       else
9160         j1=j-1
9161         j2=j-2
9162       endif
9163       if (l.lt.nres-1) then
9164         l1=l+1
9165         l2=l-1
9166       else
9167         l1=l-1
9168         l2=l-2
9169       endif
9170       do ll=1,3
9171 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9172 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9173 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9174 cgrad        ghalf=0.5d0*ggg1(ll)
9175 cd        ghalf=0.0d0
9176         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9177         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9178         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9179         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9180         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9181         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9182         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9183         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9184 cgrad        ghalf=0.5d0*ggg2(ll)
9185 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9186 cd        ghalf=0.0d0
9187         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9188         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9189         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9190         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9191         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9192         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9193       enddo
9194       endif ! calc_grad
9195 cd      goto 1112
9196 cgrad      do m=i+1,j-1
9197 cgrad        do ll=1,3
9198 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9199 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9200 cgrad        enddo
9201 cgrad      enddo
9202 cgrad      do m=k+1,l-1
9203 cgrad        do ll=1,3
9204 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9205 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9206 cgrad        enddo
9207 cgrad      enddo
9208 cgrad1112  continue
9209 cgrad      do m=i+2,j2
9210 cgrad        do ll=1,3
9211 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9212 cgrad        enddo
9213 cgrad      enddo
9214 cgrad      do m=k+2,l2
9215 cgrad        do ll=1,3
9216 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9217 cgrad        enddo
9218 cgrad      enddo
9219 cd      do iii=1,nres-3
9220 cd        write (2,*) iii,g_corr6_loc(iii)
9221 cd      enddo
9222       eello6=ekont*eel6
9223 cd      write (2,*) 'ekont',ekont
9224 cd      write (iout,*) 'eello6',ekont*eel6
9225       return
9226       end
9227 c--------------------------------------------------------------------------
9228       double precision function eello6_graph1(i,j,k,l,imat,swap)
9229       implicit real*8 (a-h,o-z)
9230       include 'DIMENSIONS'
9231       include 'DIMENSIONS.ZSCOPT'
9232       include 'COMMON.IOUNITS'
9233       include 'COMMON.CHAIN'
9234       include 'COMMON.DERIV'
9235       include 'COMMON.INTERACT'
9236       include 'COMMON.CONTACTS'
9237       include 'COMMON.TORSION'
9238       include 'COMMON.VAR'
9239       include 'COMMON.GEO'
9240       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9241       logical swap
9242       logical lprn
9243       common /kutas/ lprn
9244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9245 C                                                                              C
9246 C      Parallel       Antiparallel                                             C
9247 C                                                                              C
9248 C          o             o                                                     C
9249 C         /l\           /j\                                                    C
9250 C        /   \         /   \                                                   C
9251 C       /| o |         | o |\                                                  C
9252 C     \ j|/k\|  /   \  |/k\|l /                                                C
9253 C      \ /   \ /     \ /   \ /                                                 C
9254 C       o     o       o     o                                                  C
9255 C       i             i                                                        C
9256 C                                                                              C
9257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9258       itk=itype2loc(itype(k))
9259       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9260       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9261       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9262       call transpose2(EUgC(1,1,k),auxmat(1,1))
9263       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9264       vv1(1)=pizda1(1,1)-pizda1(2,2)
9265       vv1(2)=pizda1(1,2)+pizda1(2,1)
9266       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9267       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9268       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9269       s5=scalar2(vv(1),Dtobr2(1,i))
9270 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9271       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9272       if (calc_grad) then
9273       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9274      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9275      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9276      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9277      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9278      & +scalar2(vv(1),Dtobr2der(1,i)))
9279       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9280       vv1(1)=pizda1(1,1)-pizda1(2,2)
9281       vv1(2)=pizda1(1,2)+pizda1(2,1)
9282       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9283       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9284       if (l.eq.j+1) then
9285         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9286      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9287      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9288      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9289      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9290       else
9291         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9292      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9293      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9294      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9295      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9296       endif
9297       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9298       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9299       vv1(1)=pizda1(1,1)-pizda1(2,2)
9300       vv1(2)=pizda1(1,2)+pizda1(2,1)
9301       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9302      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9303      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9304      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9305       do iii=1,2
9306         if (swap) then
9307           ind=3-iii
9308         else
9309           ind=iii
9310         endif
9311         do kkk=1,5
9312           do lll=1,3
9313             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9314             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9315             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9316             call transpose2(EUgC(1,1,k),auxmat(1,1))
9317             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9318      &        pizda1(1,1))
9319             vv1(1)=pizda1(1,1)-pizda1(2,2)
9320             vv1(2)=pizda1(1,2)+pizda1(2,1)
9321             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9322             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9323      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9324             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9325      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9326             s5=scalar2(vv(1),Dtobr2(1,i))
9327             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9328           enddo
9329         enddo
9330       enddo
9331       endif ! calc_grad
9332       return
9333       end
9334 c----------------------------------------------------------------------------
9335       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9336       implicit real*8 (a-h,o-z)
9337       include 'DIMENSIONS'
9338       include 'DIMENSIONS.ZSCOPT'
9339       include 'COMMON.IOUNITS'
9340       include 'COMMON.CHAIN'
9341       include 'COMMON.DERIV'
9342       include 'COMMON.INTERACT'
9343       include 'COMMON.CONTACTS'
9344       include 'COMMON.TORSION'
9345       include 'COMMON.VAR'
9346       include 'COMMON.GEO'
9347       logical swap
9348       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9349      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9350       logical lprn
9351       common /kutas/ lprn
9352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9353 C                                                                              C
9354 C      Parallel       Antiparallel                                             C
9355 C                                                                              C
9356 C          o             o                                                     C
9357 C     \   /l\           /j\   /                                                C
9358 C      \ /   \         /   \ /                                                 C
9359 C       o| o |         | o |o                                                  C
9360 C     \ j|/k\|      \  |/k\|l                                                  C
9361 C      \ /   \       \ /   \                                                   C
9362 C       o             o                                                        C
9363 C       i             i                                                        C
9364 C                                                                              C
9365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9366 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9367 C AL 7/4/01 s1 would occur in the sixth-order moment,
9368 C           but not in a cluster cumulant
9369 #ifdef MOMENT
9370       s1=dip(1,jj,i)*dip(1,kk,k)
9371 #endif
9372       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9373       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9374       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9375       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9376       call transpose2(EUg(1,1,k),auxmat(1,1))
9377       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9378       vv(1)=pizda(1,1)-pizda(2,2)
9379       vv(2)=pizda(1,2)+pizda(2,1)
9380       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9381 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9382 #ifdef MOMENT
9383       eello6_graph2=-(s1+s2+s3+s4)
9384 #else
9385       eello6_graph2=-(s2+s3+s4)
9386 #endif
9387 c      eello6_graph2=-s3
9388 C Derivatives in gamma(i-1)
9389       if (calc_grad) then
9390       if (i.gt.1) then
9391 #ifdef MOMENT
9392         s1=dipderg(1,jj,i)*dip(1,kk,k)
9393 #endif
9394         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9395         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9396         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9397         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9398 #ifdef MOMENT
9399         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9400 #else
9401         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9402 #endif
9403 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9404       endif
9405 C Derivatives in gamma(k-1)
9406 #ifdef MOMENT
9407       s1=dip(1,jj,i)*dipderg(1,kk,k)
9408 #endif
9409       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9410       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9411       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9412       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9413       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9414       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9415       vv(1)=pizda(1,1)-pizda(2,2)
9416       vv(2)=pizda(1,2)+pizda(2,1)
9417       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9418 #ifdef MOMENT
9419       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9420 #else
9421       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9422 #endif
9423 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9424 C Derivatives in gamma(j-1) or gamma(l-1)
9425       if (j.gt.1) then
9426 #ifdef MOMENT
9427         s1=dipderg(3,jj,i)*dip(1,kk,k)
9428 #endif
9429         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9430         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9431         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9432         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9433         vv(1)=pizda(1,1)-pizda(2,2)
9434         vv(2)=pizda(1,2)+pizda(2,1)
9435         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9436 #ifdef MOMENT
9437         if (swap) then
9438           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9439         else
9440           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9441         endif
9442 #endif
9443         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9444 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9445       endif
9446 C Derivatives in gamma(l-1) or gamma(j-1)
9447       if (l.gt.1) then
9448 #ifdef MOMENT
9449         s1=dip(1,jj,i)*dipderg(3,kk,k)
9450 #endif
9451         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9452         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9453         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9454         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9455         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9456         vv(1)=pizda(1,1)-pizda(2,2)
9457         vv(2)=pizda(1,2)+pizda(2,1)
9458         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9459 #ifdef MOMENT
9460         if (swap) then
9461           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9462         else
9463           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9464         endif
9465 #endif
9466         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9467 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9468       endif
9469 C Cartesian derivatives.
9470       if (lprn) then
9471         write (2,*) 'In eello6_graph2'
9472         do iii=1,2
9473           write (2,*) 'iii=',iii
9474           do kkk=1,5
9475             write (2,*) 'kkk=',kkk
9476             do jjj=1,2
9477               write (2,'(3(2f10.5),5x)')
9478      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9479             enddo
9480           enddo
9481         enddo
9482       endif
9483       do iii=1,2
9484         do kkk=1,5
9485           do lll=1,3
9486 #ifdef MOMENT
9487             if (iii.eq.1) then
9488               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9489             else
9490               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9491             endif
9492 #endif
9493             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9494      &        auxvec(1))
9495             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9496             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9497      &        auxvec(1))
9498             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9499             call transpose2(EUg(1,1,k),auxmat(1,1))
9500             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9501      &        pizda(1,1))
9502             vv(1)=pizda(1,1)-pizda(2,2)
9503             vv(2)=pizda(1,2)+pizda(2,1)
9504             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9505 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9506 #ifdef MOMENT
9507             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9508 #else
9509             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9510 #endif
9511             if (swap) then
9512               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9513             else
9514               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9515             endif
9516           enddo
9517         enddo
9518       enddo
9519       endif ! calc_grad
9520       return
9521       end
9522 c----------------------------------------------------------------------------
9523       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9524       implicit real*8 (a-h,o-z)
9525       include 'DIMENSIONS'
9526       include 'DIMENSIONS.ZSCOPT'
9527       include 'COMMON.IOUNITS'
9528       include 'COMMON.CHAIN'
9529       include 'COMMON.DERIV'
9530       include 'COMMON.INTERACT'
9531       include 'COMMON.CONTACTS'
9532       include 'COMMON.TORSION'
9533       include 'COMMON.VAR'
9534       include 'COMMON.GEO'
9535       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9536       logical swap
9537 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9538 C                                                                              C
9539 C      Parallel       Antiparallel                                             C
9540 C                                                                              C
9541 C          o             o                                                     C
9542 C         /l\   /   \   /j\                                                    C
9543 C        /   \ /     \ /   \                                                   C
9544 C       /| o |o       o| o |\                                                  C
9545 C       j|/k\|  /      |/k\|l /                                                C
9546 C        /   \ /       /   \ /                                                 C
9547 C       /     o       /     o                                                  C
9548 C       i             i                                                        C
9549 C                                                                              C
9550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9551 C
9552 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9553 C           energy moment and not to the cluster cumulant.
9554       iti=itortyp(itype(i))
9555       if (j.lt.nres-1) then
9556         itj1=itype2loc(itype(j+1))
9557       else
9558         itj1=nloctyp
9559       endif
9560       itk=itype2loc(itype(k))
9561       itk1=itype2loc(itype(k+1))
9562       if (l.lt.nres-1) then
9563         itl1=itype2loc(itype(l+1))
9564       else
9565         itl1=nloctyp
9566       endif
9567 #ifdef MOMENT
9568       s1=dip(4,jj,i)*dip(4,kk,k)
9569 #endif
9570       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9571       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9572       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9573       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9574       call transpose2(EE(1,1,k),auxmat(1,1))
9575       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9576       vv(1)=pizda(1,1)+pizda(2,2)
9577       vv(2)=pizda(2,1)-pizda(1,2)
9578       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9579 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9580 cd     & "sum",-(s2+s3+s4)
9581 #ifdef MOMENT
9582       eello6_graph3=-(s1+s2+s3+s4)
9583 #else
9584       eello6_graph3=-(s2+s3+s4)
9585 #endif
9586 c      eello6_graph3=-s4
9587 C Derivatives in gamma(k-1)
9588       if (calc_grad) then
9589       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9590       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9591       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9592       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9593 C Derivatives in gamma(l-1)
9594       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9595       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9596       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9597       vv(1)=pizda(1,1)+pizda(2,2)
9598       vv(2)=pizda(2,1)-pizda(1,2)
9599       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9600       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9601 C Cartesian derivatives.
9602       do iii=1,2
9603         do kkk=1,5
9604           do lll=1,3
9605 #ifdef MOMENT
9606             if (iii.eq.1) then
9607               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9608             else
9609               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9610             endif
9611 #endif
9612             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9613      &        auxvec(1))
9614             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9615             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9616      &        auxvec(1))
9617             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9618             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9619      &        pizda(1,1))
9620             vv(1)=pizda(1,1)+pizda(2,2)
9621             vv(2)=pizda(2,1)-pizda(1,2)
9622             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9623 #ifdef MOMENT
9624             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9625 #else
9626             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9627 #endif
9628             if (swap) then
9629               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9630             else
9631               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9632             endif
9633 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9634           enddo
9635         enddo
9636       enddo
9637       endif ! calc_grad
9638       return
9639       end
9640 c----------------------------------------------------------------------------
9641       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9642       implicit real*8 (a-h,o-z)
9643       include 'DIMENSIONS'
9644       include 'DIMENSIONS.ZSCOPT'
9645       include 'COMMON.IOUNITS'
9646       include 'COMMON.CHAIN'
9647       include 'COMMON.DERIV'
9648       include 'COMMON.INTERACT'
9649       include 'COMMON.CONTACTS'
9650       include 'COMMON.TORSION'
9651       include 'COMMON.VAR'
9652       include 'COMMON.GEO'
9653       include 'COMMON.FFIELD'
9654       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9655      & auxvec1(2),auxmat1(2,2)
9656       logical swap
9657 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9658 C                                                                              C
9659 C      Parallel       Antiparallel                                             C
9660 C                                                                              C
9661 C          o             o                                                     C
9662 C         /l\   /   \   /j\                                                    C
9663 C        /   \ /     \ /   \                                                   C
9664 C       /| o |o       o| o |\                                                  C
9665 C     \ j|/k\|      \  |/k\|l                                                  C
9666 C      \ /   \       \ /   \                                                   C
9667 C       o     \       o     \                                                  C
9668 C       i             i                                                        C
9669 C                                                                              C
9670 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9671 C
9672 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9673 C           energy moment and not to the cluster cumulant.
9674 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9675       iti=itype2loc(itype(i))
9676       itj=itype2loc(itype(j))
9677       if (j.lt.nres-1) then
9678         itj1=itype2loc(itype(j+1))
9679       else
9680         itj1=nloctyp
9681       endif
9682       itk=itype2loc(itype(k))
9683       if (k.lt.nres-1) then
9684         itk1=itype2loc(itype(k+1))
9685       else
9686         itk1=nloctyp
9687       endif
9688       itl=itype2loc(itype(l))
9689       if (l.lt.nres-1) then
9690         itl1=itype2loc(itype(l+1))
9691       else
9692         itl1=nloctyp
9693       endif
9694 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9695 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9696 cd     & ' itl',itl,' itl1',itl1
9697 #ifdef MOMENT
9698       if (imat.eq.1) then
9699         s1=dip(3,jj,i)*dip(3,kk,k)
9700       else
9701         s1=dip(2,jj,j)*dip(2,kk,l)
9702       endif
9703 #endif
9704       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9705       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9706       if (j.eq.l+1) then
9707         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9708         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9709       else
9710         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9711         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9712       endif
9713       call transpose2(EUg(1,1,k),auxmat(1,1))
9714       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9715       vv(1)=pizda(1,1)-pizda(2,2)
9716       vv(2)=pizda(2,1)+pizda(1,2)
9717       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9718 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9719 #ifdef MOMENT
9720       eello6_graph4=-(s1+s2+s3+s4)
9721 #else
9722       eello6_graph4=-(s2+s3+s4)
9723 #endif
9724 C Derivatives in gamma(i-1)
9725       if (calc_grad) then
9726       if (i.gt.1) then
9727 #ifdef MOMENT
9728         if (imat.eq.1) then
9729           s1=dipderg(2,jj,i)*dip(3,kk,k)
9730         else
9731           s1=dipderg(4,jj,j)*dip(2,kk,l)
9732         endif
9733 #endif
9734         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9735         if (j.eq.l+1) then
9736           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9737           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9738         else
9739           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9740           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9741         endif
9742         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9743         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9744 cd          write (2,*) 'turn6 derivatives'
9745 #ifdef MOMENT
9746           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9747 #else
9748           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9749 #endif
9750         else
9751 #ifdef MOMENT
9752           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9753 #else
9754           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9755 #endif
9756         endif
9757       endif
9758 C Derivatives in gamma(k-1)
9759 #ifdef MOMENT
9760       if (imat.eq.1) then
9761         s1=dip(3,jj,i)*dipderg(2,kk,k)
9762       else
9763         s1=dip(2,jj,j)*dipderg(4,kk,l)
9764       endif
9765 #endif
9766       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9767       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9768       if (j.eq.l+1) then
9769         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9770         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9771       else
9772         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9773         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9774       endif
9775       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9776       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9777       vv(1)=pizda(1,1)-pizda(2,2)
9778       vv(2)=pizda(2,1)+pizda(1,2)
9779       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9780       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9781 #ifdef MOMENT
9782         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9783 #else
9784         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9785 #endif
9786       else
9787 #ifdef MOMENT
9788         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9789 #else
9790         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9791 #endif
9792       endif
9793 C Derivatives in gamma(j-1) or gamma(l-1)
9794       if (l.eq.j+1 .and. l.gt.1) then
9795         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9796         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9797         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9798         vv(1)=pizda(1,1)-pizda(2,2)
9799         vv(2)=pizda(2,1)+pizda(1,2)
9800         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9801         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9802       else if (j.gt.1) then
9803         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9804         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9805         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9806         vv(1)=pizda(1,1)-pizda(2,2)
9807         vv(2)=pizda(2,1)+pizda(1,2)
9808         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9809         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9810           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9811         else
9812           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9813         endif
9814       endif
9815 C Cartesian derivatives.
9816       do iii=1,2
9817         do kkk=1,5
9818           do lll=1,3
9819 #ifdef MOMENT
9820             if (iii.eq.1) then
9821               if (imat.eq.1) then
9822                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9823               else
9824                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9825               endif
9826             else
9827               if (imat.eq.1) then
9828                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9829               else
9830                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9831               endif
9832             endif
9833 #endif
9834             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9835      &        auxvec(1))
9836             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9837             if (j.eq.l+1) then
9838               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9839      &          b1(1,j+1),auxvec(1))
9840               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9841             else
9842               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9843      &          b1(1,l+1),auxvec(1))
9844               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9845             endif
9846             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9847      &        pizda(1,1))
9848             vv(1)=pizda(1,1)-pizda(2,2)
9849             vv(2)=pizda(2,1)+pizda(1,2)
9850             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9851             if (swap) then
9852               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9853 #ifdef MOMENT
9854                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9855      &             -(s1+s2+s4)
9856 #else
9857                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9858      &             -(s2+s4)
9859 #endif
9860                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9861               else
9862 #ifdef MOMENT
9863                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9864 #else
9865                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9866 #endif
9867                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9868               endif
9869             else
9870 #ifdef MOMENT
9871               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9872 #else
9873               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9874 #endif
9875               if (l.eq.j+1) then
9876                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9877               else
9878                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9879               endif
9880             endif
9881           enddo
9882         enddo
9883       enddo
9884       endif ! calc_grad
9885       return
9886       end
9887 c----------------------------------------------------------------------------
9888       double precision function eello_turn6(i,jj,kk)
9889       implicit real*8 (a-h,o-z)
9890       include 'DIMENSIONS'
9891       include 'DIMENSIONS.ZSCOPT'
9892       include 'COMMON.IOUNITS'
9893       include 'COMMON.CHAIN'
9894       include 'COMMON.DERIV'
9895       include 'COMMON.INTERACT'
9896       include 'COMMON.CONTACTS'
9897       include 'COMMON.TORSION'
9898       include 'COMMON.VAR'
9899       include 'COMMON.GEO'
9900       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9901      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9902      &  ggg1(3),ggg2(3)
9903       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9904      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9905 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9906 C           the respective energy moment and not to the cluster cumulant.
9907       s1=0.0d0
9908       s8=0.0d0
9909       s13=0.0d0
9910 c
9911       eello_turn6=0.0d0
9912       j=i+4
9913       k=i+1
9914       l=i+3
9915       iti=itype2loc(itype(i))
9916       itk=itype2loc(itype(k))
9917       itk1=itype2loc(itype(k+1))
9918       itl=itype2loc(itype(l))
9919       itj=itype2loc(itype(j))
9920 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9921 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9922 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9923 cd        eello6=0.0d0
9924 cd        return
9925 cd      endif
9926 cd      write (iout,*)
9927 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9928 cd     &   ' and',k,l
9929 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9930       do iii=1,2
9931         do kkk=1,5
9932           do lll=1,3
9933             derx_turn(lll,kkk,iii)=0.0d0
9934           enddo
9935         enddo
9936       enddo
9937 cd      eij=1.0d0
9938 cd      ekl=1.0d0
9939 cd      ekont=1.0d0
9940       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9941 cd      eello6_5=0.0d0
9942 cd      write (2,*) 'eello6_5',eello6_5
9943 #ifdef MOMENT
9944       call transpose2(AEA(1,1,1),auxmat(1,1))
9945       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9946       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9947       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9948 #endif
9949       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9950       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9951       s2 = scalar2(b1(1,k),vtemp1(1))
9952 #ifdef MOMENT
9953       call transpose2(AEA(1,1,2),atemp(1,1))
9954       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9955       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9956       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9957 #endif
9958       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9959       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9960       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9961 #ifdef MOMENT
9962       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9963       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9964       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9965       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9966       ss13 = scalar2(b1(1,k),vtemp4(1))
9967       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9968 #endif
9969 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9970 c      s1=0.0d0
9971 c      s2=0.0d0
9972 c      s8=0.0d0
9973 c      s12=0.0d0
9974 c      s13=0.0d0
9975       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9976 C Derivatives in gamma(i+2)
9977       if (calc_grad) then
9978       s1d =0.0d0
9979       s8d =0.0d0
9980 #ifdef MOMENT
9981       call transpose2(AEA(1,1,1),auxmatd(1,1))
9982       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9983       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9984       call transpose2(AEAderg(1,1,2),atempd(1,1))
9985       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9986       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9987 #endif
9988       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9989       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9990       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9991 c      s1d=0.0d0
9992 c      s2d=0.0d0
9993 c      s8d=0.0d0
9994 c      s12d=0.0d0
9995 c      s13d=0.0d0
9996       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9997 C Derivatives in gamma(i+3)
9998 #ifdef MOMENT
9999       call transpose2(AEA(1,1,1),auxmatd(1,1))
10000       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10001       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10002       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10003 #endif
10004       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10005       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10006       s2d = scalar2(b1(1,k),vtemp1d(1))
10007 #ifdef MOMENT
10008       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10009       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10010 #endif
10011       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10012 #ifdef MOMENT
10013       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10014       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10015       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10016 #endif
10017 c      s1d=0.0d0
10018 c      s2d=0.0d0
10019 c      s8d=0.0d0
10020 c      s12d=0.0d0
10021 c      s13d=0.0d0
10022 #ifdef MOMENT
10023       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10024      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10025 #else
10026       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10027      &               -0.5d0*ekont*(s2d+s12d)
10028 #endif
10029 C Derivatives in gamma(i+4)
10030       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10031       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10032       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10033 #ifdef MOMENT
10034       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10035       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10036       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10037 #endif
10038 c      s1d=0.0d0
10039 c      s2d=0.0d0
10040 c      s8d=0.0d0
10041 C      s12d=0.0d0
10042 c      s13d=0.0d0
10043 #ifdef MOMENT
10044       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10045 #else
10046       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10047 #endif
10048 C Derivatives in gamma(i+5)
10049 #ifdef MOMENT
10050       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10051       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10052       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10053 #endif
10054       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10055       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10056       s2d = scalar2(b1(1,k),vtemp1d(1))
10057 #ifdef MOMENT
10058       call transpose2(AEA(1,1,2),atempd(1,1))
10059       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10060       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10061 #endif
10062       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10063       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10064 #ifdef MOMENT
10065       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10066       ss13d = scalar2(b1(1,k),vtemp4d(1))
10067       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10068 #endif
10069 c      s1d=0.0d0
10070 c      s2d=0.0d0
10071 c      s8d=0.0d0
10072 c      s12d=0.0d0
10073 c      s13d=0.0d0
10074 #ifdef MOMENT
10075       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10076      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10077 #else
10078       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10079      &               -0.5d0*ekont*(s2d+s12d)
10080 #endif
10081 C Cartesian derivatives
10082       do iii=1,2
10083         do kkk=1,5
10084           do lll=1,3
10085 #ifdef MOMENT
10086             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10087             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10088             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10089 #endif
10090             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10091             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10092      &          vtemp1d(1))
10093             s2d = scalar2(b1(1,k),vtemp1d(1))
10094 #ifdef MOMENT
10095             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10096             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10097             s8d = -(atempd(1,1)+atempd(2,2))*
10098      &           scalar2(cc(1,1,l),vtemp2(1))
10099 #endif
10100             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10101      &           auxmatd(1,1))
10102             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10103             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10104 c      s1d=0.0d0
10105 c      s2d=0.0d0
10106 c      s8d=0.0d0
10107 c      s12d=0.0d0
10108 c      s13d=0.0d0
10109 #ifdef MOMENT
10110             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10111      &        - 0.5d0*(s1d+s2d)
10112 #else
10113             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10114      &        - 0.5d0*s2d
10115 #endif
10116 #ifdef MOMENT
10117             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10118      &        - 0.5d0*(s8d+s12d)
10119 #else
10120             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10121      &        - 0.5d0*s12d
10122 #endif
10123           enddo
10124         enddo
10125       enddo
10126 #ifdef MOMENT
10127       do kkk=1,5
10128         do lll=1,3
10129           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10130      &      achuj_tempd(1,1))
10131           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10132           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10133           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10134           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10135           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10136      &      vtemp4d(1))
10137           ss13d = scalar2(b1(1,k),vtemp4d(1))
10138           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10139           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10140         enddo
10141       enddo
10142 #endif
10143 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10144 cd     &  16*eel_turn6_num
10145 cd      goto 1112
10146       if (j.lt.nres-1) then
10147         j1=j+1
10148         j2=j-1
10149       else
10150         j1=j-1
10151         j2=j-2
10152       endif
10153       if (l.lt.nres-1) then
10154         l1=l+1
10155         l2=l-1
10156       else
10157         l1=l-1
10158         l2=l-2
10159       endif
10160       do ll=1,3
10161 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10162 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10163 cgrad        ghalf=0.5d0*ggg1(ll)
10164 cd        ghalf=0.0d0
10165         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10166         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10167         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10168      &    +ekont*derx_turn(ll,2,1)
10169         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10170         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10171      &    +ekont*derx_turn(ll,4,1)
10172         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10173         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10174         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10175 cgrad        ghalf=0.5d0*ggg2(ll)
10176 cd        ghalf=0.0d0
10177         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10178      &    +ekont*derx_turn(ll,2,2)
10179         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10180         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10181      &    +ekont*derx_turn(ll,4,2)
10182         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10183         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10184         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10185       enddo
10186 cd      goto 1112
10187 cgrad      do m=i+1,j-1
10188 cgrad        do ll=1,3
10189 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10190 cgrad        enddo
10191 cgrad      enddo
10192 cgrad      do m=k+1,l-1
10193 cgrad        do ll=1,3
10194 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10195 cgrad        enddo
10196 cgrad      enddo
10197 cgrad1112  continue
10198 cgrad      do m=i+2,j2
10199 cgrad        do ll=1,3
10200 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10201 cgrad        enddo
10202 cgrad      enddo
10203 cgrad      do m=k+2,l2
10204 cgrad        do ll=1,3
10205 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10206 cgrad        enddo
10207 cgrad      enddo
10208 cd      do iii=1,nres-3
10209 cd        write (2,*) iii,g_corr6_loc(iii)
10210 cd      enddo
10211       endif ! calc_grad
10212       eello_turn6=ekont*eel_turn6
10213 cd      write (2,*) 'ekont',ekont
10214 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10215       return
10216       end
10217
10218 crc-------------------------------------------------
10219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10220       subroutine Eliptransfer(eliptran)
10221       implicit real*8 (a-h,o-z)
10222       include 'DIMENSIONS'
10223       include 'DIMENSIONS.ZSCOPT'
10224       include 'COMMON.GEO'
10225       include 'COMMON.VAR'
10226       include 'COMMON.LOCAL'
10227       include 'COMMON.CHAIN'
10228       include 'COMMON.DERIV'
10229       include 'COMMON.INTERACT'
10230       include 'COMMON.IOUNITS'
10231       include 'COMMON.CALC'
10232       include 'COMMON.CONTROL'
10233       include 'COMMON.SPLITELE'
10234       include 'COMMON.SBRIDGE'
10235 C this is done by Adasko
10236 C      print *,"wchodze"
10237 C structure of box:
10238 C      water
10239 C--bordliptop-- buffore starts
10240 C--bufliptop--- here true lipid starts
10241 C      lipid
10242 C--buflipbot--- lipid ends buffore starts
10243 C--bordlipbot--buffore ends
10244       eliptran=0.0
10245       do i=1,nres
10246 C       do i=1,1
10247         if (itype(i).eq.ntyp1) cycle
10248
10249         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10250         if (positi.le.0) positi=positi+boxzsize
10251 C        print *,i
10252 C first for peptide groups
10253 c for each residue check if it is in lipid or lipid water border area
10254        if ((positi.gt.bordlipbot)
10255      &.and.(positi.lt.bordliptop)) then
10256 C the energy transfer exist
10257         if (positi.lt.buflipbot) then
10258 C what fraction I am in
10259          fracinbuf=1.0d0-
10260      &        ((positi-bordlipbot)/lipbufthick)
10261 C lipbufthick is thickenes of lipid buffore
10262          sslip=sscalelip(fracinbuf)
10263          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10264          eliptran=eliptran+sslip*pepliptran
10265          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10266          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10267 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10268         elseif (positi.gt.bufliptop) then
10269          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10270          sslip=sscalelip(fracinbuf)
10271          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10272          eliptran=eliptran+sslip*pepliptran
10273          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10274          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10275 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10276 C          print *, "doing sscalefor top part"
10277 C         print *,i,sslip,fracinbuf,ssgradlip
10278         else
10279          eliptran=eliptran+pepliptran
10280 C         print *,"I am in true lipid"
10281         endif
10282 C       else
10283 C       eliptran=elpitran+0.0 ! I am in water
10284        endif
10285        enddo
10286 C       print *, "nic nie bylo w lipidzie?"
10287 C now multiply all by the peptide group transfer factor
10288 C       eliptran=eliptran*pepliptran
10289 C now the same for side chains
10290 CV       do i=1,1
10291        do i=1,nres
10292         if (itype(i).eq.ntyp1) cycle
10293         positi=(mod(c(3,i+nres),boxzsize))
10294         if (positi.le.0) positi=positi+boxzsize
10295 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10296 c for each residue check if it is in lipid or lipid water border area
10297 C       respos=mod(c(3,i+nres),boxzsize)
10298 C       print *,positi,bordlipbot,buflipbot
10299        if ((positi.gt.bordlipbot)
10300      & .and.(positi.lt.bordliptop)) then
10301 C the energy transfer exist
10302         if (positi.lt.buflipbot) then
10303          fracinbuf=1.0d0-
10304      &     ((positi-bordlipbot)/lipbufthick)
10305 C lipbufthick is thickenes of lipid buffore
10306          sslip=sscalelip(fracinbuf)
10307          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10308          eliptran=eliptran+sslip*liptranene(itype(i))
10309          gliptranx(3,i)=gliptranx(3,i)
10310      &+ssgradlip*liptranene(itype(i))
10311          gliptranc(3,i-1)= gliptranc(3,i-1)
10312      &+ssgradlip*liptranene(itype(i))
10313 C         print *,"doing sccale for lower part"
10314         elseif (positi.gt.bufliptop) then
10315          fracinbuf=1.0d0-
10316      &((bordliptop-positi)/lipbufthick)
10317          sslip=sscalelip(fracinbuf)
10318          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10319          eliptran=eliptran+sslip*liptranene(itype(i))
10320          gliptranx(3,i)=gliptranx(3,i)
10321      &+ssgradlip*liptranene(itype(i))
10322          gliptranc(3,i-1)= gliptranc(3,i-1)
10323      &+ssgradlip*liptranene(itype(i))
10324 C          print *, "doing sscalefor top part",sslip,fracinbuf
10325         else
10326          eliptran=eliptran+liptranene(itype(i))
10327 C         print *,"I am in true lipid"
10328         endif
10329         endif ! if in lipid or buffor
10330 C       else
10331 C       eliptran=elpitran+0.0 ! I am in water
10332        enddo
10333        return
10334        end
10335
10336
10337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10338
10339       SUBROUTINE MATVEC2(A1,V1,V2)
10340       implicit real*8 (a-h,o-z)
10341       include 'DIMENSIONS'
10342       DIMENSION A1(2,2),V1(2),V2(2)
10343 c      DO 1 I=1,2
10344 c        VI=0.0
10345 c        DO 3 K=1,2
10346 c    3     VI=VI+A1(I,K)*V1(K)
10347 c        Vaux(I)=VI
10348 c    1 CONTINUE
10349
10350       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10351       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10352
10353       v2(1)=vaux1
10354       v2(2)=vaux2
10355       END
10356 C---------------------------------------
10357       SUBROUTINE MATMAT2(A1,A2,A3)
10358       implicit real*8 (a-h,o-z)
10359       include 'DIMENSIONS'
10360       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10361 c      DIMENSION AI3(2,2)
10362 c        DO  J=1,2
10363 c          A3IJ=0.0
10364 c          DO K=1,2
10365 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10366 c          enddo
10367 c          A3(I,J)=A3IJ
10368 c       enddo
10369 c      enddo
10370
10371       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10372       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10373       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10374       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10375
10376       A3(1,1)=AI3_11
10377       A3(2,1)=AI3_21
10378       A3(1,2)=AI3_12
10379       A3(2,2)=AI3_22
10380       END
10381
10382 c-------------------------------------------------------------------------
10383       double precision function scalar2(u,v)
10384       implicit none
10385       double precision u(2),v(2)
10386       double precision sc
10387       integer i
10388       scalar2=u(1)*v(1)+u(2)*v(2)
10389       return
10390       end
10391
10392 C-----------------------------------------------------------------------------
10393
10394       subroutine transpose2(a,at)
10395       implicit none
10396       double precision a(2,2),at(2,2)
10397       at(1,1)=a(1,1)
10398       at(1,2)=a(2,1)
10399       at(2,1)=a(1,2)
10400       at(2,2)=a(2,2)
10401       return
10402       end
10403 c--------------------------------------------------------------------------
10404       subroutine transpose(n,a,at)
10405       implicit none
10406       integer n,i,j
10407       double precision a(n,n),at(n,n)
10408       do i=1,n
10409         do j=1,n
10410           at(j,i)=a(i,j)
10411         enddo
10412       enddo
10413       return
10414       end
10415 C---------------------------------------------------------------------------
10416       subroutine prodmat3(a1,a2,kk,transp,prod)
10417       implicit none
10418       integer i,j
10419       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10420       logical transp
10421 crc      double precision auxmat(2,2),prod_(2,2)
10422
10423       if (transp) then
10424 crc        call transpose2(kk(1,1),auxmat(1,1))
10425 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10426 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10427
10428            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10429      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10430            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10431      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10432            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10433      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10434            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10435      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10436
10437       else
10438 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10439 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10440
10441            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10442      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10443            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10444      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10445            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10446      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10447            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10448      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10449
10450       endif
10451 c      call transpose2(a2(1,1),a2t(1,1))
10452
10453 crc      print *,transp
10454 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10455 crc      print *,((prod(i,j),i=1,2),j=1,2)
10456
10457       return
10458       end
10459 C-----------------------------------------------------------------------------
10460       double precision function scalar(u,v)
10461       implicit none
10462       double precision u(3),v(3)
10463       double precision sc
10464       integer i
10465       sc=0.0d0
10466       do i=1,3
10467         sc=sc+u(i)*v(i)
10468       enddo
10469       scalar=sc
10470       return
10471       end
10472 C-----------------------------------------------------------------------
10473       double precision function sscale(r)
10474       double precision r,gamm
10475       include "COMMON.SPLITELE"
10476       if(r.lt.r_cut-rlamb) then
10477         sscale=1.0d0
10478       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10479         gamm=(r-(r_cut-rlamb))/rlamb
10480         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10481       else
10482         sscale=0d0
10483       endif
10484       return
10485       end
10486 C-----------------------------------------------------------------------
10487 C-----------------------------------------------------------------------
10488       double precision function sscagrad(r)
10489       double precision r,gamm
10490       include "COMMON.SPLITELE"
10491       if(r.lt.r_cut-rlamb) then
10492         sscagrad=0.0d0
10493       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10494         gamm=(r-(r_cut-rlamb))/rlamb
10495         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10496       else
10497         sscagrad=0.0d0
10498       endif
10499       return
10500       end
10501 C-----------------------------------------------------------------------
10502 C-----------------------------------------------------------------------
10503       double precision function sscalelip(r)
10504       double precision r,gamm
10505       include "COMMON.SPLITELE"
10506 C      if(r.lt.r_cut-rlamb) then
10507 C        sscale=1.0d0
10508 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10509 C        gamm=(r-(r_cut-rlamb))/rlamb
10510         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10511 C      else
10512 C        sscale=0d0
10513 C      endif
10514       return
10515       end
10516 C-----------------------------------------------------------------------
10517       double precision function sscagradlip(r)
10518       double precision r,gamm
10519       include "COMMON.SPLITELE"
10520 C     if(r.lt.r_cut-rlamb) then
10521 C        sscagrad=0.0d0
10522 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10523 C        gamm=(r-(r_cut-rlamb))/rlamb
10524         sscagradlip=r*(6*r-6.0d0)
10525 C      else
10526 C        sscagrad=0.0d0
10527 C      endif
10528       return
10529       end
10530
10531 C-----------------------------------------------------------------------
10532        subroutine set_shield_fac
10533       implicit real*8 (a-h,o-z)
10534       include 'DIMENSIONS'
10535       include 'DIMENSIONS.ZSCOPT'
10536       include 'COMMON.CHAIN'
10537       include 'COMMON.DERIV'
10538       include 'COMMON.IOUNITS'
10539       include 'COMMON.SHIELD'
10540       include 'COMMON.INTERACT'
10541 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10542       double precision div77_81/0.974996043d0/,
10543      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10544
10545 C the vector between center of side_chain and peptide group
10546        double precision pep_side(3),long,side_calf(3),
10547      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10548      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10549 C the line belowe needs to be changed for FGPROC>1
10550       do i=1,nres-1
10551       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10552       ishield_list(i)=0
10553 Cif there two consequtive dummy atoms there is no peptide group between them
10554 C the line below has to be changed for FGPROC>1
10555       VolumeTotal=0.0
10556       do k=1,nres
10557        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10558        dist_pep_side=0.0
10559        dist_side_calf=0.0
10560        do j=1,3
10561 C first lets set vector conecting the ithe side-chain with kth side-chain
10562       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10563 C      pep_side(j)=2.0d0
10564 C and vector conecting the side-chain with its proper calfa
10565       side_calf(j)=c(j,k+nres)-c(j,k)
10566 C      side_calf(j)=2.0d0
10567       pept_group(j)=c(j,i)-c(j,i+1)
10568 C lets have their lenght
10569       dist_pep_side=pep_side(j)**2+dist_pep_side
10570       dist_side_calf=dist_side_calf+side_calf(j)**2
10571       dist_pept_group=dist_pept_group+pept_group(j)**2
10572       enddo
10573        dist_pep_side=dsqrt(dist_pep_side)
10574        dist_pept_group=dsqrt(dist_pept_group)
10575        dist_side_calf=dsqrt(dist_side_calf)
10576       do j=1,3
10577         pep_side_norm(j)=pep_side(j)/dist_pep_side
10578         side_calf_norm(j)=dist_side_calf
10579       enddo
10580 C now sscale fraction
10581        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10582 C       print *,buff_shield,"buff"
10583 C now sscale
10584         if (sh_frac_dist.le.0.0) cycle
10585 C If we reach here it means that this side chain reaches the shielding sphere
10586 C Lets add him to the list for gradient
10587         ishield_list(i)=ishield_list(i)+1
10588 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10589 C this list is essential otherwise problem would be O3
10590         shield_list(ishield_list(i),i)=k
10591 C Lets have the sscale value
10592         if (sh_frac_dist.gt.1.0) then
10593          scale_fac_dist=1.0d0
10594          do j=1,3
10595          sh_frac_dist_grad(j)=0.0d0
10596          enddo
10597         else
10598          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10599      &                   *(2.0*sh_frac_dist-3.0d0)
10600          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10601      &                  /dist_pep_side/buff_shield*0.5
10602 C remember for the final gradient multiply sh_frac_dist_grad(j)
10603 C for side_chain by factor -2 !
10604          do j=1,3
10605          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10606 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10607 C     &                    sh_frac_dist_grad(j)
10608          enddo
10609         endif
10610 C        if ((i.eq.3).and.(k.eq.2)) then
10611 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10612 C     & ,"TU"
10613 C        endif
10614
10615 C this is what is now we have the distance scaling now volume...
10616       short=short_r_sidechain(itype(k))
10617       long=long_r_sidechain(itype(k))
10618       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10619 C now costhet_grad
10620 C       costhet=0.0d0
10621        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10622 C       costhet_fac=0.0d0
10623        do j=1,3
10624          costhet_grad(j)=costhet_fac*pep_side(j)
10625        enddo
10626 C remember for the final gradient multiply costhet_grad(j)
10627 C for side_chain by factor -2 !
10628 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10629 C pep_side0pept_group is vector multiplication
10630       pep_side0pept_group=0.0
10631       do j=1,3
10632       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10633       enddo
10634       cosalfa=(pep_side0pept_group/
10635      & (dist_pep_side*dist_side_calf))
10636       fac_alfa_sin=1.0-cosalfa**2
10637       fac_alfa_sin=dsqrt(fac_alfa_sin)
10638       rkprim=fac_alfa_sin*(long-short)+short
10639 C now costhet_grad
10640        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10641        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10642
10643        do j=1,3
10644          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10645      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10646      &*(long-short)/fac_alfa_sin*cosalfa/
10647      &((dist_pep_side*dist_side_calf))*
10648      &((side_calf(j))-cosalfa*
10649      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10650
10651         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10652      &*(long-short)/fac_alfa_sin*cosalfa
10653      &/((dist_pep_side*dist_side_calf))*
10654      &(pep_side(j)-
10655      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10656        enddo
10657
10658       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10659      &                    /VSolvSphere_div
10660      &                    *wshield
10661 C now the gradient...
10662 C grad_shield is gradient of Calfa for peptide groups
10663 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10664 C     &               costhet,cosphi
10665 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10666 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10667       do j=1,3
10668       grad_shield(j,i)=grad_shield(j,i)
10669 C gradient po skalowaniu
10670      &                +(sh_frac_dist_grad(j)
10671 C  gradient po costhet
10672      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10673      &-scale_fac_dist*(cosphi_grad_long(j))
10674      &/(1.0-cosphi) )*div77_81
10675      &*VofOverlap
10676 C grad_shield_side is Cbeta sidechain gradient
10677       grad_shield_side(j,ishield_list(i),i)=
10678      &        (sh_frac_dist_grad(j)*-2.0d0
10679      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10680      &       +scale_fac_dist*(cosphi_grad_long(j))
10681      &        *2.0d0/(1.0-cosphi))
10682      &        *div77_81*VofOverlap
10683
10684        grad_shield_loc(j,ishield_list(i),i)=
10685      &   scale_fac_dist*cosphi_grad_loc(j)
10686      &        *2.0d0/(1.0-cosphi)
10687      &        *div77_81*VofOverlap
10688       enddo
10689       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10690       enddo
10691       fac_shield(i)=VolumeTotal*div77_81+div4_81
10692 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10693       enddo
10694       return
10695       end
10696 C--------------------------------------------------------------------------
10697 C first for shielding is setting of function of side-chains
10698        subroutine set_shield_fac2
10699       implicit real*8 (a-h,o-z)
10700       include 'DIMENSIONS'
10701       include 'DIMENSIONS.ZSCOPT'
10702       include 'COMMON.CHAIN'
10703       include 'COMMON.DERIV'
10704       include 'COMMON.IOUNITS'
10705       include 'COMMON.SHIELD'
10706       include 'COMMON.INTERACT'
10707 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10708       double precision div77_81/0.974996043d0/,
10709      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10710
10711 C the vector between center of side_chain and peptide group
10712        double precision pep_side(3),long,side_calf(3),
10713      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10714      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10715 C the line belowe needs to be changed for FGPROC>1
10716       do i=1,nres-1
10717       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10718       ishield_list(i)=0
10719 Cif there two consequtive dummy atoms there is no peptide group between them
10720 C the line below has to be changed for FGPROC>1
10721       VolumeTotal=0.0
10722       do k=1,nres
10723        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10724        dist_pep_side=0.0
10725        dist_side_calf=0.0
10726        do j=1,3
10727 C first lets set vector conecting the ithe side-chain with kth side-chain
10728       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10729 C      pep_side(j)=2.0d0
10730 C and vector conecting the side-chain with its proper calfa
10731       side_calf(j)=c(j,k+nres)-c(j,k)
10732 C      side_calf(j)=2.0d0
10733       pept_group(j)=c(j,i)-c(j,i+1)
10734 C lets have their lenght
10735       dist_pep_side=pep_side(j)**2+dist_pep_side
10736       dist_side_calf=dist_side_calf+side_calf(j)**2
10737       dist_pept_group=dist_pept_group+pept_group(j)**2
10738       enddo
10739        dist_pep_side=dsqrt(dist_pep_side)
10740        dist_pept_group=dsqrt(dist_pept_group)
10741        dist_side_calf=dsqrt(dist_side_calf)
10742       do j=1,3
10743         pep_side_norm(j)=pep_side(j)/dist_pep_side
10744         side_calf_norm(j)=dist_side_calf
10745       enddo
10746 C now sscale fraction
10747        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10748 C       print *,buff_shield,"buff"
10749 C now sscale
10750         if (sh_frac_dist.le.0.0) cycle
10751 C If we reach here it means that this side chain reaches the shielding sphere
10752 C Lets add him to the list for gradient
10753         ishield_list(i)=ishield_list(i)+1
10754 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10755 C this list is essential otherwise problem would be O3
10756         shield_list(ishield_list(i),i)=k
10757 C Lets have the sscale value
10758         if (sh_frac_dist.gt.1.0) then
10759          scale_fac_dist=1.0d0
10760          do j=1,3
10761          sh_frac_dist_grad(j)=0.0d0
10762          enddo
10763         else
10764          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10765      &                   *(2.0d0*sh_frac_dist-3.0d0)
10766          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10767      &                  /dist_pep_side/buff_shield*0.5d0
10768 C remember for the final gradient multiply sh_frac_dist_grad(j)
10769 C for side_chain by factor -2 !
10770          do j=1,3
10771          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10772 C         sh_frac_dist_grad(j)=0.0d0
10773 C         scale_fac_dist=1.0d0
10774 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10775 C     &                    sh_frac_dist_grad(j)
10776          enddo
10777         endif
10778 C this is what is now we have the distance scaling now volume...
10779       short=short_r_sidechain(itype(k))
10780       long=long_r_sidechain(itype(k))
10781       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10782       sinthet=short/dist_pep_side*costhet
10783 C now costhet_grad
10784 C       costhet=0.6d0
10785 C       sinthet=0.8
10786        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10787 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10788 C     &             -short/dist_pep_side**2/costhet)
10789 C       costhet_fac=0.0d0
10790        do j=1,3
10791          costhet_grad(j)=costhet_fac*pep_side(j)
10792        enddo
10793 C remember for the final gradient multiply costhet_grad(j)
10794 C for side_chain by factor -2 !
10795 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10796 C pep_side0pept_group is vector multiplication
10797       pep_side0pept_group=0.0d0
10798       do j=1,3
10799       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10800       enddo
10801       cosalfa=(pep_side0pept_group/
10802      & (dist_pep_side*dist_side_calf))
10803       fac_alfa_sin=1.0d0-cosalfa**2
10804       fac_alfa_sin=dsqrt(fac_alfa_sin)
10805       rkprim=fac_alfa_sin*(long-short)+short
10806 C      rkprim=short
10807
10808 C now costhet_grad
10809        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10810 C       cosphi=0.6
10811        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10812        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10813      &      dist_pep_side**2)
10814 C       sinphi=0.8
10815        do j=1,3
10816          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10817      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10818      &*(long-short)/fac_alfa_sin*cosalfa/
10819      &((dist_pep_side*dist_side_calf))*
10820      &((side_calf(j))-cosalfa*
10821      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10822 C       cosphi_grad_long(j)=0.0d0
10823         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10824      &*(long-short)/fac_alfa_sin*cosalfa
10825      &/((dist_pep_side*dist_side_calf))*
10826      &(pep_side(j)-
10827      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10828 C       cosphi_grad_loc(j)=0.0d0
10829        enddo
10830 C      print *,sinphi,sinthet
10831       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10832      &                    /VSolvSphere_div
10833 C     &                    *wshield
10834 C now the gradient...
10835       do j=1,3
10836       grad_shield(j,i)=grad_shield(j,i)
10837 C gradient po skalowaniu
10838      &                +(sh_frac_dist_grad(j)*VofOverlap
10839 C  gradient po costhet
10840      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10841      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10842      &       sinphi/sinthet*costhet*costhet_grad(j)
10843      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10844      & )*wshield
10845 C grad_shield_side is Cbeta sidechain gradient
10846       grad_shield_side(j,ishield_list(i),i)=
10847      &        (sh_frac_dist_grad(j)*-2.0d0
10848      &        *VofOverlap
10849      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10850      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10851      &       sinphi/sinthet*costhet*costhet_grad(j)
10852      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10853      &       )*wshield
10854
10855        grad_shield_loc(j,ishield_list(i),i)=
10856      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10857      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10858      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10859      &        ))
10860      &        *wshield
10861       enddo
10862       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10863       enddo
10864       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10865 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10866 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10867       enddo
10868       return
10869       end
10870 C--------------------------------------------------------------------------
10871       double precision function tschebyshev(m,n,x,y)
10872       implicit none
10873       include "DIMENSIONS"
10874       integer i,m,n
10875       double precision x(n),y,yy(0:maxvar),aux
10876 c Tschebyshev polynomial. Note that the first term is omitted
10877 c m=0: the constant term is included
10878 c m=1: the constant term is not included
10879       yy(0)=1.0d0
10880       yy(1)=y
10881       do i=2,n
10882         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10883       enddo
10884       aux=0.0d0
10885       do i=m,n
10886         aux=aux+x(i)*yy(i)
10887       enddo
10888       tschebyshev=aux
10889       return
10890       end
10891 C--------------------------------------------------------------------------
10892       double precision function gradtschebyshev(m,n,x,y)
10893       implicit none
10894       include "DIMENSIONS"
10895       integer i,m,n
10896       double precision x(n+1),y,yy(0:maxvar),aux
10897 c Tschebyshev polynomial. Note that the first term is omitted
10898 c m=0: the constant term is included
10899 c m=1: the constant term is not included
10900       yy(0)=1.0d0
10901       yy(1)=2.0d0*y
10902       do i=2,n
10903         yy(i)=2*y*yy(i-1)-yy(i-2)
10904       enddo
10905       aux=0.0d0
10906       do i=m,n
10907         aux=aux+x(i+1)*yy(i)*(i+1)
10908 C        print *, x(i+1),yy(i),i
10909       enddo
10910       gradtschebyshev=aux
10911       return
10912       end
10913