source/maxlik/src-Fmatch/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.CONTROL'
 783       include 'COMMON.GEO'
 784       include 'COMMON.VAR'
 785       include 'COMMON.LOCAL'
 786       include 'COMMON.CHAIN'
 787       include 'COMMON.DERIV'
 788       include 'COMMON.NAMES'
 789       include 'COMMON.INTERACT'
 790       include 'COMMON.WEIGHTDER'
 791       include 'COMMON.IOUNITS'
 792       include 'COMMON.CALC'
 793       include 'COMMON.SBRIDGE'
 794       logical lprn
 795       common /srutu/icall
 796       integer icant
 797       external icant
 798       do i=1,nntyp
 799         do j=1,2
 800           eneps_temp(j,i)=0.0d0
 801         enddo
 802       enddo
 803       evdw=0.0D0
 804 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 805       evdw=0.0D0
 806       lprn=.false.
 807 c      if (icall.gt.0) lprn=.true.
 808       ind=0
 809       do i=iatsc_s,iatsc_e
 810         itypi=iabs(itype(i))
 811         if (itypi.eq.ntyp1) cycle
 812         itypi1=iabs(itype(i+1))
 813         xi=c(1,nres+i)
 814         yi=c(2,nres+i)
 815         zi=c(3,nres+i)
 816 C Adjusting to box limits
 817         xi=mod(xi,boxxsize)
 818         if (xi.lt.0) xi=xi+boxxsize
 819         yi=mod(yi,boxysize)
 820         if (yi.lt.0) yi=yi+boxysize
 821         zi=mod(zi,boxzsize)
 822         if (zi.lt.0) zi=zi+boxzsize
 823 C end adjusting
 824 #ifdef LIPID
 825 C Lipid
 826        if ((zi.gt.bordlipbot)
 827      &.and.(zi.lt.bordliptop)) then
 828 C the energy transfer exist
 829         if (zi.lt.buflipbot) then
 830 C what fraction I am in
 831          fracinbuf=1.0d0-
 832      &        ((zi-bordlipbot)/lipbufthick)
 833 C lipbufthick is thickenes of lipid buffore
 834          sslipi=sscalelip(fracinbuf)
 835          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 836         elseif (zi.gt.bufliptop) then
 837          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 838          sslipi=sscalelip(fracinbuf)
 839          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 840         else
 841          sslipi=1.0d0
 842          ssgradlipi=0.0
 843         endif
 844        else
 845          sslipi=0.0d0
 846          ssgradlipi=0.0
 847        endif
 848 C end lipid
 849 #endif
 850         dxi=dc_norm(1,nres+i)
 851         dyi=dc_norm(2,nres+i)
 852         dzi=dc_norm(3,nres+i)
 853         dsci_inv=vbld_inv(i+nres)
 854 C
 855 C Calculate SC interaction energy.
 856 C
 857         do iint=1,nint_gr(i)
 858           do j=istart(i,iint),iend(i,iint)
 859 #ifdef SSBOND
 860 c SSbond
 861             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 862
 863 c              write(iout,*) "PRZED ZWYKLE", evdwij
 864               call dyn_ssbond_ene(i,j,evdwij)
 865 c              write(iout,*) "PO ZWYKLE", evdwij
 866
 867               evdw=evdw+evdwij
 868               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 869      &                        'evdw',i,j,evdwij,' ss'
 870 C triple bond artifac removal
 871              do k=j+1,iend(i,iint)
 872 C search over all next residues
 873               if (dyn_ss_mask(k)) then
 874 C check if they are cysteins
 875 C              write(iout,*) 'k=',k
 876
 877 c              write(iout,*) "PRZED TRI", evdwij
 878                evdwij_przed_tri=evdwij
 879               call triple_ssbond_ene(i,j,k,evdwij)
 880 c               if(evdwij_przed_tri.ne.evdwij) then
 881 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 882 c               endif
 883
 884 c              write(iout,*) "PO TRI", evdwij
 885 C call the energy function that removes the artifical triple disulfide
 886 C bond the soubroutine is located in ssMD.F
 887               evdw=evdw+evdwij
 888               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 889      &                        'evdw',i,j,evdwij,'tss'
 890               endif!dyn_ss_mask(k)
 891              enddo! k
 892 c end ssbond
 893             ELSE
 894 #endif
 895             ind=ind+1
 896             itypj=iabs(itype(j))
 897             if (itypj.eq.ntyp1) cycle
 898             dscj_inv=vbld_inv(j+nres)
 899             sig0ij=sigma(itypi,itypj)
 900             chi1=chi(itypi,itypj)
 901             chi2=chi(itypj,itypi)
 902             chi12=chi1*chi2
 903             chip1=chip(itypi)
 904             chip2=chip(itypj)
 905             chip12=chip1*chip2
 906             alf1=alp(itypi)
 907             alf2=alp(itypj)
 908             alf12=0.5D0*(alf1+alf2)
 909 C For diagnostics only!!!
 910 c           chi1=0.0D0
 911 c           chi2=0.0D0
 912 c           chi12=0.0D0
 913 c           chip1=0.0D0
 914 c           chip2=0.0D0
 915 c           chip12=0.0D0
 916 c           alf1=0.0D0
 917 c           alf2=0.0D0
 918 c           alf12=0.0D0
 919             xj=c(1,nres+j)
 920             yj=c(2,nres+j)
 921             zj=c(3,nres+j)
 922             xj=mod(xj,boxxsize)
 923             if (xj.lt.0) xj=xj+boxxsize
 924             yj=mod(yj,boxysize)
 925             if (yj.lt.0) yj=yj+boxysize
 926             zj=mod(zj,boxzsize)
 927             if (zj.lt.0) zj=zj+boxzsize
 928 #ifdef LIPID
 929             if ((zj.gt.bordlipbot)
 930      &       .and.(zj.lt.bordliptop)) then
 931 C the energy transfer exist
 932             if (zj.lt.buflipbot) then
 933 C what fraction I am in
 934                fracinbuf=1.0d0-
 935      &          ((zj-bordlipbot)/lipbufthick)
 936 C lipbufthick is thickenes of lipid buffore
 937                sslipj=sscalelip(fracinbuf)
 938                ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 939             elseif (zj.gt.bufliptop) then
 940               fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 941               sslipj=sscalelip(fracinbuf)
 942               ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 943             else
 944               sslipj=1.0d0
 945               ssgradlipj=0.0
 946             endif
 947             else
 948             sslipj=0.0d0
 949             ssgradlipj=0.0
 950             endif
 951             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 952      &      +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 953             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 954      &      +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 955 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
 956 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
 957 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
 958 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
 959 C      print *,sslipi,sslipj,bordlipbot,zi,zj
 960 #endif
 961             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 962             xj_safe=xj
 963             yj_safe=yj
 964             zj_safe=zj
 965             subchap=0
 966             do xshift=-1,1
 967             do yshift=-1,1
 968             do zshift=-1,1
 969               xj=xj_safe+xshift*boxxsize
 970               yj=yj_safe+yshift*boxysize
 971               zj=zj_safe+zshift*boxzsize
 972               dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 973               if(dist_temp.lt.dist_init) then
 974                 dist_init=dist_temp
 975                 xj_temp=xj
 976                 yj_temp=yj
 977                 zj_temp=zj
 978                 subchap=1
 979               endif
 980             enddo
 981             enddo
 982             enddo
 983             if (subchap.eq.1) then
 984               xj=xj_temp-xi
 985               yj=yj_temp-yi
 986               zj=zj_temp-zi
 987             else
 988               xj=xj_safe-xi
 989               yj=yj_safe-yi
 990               zj=zj_safe-zi
 991             endif
 992             dxj=dc_norm(1,nres+j)
 993             dyj=dc_norm(2,nres+j)
 994             dzj=dc_norm(3,nres+j)
 995 c            write (iout,*) i,j,xj,yj,zj
 996             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 997             rij=dsqrt(rrij)
 998 C Calculate angle-dependent terms of energy and contributions to their
 999 C derivatives.
1000             call sc_angular
1001             sigsq=1.0D0/sigsq
1002             sig=sig0ij*dsqrt(sigsq)
1003             rij_shift=1.0D0/rij-sig+sig0ij
1004 C I hate to put IF's in the loops, but here don't have another choice!!!!
1005             if (rij_shift.le.0.0D0) then
1006               evdw=1.0D20
1007               return
1008             endif
1009             sigder=-sig*sigsq
1010 c---------------------------------------------------------------
1011             rij_shift=1.0D0/rij_shift
1012             fac=rij_shift**expon
1013             e1=fac*fac*aa(itypi,itypj)
1014             e2=fac*bb(itypi,itypj)
1015             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1016             eps2der=evdwij*eps3rt
1017             eps3der=evdwij*eps2rt
1018             evdwij=evdwij*eps2rt*eps3rt
1019             evdw=evdw+evdwij
1020             ij=icant(itypi,itypj)
1021             aux=eps1*eps2rt**2*eps3rt**2
1022 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1023 c     &        /dabs(eps(itypi,itypj))
1024 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1025 c-----------------------
1026             eps0ij=eps(itypi,itypj)
1027             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1028             rr0ij=r0(itypi,itypj)
1029             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1030 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1031 c-----------------------
1032 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1033 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1034 c     &         aux*e2/eps(itypi,itypj)
1035            if (lprn) then
1036            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1037             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1038             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1039      &        restyp(itypi),i,restyp(itypj),j,
1040      &        epsi,sigm,chi1,chi2,chip1,chip2,
1041      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1042      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1043      &        evdwij
1044             endif
1045             if (calc_grad) then
1046 C Calculate gradient components.
1047             e1=e1*eps1*eps2rt**2*eps3rt**2
1048             fac=-expon*(e1+evdwij)*rij_shift
1049             sigder=fac*sigder
1050             fac=rij*fac
1051 C Calculate the radial part of the gradient
1052             gg(1)=xj*fac
1053             gg(2)=yj*fac
1054             gg(3)=zj*fac
1055 C Calculate angular part of the gradient.
1056             call sc_grad
1057             endif
1058 #ifdef SSBOND
1059             ENDIF
1060 #endif
1061           enddo      ! j
1062         enddo        ! iint
1063       enddo          ! i
1064       return
1065       end
1066 C-----------------------------------------------------------------------------
1067       subroutine egbv(evdw)
1068 C
1069 C This subroutine calculates the interaction energy of nonbonded side chains
1070 C assuming the Gay-Berne-Vorobjev potential of interaction.
1071 C
1072       implicit real*8 (a-h,o-z)
1073       include 'DIMENSIONS'
1074       include 'DIMENSIONS.ZSCOPT'
1075       include 'COMMON.GEO'
1076       include 'COMMON.VAR'
1077       include 'COMMON.LOCAL'
1078       include 'COMMON.CHAIN'
1079       include 'COMMON.DERIV'
1080       include 'COMMON.NAMES'
1081       include 'COMMON.INTERACT'
1082       include 'COMMON.WEIGHTDER'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CALC'
1085       common /srutu/ icall
1086       logical lprn
1087       integer icant
1088       external icant
1089       do i=1,nntyp
1090         do j=1,2
1091           eneps_temp(j,i)=0.0d0
1092         enddo
1093       enddo
1094       evdw=0.0D0
1095 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1096       evdw=0.0D0
1097       lprn=.false.
1098 c      if (icall.gt.0) lprn=.true.
1099       ind=0
1100       do i=iatsc_s,iatsc_e
1101         itypi=itype(i)
1102         itypi1=itype(i+1)
1103         xi=c(1,nres+i)
1104         yi=c(2,nres+i)
1105         zi=c(3,nres+i)
1106         dxi=dc_norm(1,nres+i)
1107         dyi=dc_norm(2,nres+i)
1108         dzi=dc_norm(3,nres+i)
1109         dsci_inv=vbld_inv(i+nres)
1110 C
1111 C Calculate SC interaction energy.
1112 C
1113         do iint=1,nint_gr(i)
1114           do j=istart(i,iint),iend(i,iint)
1115             ind=ind+1
1116             itypj=itype(j)
1117             dscj_inv=vbld_inv(j+nres)
1118             sig0ij=sigma(itypi,itypj)
1119             r0ij=r0(itypi,itypj)
1120             chi1=chi(itypi,itypj)
1121             chi2=chi(itypj,itypi)
1122             chi12=chi1*chi2
1123             chip1=chip(itypi)
1124             chip2=chip(itypj)
1125             chip12=chip1*chip2
1126             alf1=alp(itypi)
1127             alf2=alp(itypj)
1128             alf12=0.5D0*(alf1+alf2)
1129 C For diagnostics only!!!
1130 c           chi1=0.0D0
1131 c           chi2=0.0D0
1132 c           chi12=0.0D0
1133 c           chip1=0.0D0
1134 c           chip2=0.0D0
1135 c           chip12=0.0D0
1136 c           alf1=0.0D0
1137 c           alf2=0.0D0
1138 c           alf12=0.0D0
1139             xj=c(1,nres+j)-xi
1140             yj=c(2,nres+j)-yi
1141             zj=c(3,nres+j)-zi
1142             dxj=dc_norm(1,nres+j)
1143             dyj=dc_norm(2,nres+j)
1144             dzj=dc_norm(3,nres+j)
1145             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1146             rij=dsqrt(rrij)
1147 C Calculate angle-dependent terms of energy and contributions to their
1148 C derivatives.
1149             call sc_angular
1150             sigsq=1.0D0/sigsq
1151             sig=sig0ij*dsqrt(sigsq)
1152             rij_shift=1.0D0/rij-sig+r0ij
1153 C I hate to put IF's in the loops, but here don't have another choice!!!!
1154             if (rij_shift.le.0.0D0) then
1155               evdw=1.0D20
1156               return
1157             endif
1158             sigder=-sig*sigsq
1159 c---------------------------------------------------------------
1160             rij_shift=1.0D0/rij_shift
1161             fac=rij_shift**expon
1162             e1=fac*fac*aa(itypi,itypj)
1163             e2=fac*bb(itypi,itypj)
1164             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1165             eps2der=evdwij*eps3rt
1166             eps3der=evdwij*eps2rt
1167             fac_augm=rrij**expon
1168             e_augm=augm(itypi,itypj)*fac_augm
1169             evdwij=evdwij*eps2rt*eps3rt
1170             evdw=evdw+evdwij+e_augm
1171             ij=icant(itypi,itypj)
1172             aux=eps1*eps2rt**2*eps3rt**2
1173             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1174      &        /dabs(eps(itypi,itypj))
1175             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1176 c            eneps_temp(ij)=eneps_temp(ij)
1177 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1178 c            if (lprn) then
1179 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1180 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1181 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1182 c     &        restyp(itypi),i,restyp(itypj),j,
1183 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1184 c     &        chi1,chi2,chip1,chip2,
1185 c     &        eps1,eps2rt**2,eps3rt**2,
1186 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1187 c     &        evdwij+e_augm
1188 c            endif
1189             if (calc_grad) then
1190 C Calculate gradient components.
1191             e1=e1*eps1*eps2rt**2*eps3rt**2
1192             fac=-expon*(e1+evdwij)*rij_shift
1193             sigder=fac*sigder
1194             fac=rij*fac-2*expon*rrij*e_augm
1195 C Calculate the radial part of the gradient
1196             gg(1)=xj*fac
1197             gg(2)=yj*fac
1198             gg(3)=zj*fac
1199 C Calculate angular part of the gradient.
1200             call sc_grad
1201             endif
1202           enddo      ! j
1203         enddo        ! iint
1204       enddo          ! i
1205       return
1206       end
1207 C-----------------------------------------------------------------------------
1208       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1209 C
1210 C This subroutine calculates the interaction energy of nonbonded side chains
1211 C assuming the Gay-Berne potential of interaction.
1212 C
1213        IMPLICIT NONE
1214        INCLUDE 'DIMENSIONS'
1215        INCLUDE 'DIMENSIONS.ZSCOPT'
1216        INCLUDE 'COMMON.CALC'
1217        INCLUDE 'COMMON.CONTROL'
1218        INCLUDE 'COMMON.CHAIN'
1219        INCLUDE 'COMMON.DERIV'
1220        INCLUDE 'COMMON.EMP'
1221        INCLUDE 'COMMON.GEO'
1222        INCLUDE 'COMMON.INTERACT'
1223        INCLUDE 'COMMON.IOUNITS'
1224        INCLUDE 'COMMON.LOCAL'
1225        INCLUDE 'COMMON.NAMES'
1226        INCLUDE 'COMMON.VAR'
1227        INCLUDE 'COMMON.WEIGHTDER'
1228        logical lprn
1229        double precision scalar
1230        double precision ener(4)
1231        integer troll
1232        integer iint,ij
1233        integer icant
1234
1235        energy_dec=.false.
1236        IF (energy_dec) write (iout,'(a)')
1237      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1238      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1239        evdw   = 0.0D0
1240        evdw_p = 0.0D0
1241        evdw_m = 0.0D0
1242 c DIAGNOSTICS
1243 ccccc      energy_dec=.false.
1244 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1245 c      lprn   = .false.
1246 c     if (icall.eq.0) lprn=.false.
1247 c END DIAGNOSTICS
1248 c      ind = 0
1249        DO i = iatsc_s, iatsc_e
1250         itypi  = itype(i)
1251 c        itypi1 = itype(i+1)
1252         dxi    = dc_norm(1,nres+i)
1253         dyi    = dc_norm(2,nres+i)
1254         dzi    = dc_norm(3,nres+i)
1255 c        dsci_inv=dsc_inv(itypi)
1256         dsci_inv = vbld_inv(i+nres)
1257 c        DO k = 1, 3
1258 c         ctail(k,1) = c(k, i+nres)
1259 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1260 c        END DO
1261         xi=c(1,nres+i)
1262         yi=c(2,nres+i)
1263         zi=c(3,nres+i)
1264 c!-------------------------------------------------------------------
1265 C Calculate SC interaction energy.
1266         DO iint = 1, nint_gr(i)
1267          DO j = istart(i,iint), iend(i,iint)
1268 c! initialize variables for electrostatic gradients
1269           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1270 c            ind=ind+1
1271 c            dscj_inv = dsc_inv(itypj)
1272           dscj_inv = vbld_inv(j+nres)
1273 c! rij holds 1/(distance of Calpha atoms)
1274           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1275           rij  = dsqrt(rrij)
1276 c!-------------------------------------------------------------------
1277 C Calculate angle-dependent terms of energy and contributions to their
1278 C derivatives.
1279
1280 #ifdef CHECK_MOMO
1281 c!      DO troll = 10, 5000
1282 c!      om1    = 0.0d0
1283 c!      om2    = 0.0d0
1284 c!      om12   = 1.0d0
1285 c!      sqom1  = om1 * om1
1286 c!      sqom2  = om2 * om2
1287 c!      sqom12 = om12 * om12
1288 c!      rij    = 5.0d0 / troll
1289 c!      rrij   = rij * rij
1290 c!      Rtail  = troll / 5.0d0
1291 c!      Rhead  = troll / 5.0d0
1292 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1293 c!      Rtail = dsqrt((Rtail**2)
1294 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1295 c!      rij = 1.0d0/Rtail
1296 c!      rrij = rij * rij
1297 #endif
1298           CALL sc_angular
1299 c! this should be in elgrad_init but om's are calculated by sc_angular
1300 c! which in turn is used by older potentials
1301 c! which proves how tangled UNRES code is >.<
1302 c! om = omega, sqom = om^2
1303           sqom1  = om1 * om1
1304           sqom2  = om2 * om2
1305           sqom12 = om12 * om12
1306
1307 c! now we calculate EGB - Gey-Berne
1308 c! It will be summed up in evdwij and saved in evdw
1309           sigsq     = 1.0D0  / sigsq
1310           sig       = sig0ij * dsqrt(sigsq)
1311 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1312           rij_shift = Rtail - sig + sig0ij
1313           IF (rij_shift.le.0.0D0) THEN
1314            evdw = 1.0D20
1315            RETURN
1316           END IF
1317           sigder = -sig * sigsq
1318           rij_shift = 1.0D0 / rij_shift
1319           fac       = rij_shift**expon
1320           c1        = fac  * fac * aa(itypi,itypj)
1321 c!          c1        = 0.0d0
1322           c2        = fac  * bb(itypi,itypj)
1323 c!          c2        = 0.0d0
1324           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1325           eps2der   = eps3rt * evdwij
1326           eps3der   = eps2rt * evdwij
1327 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1328           evdwij    = eps2rt * eps3rt * evdwij
1329 c!      evdwij = 0.0d0
1330 c!      write (*,*) "Gey Berne = ", evdwij
1331 #ifdef TSCSC
1332           IF (bb(itypi,itypj).gt.0) THEN
1333            evdw_p = evdw_p + evdwij
1334           ELSE
1335            evdw_m = evdw_m + evdwij
1336           END IF
1337 #else
1338           evdw = evdw
1339      &         + evdwij
1340 #endif
1341 c!-------------------------------------------------------------------
1342 c! Calculate some components of GGB
1343           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1344           fac    = -expon * (c1 + evdwij) * rij_shift
1345           sigder = fac * sigder
1346 c!          fac    = rij * fac
1347 c! Calculate distance derivative
1348 c!          gg(1) = xj * fac
1349 c!          gg(2) = yj * fac
1350 c!          gg(3) = zj * fac
1351           gg(1) = fac
1352           gg(2) = fac
1353           gg(3) = fac
1354 c!      write (*,*) "gg(1) = ", gg(1)
1355 c!      write (*,*) "gg(2) = ", gg(2)
1356 c!      write (*,*) "gg(3) = ", gg(3)
1357 c! The angular derivatives of GGB are brought together in sc_grad
1358 c!-------------------------------------------------------------------
1359 c! Fcav
1360 c!
1361 c! Catch gly-gly interactions to skip calculation of something that
1362 c! does not exist
1363
1364       IF (itypi.eq.10.and.itypj.eq.10) THEN
1365        Fcav = 0.0d0
1366        dFdR = 0.0d0
1367        dCAVdOM1  = 0.0d0
1368        dCAVdOM2  = 0.0d0
1369        dCAVdOM12 = 0.0d0
1370       ELSE
1371
1372 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1373        fac = chis1 * sqom1 + chis2 * sqom2
1374      &     - 2.0d0 * chis12 * om1 * om2 * om12
1375 c! we will use pom later in Gcav, so dont mess with it!
1376        pom = 1.0d0 - chis1 * chis2 * sqom12
1377
1378        Lambf = (1.0d0 - (fac / pom))
1379        Lambf = dsqrt(Lambf)
1380
1381
1382        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1383 c!       write (*,*) "sparrow = ", sparrow
1384        Chif = Rtail * sparrow
1385        ChiLambf = Chif * Lambf
1386        eagle = dsqrt(ChiLambf)
1387        bat = ChiLambf ** 11.0d0
1388
1389        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1390        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1391        botsq = bot * bot
1392
1393 c!      write (*,*) "sig1 = ",sig1
1394 c!      write (*,*) "sig2 = ",sig2
1395 c!      write (*,*) "Rtail = ",Rtail
1396 c!      write (*,*) "sparrow = ",sparrow
1397 c!      write (*,*) "Chis1 = ", chis1
1398 c!      write (*,*) "Chis2 = ", chis2
1399 c!      write (*,*) "Chis12 = ", chis12
1400 c!      write (*,*) "om1 = ", om1
1401 c!      write (*,*) "om2 = ", om2
1402 c!      write (*,*) "om12 = ", om12
1403 c!      write (*,*) "sqom1 = ", sqom1
1404 c!      write (*,*) "sqom2 = ", sqom2
1405 c!      write (*,*) "sqom12 = ", sqom12
1406 c!      write (*,*) "Lambf = ",Lambf
1407 c!      write (*,*) "b1 = ",b1
1408 c!      write (*,*) "b2 = ",b2
1409 c!      write (*,*) "b3 = ",b3
1410 c!      write (*,*) "b4 = ",b4
1411 c!      write (*,*) "top = ",top
1412 c!      write (*,*) "bot = ",bot
1413        Fcav = top / bot
1414 c!       Fcav = 0.0d0
1415 c!      write (*,*) "Fcav = ", Fcav
1416 c!-------------------------------------------------------------------
1417 c! derivative of Fcav is Gcav...
1418 c!---------------------------------------------------
1419
1420        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1421        dbot = 12.0d0 * b4 * bat * Lambf
1422        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1423 c!       dFdR = 0.0d0
1424 c!      write (*,*) "dFcav/dR = ", dFdR
1425
1426        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1427        dbot = 12.0d0 * b4 * bat * Chif
1428        eagle = Lambf * pom
1429        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1430        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1431        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1432      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1433
1434        dFdL = ((dtop * bot - top * dbot) / botsq)
1435 c!       dFdL = 0.0d0
1436        dCAVdOM1  = dFdL * ( dFdOM1 )
1437        dCAVdOM2  = dFdL * ( dFdOM2 )
1438        dCAVdOM12 = dFdL * ( dFdOM12 )
1439 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1440 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1441 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1442 c!      write (*,*) ""
1443 c!-------------------------------------------------------------------
1444 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1445 c! Pom is used here to project the gradient vector into
1446 c! cartesian coordinates and at the same time contains
1447 c! dXhb/dXsc derivative (for charged amino acids
1448 c! location of hydrophobic centre of interaction is not
1449 c! the same as geometric centre of side chain, this
1450 c! derivative takes that into account)
1451 c! derivatives of omega angles will be added in sc_grad
1452
1453        DO k= 1, 3
1454         ertail(k) = Rtail_distance(k)/Rtail
1455        END DO
1456        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1457        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1458        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1459        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1460        DO k = 1, 3
1461 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1462 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1463         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1464         gvdwx(k,i) = gvdwx(k,i)
1465      &             - (( dFdR + gg(k) ) * pom)
1466 c!     &             - ( dFdR * pom )
1467         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1468         gvdwx(k,j) = gvdwx(k,j)
1469      &             + (( dFdR + gg(k) ) * pom)
1470 c!     &             + ( dFdR * pom )
1471
1472         gvdwc(k,i) = gvdwc(k,i)
1473      &             - (( dFdR + gg(k) ) * ertail(k))
1474 c!     &             - ( dFdR * ertail(k))
1475
1476         gvdwc(k,j) = gvdwc(k,j)
1477      &             + (( dFdR + gg(k) ) * ertail(k))
1478 c!     &             + ( dFdR * ertail(k))
1479
1480         gg(k) = 0.0d0
1481 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1482 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1483       END DO
1484
1485 c!-------------------------------------------------------------------
1486 c! Compute head-head and head-tail energies for each state
1487
1488           isel = iabs(Qi) + iabs(Qj)
1489           IF (isel.eq.0) THEN
1490 c! No charges - do nothing
1491            eheadtail = 0.0d0
1492
1493           ELSE IF (isel.eq.4) THEN
1494 c! Calculate dipole-dipole interactions
1495            CALL edd(ecl)
1496            eheadtail = ECL
1497
1498           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1499 c! Charge-nonpolar interactions
1500            CALL eqn(epol)
1501            eheadtail = epol
1502
1503           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1504 c! Nonpolar-charge interactions
1505            CALL enq(epol)
1506            eheadtail = epol
1507
1508           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1509 c! Charge-dipole interactions
1510            CALL eqd(ecl, elj, epol)
1511            eheadtail = ECL + elj + epol
1512
1513           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1514 c! Dipole-charge interactions
1515            CALL edq(ecl, elj, epol)
1516            eheadtail = ECL + elj + epol
1517
1518           ELSE IF ((isel.eq.2.and.
1519      &          iabs(Qi).eq.1).and.
1520      &          nstate(itypi,itypj).eq.1) THEN
1521 c! Same charge-charge interaction ( +/+ or -/- )
1522            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1523            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1524
1525           ELSE IF ((isel.eq.2.and.
1526      &          iabs(Qi).eq.1).and.
1527      &          nstate(itypi,itypj).ne.1) THEN
1528 c! Different charge-charge interaction ( +/- or -/+ )
1529            CALL energy_quad
1530      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1531           END IF
1532        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1533 c!      write (*,*) "evdw = ", evdw
1534 c!      write (*,*) "Fcav = ", Fcav
1535 c!      write (*,*) "eheadtail = ", eheadtail
1536        evdw = evdw
1537      &      + Fcav
1538      &      + eheadtail
1539        ij=icant(itypi,itypj)
1540        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1541        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1542        eneps_temp(3,ij)=eheadtail
1543        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1544      &  restyp(itype(i)),i,restyp(itype(j)),j,
1545      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1546      &  Equad,evdw
1547        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1548      &  restyp(itype(i)),i,restyp(itype(j)),j,
1549      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1550      &  Equad,evdw
1551 #ifdef CHECK_MOMO
1552        evdw = 0.0d0
1553        END DO ! troll
1554 #endif
1555
1556 c!-------------------------------------------------------------------
1557 c! As all angular derivatives are done, now we sum them up,
1558 c! then transform and project into cartesian vectors and add to gvdwc
1559 c! We call sc_grad always, with the exception of +/- interaction.
1560 c! This is because energy_quad subroutine needs to handle
1561 c! this job in his own way.
1562 c! This IS probably not very efficient and SHOULD be optimised
1563 c! but it will require major restructurization of emomo
1564 c! so it will be left as it is for now
1565 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1566        IF (nstate(itypi,itypj).eq.1) THEN
1567 #ifdef TSCSC
1568         IF (bb(itypi,itypj).gt.0) THEN
1569          CALL sc_grad
1570         ELSE
1571          CALL sc_grad_T
1572         END IF
1573 #else
1574         CALL sc_grad
1575 #endif
1576        END IF
1577 c!-------------------------------------------------------------------
1578 c! NAPISY KONCOWE
1579          END DO   ! j
1580         END DO    ! iint
1581        END DO     ! i
1582 c      write (iout,*) "Number of loop steps in EGB:",ind
1583 c      energy_dec=.false.
1584        RETURN
1585       END SUBROUTINE emomo
1586 c! END OF MOMO
1587 C-----------------------------------------------------------------------------
1588       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1589        IMPLICIT NONE
1590        INCLUDE 'DIMENSIONS'
1591        INCLUDE 'DIMENSIONS.ZSCOPT'
1592        INCLUDE 'COMMON.CALC'
1593        INCLUDE 'COMMON.CHAIN'
1594        INCLUDE 'COMMON.CONTROL'
1595        INCLUDE 'COMMON.DERIV'
1596        INCLUDE 'COMMON.EMP'
1597        INCLUDE 'COMMON.GEO'
1598        INCLUDE 'COMMON.INTERACT'
1599        INCLUDE 'COMMON.IOUNITS'
1600        INCLUDE 'COMMON.LOCAL'
1601        INCLUDE 'COMMON.NAMES'
1602        INCLUDE 'COMMON.VAR'
1603        double precision scalar, facd3, facd4, federmaus, adler
1604 c! Epol and Gpol analytical parameters
1605        alphapol1 = alphapol(itypi,itypj)
1606        alphapol2 = alphapol(itypj,itypi)
1607 c! Fisocav and Gisocav analytical parameters
1608        al1  = alphiso(1,itypi,itypj)
1609        al2  = alphiso(2,itypi,itypj)
1610        al3  = alphiso(3,itypi,itypj)
1611        al4  = alphiso(4,itypi,itypj)
1612        csig = (1.0d0
1613      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1614      &      + sigiso2(itypi,itypj)**2.0d0))
1615 c!
1616        pis  = sig0head(itypi,itypj)
1617        eps_head = epshead(itypi,itypj)
1618        Rhead_sq = Rhead * Rhead
1619 c! R1 - distance between head of ith side chain and tail of jth sidechain
1620 c! R2 - distance between head of jth side chain and tail of ith sidechain
1621        R1 = 0.0d0
1622        R2 = 0.0d0
1623        DO k = 1, 3
1624 c! Calculate head-to-tail distances needed by Epol
1625         R1=R1+(ctail(k,2)-chead(k,1))**2
1626         R2=R2+(chead(k,2)-ctail(k,1))**2
1627        END DO
1628 c! Pitagoras
1629        R1 = dsqrt(R1)
1630        R2 = dsqrt(R2)
1631
1632 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1633 c!     &        +dhead(1,1,itypi,itypj))**2))
1634 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1635 c!     &        +dhead(2,1,itypi,itypj))**2))
1636 c!-------------------------------------------------------------------
1637 c! Coulomb electrostatic interaction
1638        Ecl = (332.0d0 * Qij) / Rhead
1639 c! derivative of Ecl is Gcl...
1640        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1641        dGCLdOM1 = 0.0d0
1642        dGCLdOM2 = 0.0d0
1643        dGCLdOM12 = 0.0d0
1644 c!-------------------------------------------------------------------
1645 c! Generalised Born Solvent Polarization
1646 c! Charged head polarizes the solvent
1647        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1648        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1649        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1650 c! Derivative of Egb is Ggb...
1651        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1652        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1653      &        / ( 2.0d0 * Fgb )
1654        dGGBdR = dGGBdFGB * dFGBdR
1655 c!-------------------------------------------------------------------
1656 c! Fisocav - isotropic cavity creation term
1657 c! or "how much energy it costs to put charged head in water"
1658        pom = Rhead * csig
1659        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1660        bot = (1.0d0 + al4 * pom**12.0d0)
1661        botsq = bot * bot
1662        FisoCav = top / bot
1663 c!      write (*,*) "Rhead = ",Rhead
1664 c!      write (*,*) "csig = ",csig
1665 c!      write (*,*) "pom = ",pom
1666 c!      write (*,*) "al1 = ",al1
1667 c!      write (*,*) "al2 = ",al2
1668 c!      write (*,*) "al3 = ",al3
1669 c!      write (*,*) "al4 = ",al4
1670 c!      write (*,*) "top = ",top
1671 c!      write (*,*) "bot = ",bot
1672 c! Derivative of Fisocav is GCV...
1673        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1674        dbot = 12.0d0 * al4 * pom ** 11.0d0
1675        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1676 c!-------------------------------------------------------------------
1677 c! Epol
1678 c! Polarization energy - charged heads polarize hydrophobic "neck"
1679        MomoFac1 = (1.0d0 - chi1 * sqom2)
1680        MomoFac2 = (1.0d0 - chi2 * sqom1)
1681        RR1  = ( R1 * R1 ) / MomoFac1
1682        RR2  = ( R2 * R2 ) / MomoFac2
1683        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1684        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1685        fgb1 = sqrt( RR1 + a12sq * ee1 )
1686        fgb2 = sqrt( RR2 + a12sq * ee2 )
1687        epol = 332.0d0 * eps_inout_fac * (
1688      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1689 c!       epol = 0.0d0
1690 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1691 c       write (*,*) "alphapol1 = ", alphapol1
1692 c       write (*,*) "alphapol2 = ", alphapol2
1693 c       write (*,*) "fgb1 = ", fgb1
1694 c       write (*,*) "fgb2 = ", fgb2
1695 c       write (*,*) "epol = ", epol
1696 c! derivative of Epol is Gpol...
1697        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1698      &          / (fgb1 ** 5.0d0)
1699        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1700      &          / (fgb2 ** 5.0d0)
1701        dFGBdR1 = ( (R1 / MomoFac1)
1702      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1703      &        / ( 2.0d0 * fgb1 )
1704        dFGBdR2 = ( (R2 / MomoFac2)
1705      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1706      &        / ( 2.0d0 * fgb2 )
1707        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1708      &          * ( 2.0d0 - 0.5d0 * ee1) )
1709      &          / ( 2.0d0 * fgb1 )
1710        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1711      &          * ( 2.0d0 - 0.5d0 * ee2) )
1712      &          / ( 2.0d0 * fgb2 )
1713        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1714 c!       dPOLdR1 = 0.0d0
1715        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1716 c!       dPOLdR2 = 0.0d0
1717        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1718 c!       dPOLdOM1 = 0.0d0
1719        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1720 c!       dPOLdOM2 = 0.0d0
1721 c!-------------------------------------------------------------------
1722 c! Elj
1723 c! Lennard-Jones 6-12 interaction between heads
1724        pom = (pis / Rhead)**6.0d0
1725        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1726 c! derivative of Elj is Glj
1727        dGLJdR = 4.0d0 * eps_head
1728      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1729      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1730 c!-------------------------------------------------------------------
1731 c! Return the results
1732 c! These things do the dRdX derivatives, that is
1733 c! allow us to change what we see from function that changes with
1734 c! distance to function that changes with LOCATION (of the interaction
1735 c! site)
1736        DO k = 1, 3
1737         erhead(k) = Rhead_distance(k)/Rhead
1738         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1739         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1740        END DO
1741
1742        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1743        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1744        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1745        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1746        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1747        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1748        facd1 = d1 * vbld_inv(i+nres)
1749        facd2 = d2 * vbld_inv(j+nres)
1750        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1751        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1752
1753 c! Now we add appropriate partial derivatives (one in each dimension)
1754        DO k = 1, 3
1755         hawk   = (erhead_tail(k,1) +
1756      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1757         condor = (erhead_tail(k,2) +
1758      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1759
1760         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1761         gvdwx(k,i) = gvdwx(k,i)
1762      &             - dGCLdR * pom
1763      &             - dGGBdR * pom
1764      &             - dGCVdR * pom
1765      &             - dPOLdR1 * hawk
1766      &             - dPOLdR2 * (erhead_tail(k,2)
1767      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1768      &             - dGLJdR * pom
1769
1770         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1771         gvdwx(k,j) = gvdwx(k,j)
1772      &             + dGCLdR * pom
1773      &             + dGGBdR * pom
1774      &             + dGCVdR * pom
1775      &             + dPOLdR1 * (erhead_tail(k,1)
1776      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1777      &             + dPOLdR2 * condor
1778      &             + dGLJdR * pom
1779
1780         gvdwc(k,i) = gvdwc(k,i)
1781      &             - dGCLdR * erhead(k)
1782      &             - dGGBdR * erhead(k)
1783      &             - dGCVdR * erhead(k)
1784      &             - dPOLdR1 * erhead_tail(k,1)
1785      &             - dPOLdR2 * erhead_tail(k,2)
1786      &             - dGLJdR * erhead(k)
1787
1788         gvdwc(k,j) = gvdwc(k,j)
1789      &             + dGCLdR * erhead(k)
1790      &             + dGGBdR * erhead(k)
1791      &             + dGCVdR * erhead(k)
1792      &             + dPOLdR1 * erhead_tail(k,1)
1793      &             + dPOLdR2 * erhead_tail(k,2)
1794      &             + dGLJdR * erhead(k)
1795
1796        END DO
1797        RETURN
1798       END SUBROUTINE eqq
1799 c!-------------------------------------------------------------------
1800       SUBROUTINE energy_quad
1801      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1802        IMPLICIT NONE
1803        INCLUDE 'DIMENSIONS'
1804        INCLUDE 'DIMENSIONS.ZSCOPT'
1805        INCLUDE 'COMMON.CALC'
1806        INCLUDE 'COMMON.CHAIN'
1807        INCLUDE 'COMMON.CONTROL'
1808        INCLUDE 'COMMON.DERIV'
1809        INCLUDE 'COMMON.EMP'
1810        INCLUDE 'COMMON.GEO'
1811        INCLUDE 'COMMON.INTERACT'
1812        INCLUDE 'COMMON.IOUNITS'
1813        INCLUDE 'COMMON.LOCAL'
1814        INCLUDE 'COMMON.NAMES'
1815        INCLUDE 'COMMON.VAR'
1816        double precision scalar
1817        double precision ener(4)
1818        double precision dcosom1(3),dcosom2(3)
1819 c! used in Epol derivatives
1820        double precision facd3, facd4
1821        double precision federmaus, adler
1822 c! Epol and Gpol analytical parameters
1823        alphapol1 = alphapol(itypi,itypj)
1824        alphapol2 = alphapol(itypj,itypi)
1825 c! Fisocav and Gisocav analytical parameters
1826        al1  = alphiso(1,itypi,itypj)
1827        al2  = alphiso(2,itypi,itypj)
1828        al3  = alphiso(3,itypi,itypj)
1829        al4  = alphiso(4,itypi,itypj)
1830        csig = (1.0d0
1831      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1832      &      + sigiso2(itypi,itypj)**2.0d0))
1833 c!
1834        w1   = wqdip(1,itypi,itypj)
1835        w2   = wqdip(2,itypi,itypj)
1836        pis  = sig0head(itypi,itypj)
1837        eps_head = epshead(itypi,itypj)
1838 c! First things first:
1839 c! We need to do sc_grad's job with GB and Fcav
1840        eom1  =
1841      &         eps2der * eps2rt_om1
1842      &       - 2.0D0 * alf1 * eps3der
1843      &       + sigder * sigsq_om1
1844      &       + dCAVdOM1
1845        eom2  =
1846      &         eps2der * eps2rt_om2
1847      &       + 2.0D0 * alf2 * eps3der
1848      &       + sigder * sigsq_om2
1849      &       + dCAVdOM2
1850        eom12 =
1851      &         evdwij  * eps1_om12
1852      &       + eps2der * eps2rt_om12
1853      &       - 2.0D0 * alf12 * eps3der
1854      &       + sigder *sigsq_om12
1855      &       + dCAVdOM12
1856 c! now some magical transformations to project gradient into
1857 c! three cartesian vectors
1858        DO k = 1, 3
1859         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1860         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1861         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1862 c! this acts on hydrophobic center of interaction
1863         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1864      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1865      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1866         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1867      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1868      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1869 c! this acts on Calpha
1870         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1871         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1872        END DO
1873 c! sc_grad is done, now we will compute
1874        eheadtail = 0.0d0
1875        eom1 = 0.0d0
1876        eom2 = 0.0d0
1877        eom12 = 0.0d0
1878
1879 c! ENERGY DEBUG
1880 c!       ii = 1
1881 c!       jj = 1
1882 c!       d1 = dhead(1, 1, itypi, itypj)
1883 c!       d2 = dhead(2, 1, itypi, itypj)
1884 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1885 c!     &        +dhead(1,ii,itypi,itypj))**2))
1886 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1887 c!     &        +dhead(2,jj,itypi,itypj))**2))
1888 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1889 c! END OF ENERGY DEBUG
1890 c*************************************************************
1891        DO istate = 1, nstate(itypi,itypj)
1892 c*************************************************************
1893         IF (istate.ne.1) THEN
1894          IF (istate.lt.3) THEN
1895           ii = 1
1896          ELSE
1897           ii = 2
1898          END IF
1899         jj = istate/ii
1900         d1 = dhead(1,ii,itypi,itypj)
1901         d2 = dhead(2,jj,itypi,itypj)
1902         DO k = 1,3
1903          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1904          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1905          Rhead_distance(k) = chead(k,2) - chead(k,1)
1906         END DO
1907 c! pitagoras (root of sum of squares)
1908         Rhead = dsqrt(
1909      &          (Rhead_distance(1)*Rhead_distance(1))
1910      &        + (Rhead_distance(2)*Rhead_distance(2))
1911      &        + (Rhead_distance(3)*Rhead_distance(3)))
1912         END IF
1913         Rhead_sq = Rhead * Rhead
1914
1915 c! R1 - distance between head of ith side chain and tail of jth sidechain
1916 c! R2 - distance between head of jth side chain and tail of ith sidechain
1917         R1 = 0.0d0
1918         R2 = 0.0d0
1919         DO k = 1, 3
1920 c! Calculate head-to-tail distances
1921          R1=R1+(ctail(k,2)-chead(k,1))**2
1922          R2=R2+(chead(k,2)-ctail(k,1))**2
1923         END DO
1924 c! Pitagoras
1925         R1 = dsqrt(R1)
1926         R2 = dsqrt(R2)
1927
1928 c! ENERGY DEBUG
1929 c!      write (*,*) "istate = ", istate
1930 c!      write (*,*) "ii = ", ii
1931 c!      write (*,*) "jj = ", jj
1932 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1933 c!     &        +dhead(1,ii,itypi,itypj))**2))
1934 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1935 c!     &        +dhead(2,jj,itypi,itypj))**2))
1936 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1937 c!      Rhead_sq = Rhead * Rhead
1938 c!      write (*,*) "d1 = ",d1
1939 c!      write (*,*) "d2 = ",d2
1940 c!      write (*,*) "R1 = ",R1
1941 c!      write (*,*) "R2 = ",R2
1942 c!      write (*,*) "Rhead = ",Rhead
1943 c! END OF ENERGY DEBUG
1944
1945 c!-------------------------------------------------------------------
1946 c! Coulomb electrostatic interaction
1947         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1948 c!        Ecl = 0.0d0
1949 c!        write (*,*) "Ecl = ", Ecl
1950 c! derivative of Ecl is Gcl...
1951         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1952 c!        dGCLdR = 0.0d0
1953         dGCLdOM1 = 0.0d0
1954         dGCLdOM2 = 0.0d0
1955         dGCLdOM12 = 0.0d0
1956 c!-------------------------------------------------------------------
1957 c! Generalised Born Solvent Polarization
1958         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1959         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1960         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1961 c!        Egb = 0.0d0
1962 c!      write (*,*) "a1*a2 = ", a12sq
1963 c!      write (*,*) "Rhead = ", Rhead
1964 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1965 c!      write (*,*) "ee = ", ee
1966 c!      write (*,*) "Fgb = ", Fgb
1967 c!      write (*,*) "fac = ", eps_inout_fac
1968 c!      write (*,*) "Qij = ", Qij
1969 c!      write (*,*) "Egb = ", Egb
1970 c! Derivative of Egb is Ggb...
1971 c! dFGBdR is used by Quad's later...
1972         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1973         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1974      &         / ( 2.0d0 * Fgb )
1975         dGGBdR = dGGBdFGB * dFGBdR
1976 c!        dGGBdR = 0.0d0
1977 c!-------------------------------------------------------------------
1978 c! Fisocav - isotropic cavity creation term
1979         pom = Rhead * csig
1980         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1981         bot = (1.0d0 + al4 * pom**12.0d0)
1982         botsq = bot * bot
1983         FisoCav = top / bot
1984 c!        FisoCav = 0.0d0
1985 c!      write (*,*) "pom = ",pom
1986 c!      write (*,*) "al1 = ",al1
1987 c!      write (*,*) "al2 = ",al2
1988 c!      write (*,*) "al3 = ",al3
1989 c!      write (*,*) "al4 = ",al4
1990 c!      write (*,*) "top = ",top
1991 c!      write (*,*) "bot = ",bot
1992 c!      write (*,*) "Fisocav = ", Fisocav
1993
1994 c! Derivative of Fisocav is GCV...
1995         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1996         dbot = 12.0d0 * al4 * pom ** 11.0d0
1997         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1998 c!        dGCVdR = 0.0d0
1999 c!-------------------------------------------------------------------
2000 c! Polarization energy
2001 c! Epol
2002         MomoFac1 = (1.0d0 - chi1 * sqom2)
2003         MomoFac2 = (1.0d0 - chi2 * sqom1)
2004         RR1  = ( R1 * R1 ) / MomoFac1
2005         RR2  = ( R2 * R2 ) / MomoFac2
2006         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2007         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2008         fgb1 = sqrt( RR1 + a12sq * ee1 )
2009         fgb2 = sqrt( RR2 + a12sq * ee2 )
2010         epol = 332.0d0 * eps_inout_fac * (
2011      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2012 c!        epol = 0.0d0
2013 c! derivative of Epol is Gpol...
2014         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2015      &            / (fgb1 ** 5.0d0)
2016         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2017      &            / (fgb2 ** 5.0d0)
2018         dFGBdR1 = ( (R1 / MomoFac1)
2019      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2020      &          / ( 2.0d0 * fgb1 )
2021         dFGBdR2 = ( (R2 / MomoFac2)
2022      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2023      &          / ( 2.0d0 * fgb2 )
2024         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2025      &           * ( 2.0d0 - 0.5d0 * ee1) )
2026      &           / ( 2.0d0 * fgb1 )
2027         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2028      &           * ( 2.0d0 - 0.5d0 * ee2) )
2029      &           / ( 2.0d0 * fgb2 )
2030         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2031 c!        dPOLdR1 = 0.0d0
2032         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2033 c!        dPOLdR2 = 0.0d0
2034         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2035 c!        dPOLdOM1 = 0.0d0
2036         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2037 c!        dPOLdOM2 = 0.0d0
2038 c!-------------------------------------------------------------------
2039 c! Elj
2040         pom = (pis / Rhead)**6.0d0
2041         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2042 c!        Elj = 0.0d0
2043 c! derivative of Elj is Glj
2044         dGLJdR = 4.0d0 * eps_head
2045      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2046      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2047 c!        dGLJdR = 0.0d0
2048 c!-------------------------------------------------------------------
2049 c! Equad
2050        IF (Wqd.ne.0.0d0) THEN
2051         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2052      &        - 37.5d0  * ( sqom1 + sqom2 )
2053      &        + 157.5d0 * ( sqom1 * sqom2 )
2054      &        - 45.0d0  * om1*om2*om12
2055         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2056         Equad = fac * Beta1
2057 c!        Equad = 0.0d0
2058 c! derivative of Equad...
2059         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2060 c!        dQUADdR = 0.0d0
2061         dQUADdOM1 = fac
2062      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2063 c!        dQUADdOM1 = 0.0d0
2064         dQUADdOM2 = fac
2065      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2066 c!        dQUADdOM2 = 0.0d0
2067         dQUADdOM12 = fac
2068      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2069 c!        dQUADdOM12 = 0.0d0
2070         ELSE
2071          Beta1 = 0.0d0
2072          Equad = 0.0d0
2073         END IF
2074 c!-------------------------------------------------------------------
2075 c! Return the results
2076 c! Angular stuff
2077         eom1 = dPOLdOM1 + dQUADdOM1
2078         eom2 = dPOLdOM2 + dQUADdOM2
2079         eom12 = dQUADdOM12
2080 c! now some magical transformations to project gradient into
2081 c! three cartesian vectors
2082         DO k = 1, 3
2083          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2084          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2085          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2086         END DO
2087 c! Radial stuff
2088         DO k = 1, 3
2089          erhead(k) = Rhead_distance(k)/Rhead
2090          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2091          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2092         END DO
2093         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2094         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2095         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2096         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2097         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2098         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2099         facd1 = d1 * vbld_inv(i+nres)
2100         facd2 = d2 * vbld_inv(j+nres)
2101         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2102         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2103 c! Throw the results into gheadtail which holds gradients
2104 c! for each micro-state
2105         DO k = 1, 3
2106          hawk   = erhead_tail(k,1) +
2107      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2108          condor = erhead_tail(k,2) +
2109      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2110
2111          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2112 c! this acts on hydrophobic center of interaction
2113          gheadtail(k,1,1) = gheadtail(k,1,1)
2114      &                    - dGCLdR * pom
2115      &                    - dGGBdR * pom
2116      &                    - dGCVdR * pom
2117      &                    - dPOLdR1 * hawk
2118      &                    - dPOLdR2 * (erhead_tail(k,2)
2119      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2120      &                    - dGLJdR * pom
2121      &                    - dQUADdR * pom
2122      &                    - tuna(k)
2123      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2124      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2125
2126          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2127 c! this acts on hydrophobic center of interaction
2128          gheadtail(k,2,1) = gheadtail(k,2,1)
2129      &                    + dGCLdR * pom
2130      &                    + dGGBdR * pom
2131      &                    + dGCVdR * pom
2132      &                    + dPOLdR1 * (erhead_tail(k,1)
2133      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2134      &                    + dPOLdR2 * condor
2135      &                    + dGLJdR * pom
2136      &                    + dQUADdR * pom
2137      &                    + tuna(k)
2138      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2139      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2140
2141 c! this acts on Calpha
2142          gheadtail(k,3,1) = gheadtail(k,3,1)
2143      &                    - dGCLdR * erhead(k)
2144      &                    - dGGBdR * erhead(k)
2145      &                    - dGCVdR * erhead(k)
2146      &                    - dPOLdR1 * erhead_tail(k,1)
2147      &                    - dPOLdR2 * erhead_tail(k,2)
2148      &                    - dGLJdR * erhead(k)
2149      &                    - dQUADdR * erhead(k)
2150      &                    - tuna(k)
2151
2152 c! this acts on Calpha
2153          gheadtail(k,4,1) = gheadtail(k,4,1)
2154      &                    + dGCLdR * erhead(k)
2155      &                    + dGGBdR * erhead(k)
2156      &                    + dGCVdR * erhead(k)
2157      &                    + dPOLdR1 * erhead_tail(k,1)
2158      &                    + dPOLdR2 * erhead_tail(k,2)
2159      &                    + dGLJdR * erhead(k)
2160      &                    + dQUADdR * erhead(k)
2161      &                    + tuna(k)
2162         END DO
2163 c!      write(*,*) "ECL = ", Ecl
2164 c!      write(*,*) "Egb = ", Egb
2165 c!      write(*,*) "Epol = ", Epol
2166 c!      write(*,*) "Fisocav = ", Fisocav
2167 c!      write(*,*) "Elj = ", Elj
2168 c!      write(*,*) "Equad = ", Equad
2169 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2170 c!      write(*,*) "eheadtail = ", eheadtail
2171 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2172 c!      write(*,*) "dGCLdR = ", dGCLdR
2173 c!      write(*,*) "dGGBdR = ", dGGBdR
2174 c!      write(*,*) "dGCVdR = ", dGCVdR
2175 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2176 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2177 c!      write(*,*) "dGLJdR = ", dGLJdR
2178 c!      write(*,*) "dQUADdR = ", dQUADdR
2179 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2180         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2181         eheadtail = eheadtail
2182      &            + wstate(istate, itypi, itypj)
2183      &            * dexp(-betaT * ener(istate))
2184 c! foreach cartesian dimension
2185         DO k = 1, 3
2186 c! foreach of two gvdwx and gvdwc
2187          DO l = 1, 4
2188           gheadtail(k,l,2) = gheadtail(k,l,2)
2189      &                     + wstate( istate, itypi, itypj )
2190      &                     * dexp(-betaT * ener(istate))
2191      &                     * gheadtail(k,l,1)
2192           gheadtail(k,l,1) = 0.0d0
2193          END DO
2194         END DO
2195        END DO
2196 c! Here ended the gigantic DO istate = 1, 4, which starts
2197 c! at the beggining of the subroutine
2198
2199        DO k = 1, 3
2200         DO l = 1, 4
2201          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2202         END DO
2203         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2204         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2205         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2206         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2207         DO l = 1, 4
2208          gheadtail(k,l,1) = 0.0d0
2209          gheadtail(k,l,2) = 0.0d0
2210         END DO
2211        END DO
2212        eheadtail = (-dlog(eheadtail)) / betaT
2213        dPOLdOM1 = 0.0d0
2214        dPOLdOM2 = 0.0d0
2215        dQUADdOM1 = 0.0d0
2216        dQUADdOM2 = 0.0d0
2217        dQUADdOM12 = 0.0d0
2218        RETURN
2219       END SUBROUTINE energy_quad
2220 c!-------------------------------------------------------------------
2221       SUBROUTINE eqn(Epol)
2222       IMPLICIT NONE
2223       INCLUDE 'DIMENSIONS'
2224       INCLUDE 'DIMENSIONS.ZSCOPT'
2225       INCLUDE 'COMMON.CALC'
2226       INCLUDE 'COMMON.CHAIN'
2227       INCLUDE 'COMMON.CONTROL'
2228       INCLUDE 'COMMON.DERIV'
2229       INCLUDE 'COMMON.EMP'
2230       INCLUDE 'COMMON.GEO'
2231       INCLUDE 'COMMON.INTERACT'
2232       INCLUDE 'COMMON.IOUNITS'
2233       INCLUDE 'COMMON.LOCAL'
2234       INCLUDE 'COMMON.NAMES'
2235       INCLUDE 'COMMON.VAR'
2236       double precision scalar, facd4, federmaus
2237       alphapol1 = alphapol(itypi,itypj)
2238 c! R1 - distance between head of ith side chain and tail of jth sidechain
2239        R1 = 0.0d0
2240        DO k = 1, 3
2241 c! Calculate head-to-tail distances
2242         R1=R1+(ctail(k,2)-chead(k,1))**2
2243        END DO
2244 c! Pitagoras
2245        R1 = dsqrt(R1)
2246
2247 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2248 c!     &        +dhead(1,1,itypi,itypj))**2))
2249 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2250 c!     &        +dhead(2,1,itypi,itypj))**2))
2251 c--------------------------------------------------------------------
2252 c Polarization energy
2253 c Epol
2254        MomoFac1 = (1.0d0 - chi1 * sqom2)
2255        RR1  = R1 * R1 / MomoFac1
2256        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2257        fgb1 = sqrt( RR1 + a12sq * ee1)
2258        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2259 c!       epol = 0.0d0
2260 c!------------------------------------------------------------------
2261 c! derivative of Epol is Gpol...
2262        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2263      &          / (fgb1 ** 5.0d0)
2264        dFGBdR1 = ( (R1 / MomoFac1)
2265      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2266      &        / ( 2.0d0 * fgb1 )
2267        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2268      &          * (2.0d0 - 0.5d0 * ee1) )
2269      &          / (2.0d0 * fgb1)
2270        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2271 c!       dPOLdR1 = 0.0d0
2272        dPOLdOM1 = 0.0d0
2273        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2274 c!       dPOLdOM2 = 0.0d0
2275 c!-------------------------------------------------------------------
2276 c! Return the results
2277 c! (see comments in Eqq)
2278        DO k = 1, 3
2279         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2280        END DO
2281        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2282        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2283        facd1 = d1 * vbld_inv(i+nres)
2284        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2285
2286        DO k = 1, 3
2287         hawk = (erhead_tail(k,1) +
2288      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2289
2290         gvdwx(k,i) = gvdwx(k,i)
2291      &             - dPOLdR1 * hawk
2292         gvdwx(k,j) = gvdwx(k,j)
2293      &             + dPOLdR1 * (erhead_tail(k,1)
2294      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2295
2296         gvdwc(k,i) = gvdwc(k,i)
2297      &             - dPOLdR1 * erhead_tail(k,1)
2298         gvdwc(k,j) = gvdwc(k,j)
2299      &             + dPOLdR1 * erhead_tail(k,1)
2300
2301        END DO
2302        RETURN
2303       END SUBROUTINE eqn
2304
2305
2306 c!-------------------------------------------------------------------
2307
2308
2309
2310       SUBROUTINE enq(Epol)
2311        IMPLICIT NONE
2312        INCLUDE 'DIMENSIONS'
2313        INCLUDE 'DIMENSIONS.ZSCOPT'
2314        INCLUDE 'COMMON.CALC'
2315        INCLUDE 'COMMON.CHAIN'
2316        INCLUDE 'COMMON.CONTROL'
2317        INCLUDE 'COMMON.DERIV'
2318        INCLUDE 'COMMON.EMP'
2319        INCLUDE 'COMMON.GEO'
2320        INCLUDE 'COMMON.INTERACT'
2321        INCLUDE 'COMMON.IOUNITS'
2322        INCLUDE 'COMMON.LOCAL'
2323        INCLUDE 'COMMON.NAMES'
2324        INCLUDE 'COMMON.VAR'
2325        double precision scalar, facd3, adler
2326        alphapol2 = alphapol(itypj,itypi)
2327 c! R2 - distance between head of jth side chain and tail of ith sidechain
2328        R2 = 0.0d0
2329        DO k = 1, 3
2330 c! Calculate head-to-tail distances
2331         R2=R2+(chead(k,2)-ctail(k,1))**2
2332        END DO
2333 c! Pitagoras
2334        R2 = dsqrt(R2)
2335
2336 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2337 c!     &        +dhead(1,1,itypi,itypj))**2))
2338 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2339 c!     &        +dhead(2,1,itypi,itypj))**2))
2340 c------------------------------------------------------------------------
2341 c Polarization energy
2342        MomoFac2 = (1.0d0 - chi2 * sqom1)
2343        RR2  = R2 * R2 / MomoFac2
2344        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2345        fgb2 = sqrt(RR2  + a12sq * ee2)
2346        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2347 c!       epol = 0.0d0
2348 c!-------------------------------------------------------------------
2349 c! derivative of Epol is Gpol...
2350        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2351      &          / (fgb2 ** 5.0d0)
2352        dFGBdR2 = ( (R2 / MomoFac2)
2353      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2354      &        / (2.0d0 * fgb2)
2355        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2356      &          * (2.0d0 - 0.5d0 * ee2) )
2357      &          / (2.0d0 * fgb2)
2358        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2359 c!       dPOLdR2 = 0.0d0
2360        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2361 c!       dPOLdOM1 = 0.0d0
2362        dPOLdOM2 = 0.0d0
2363 c!-------------------------------------------------------------------
2364 c! Return the results
2365 c! (See comments in Eqq)
2366        DO k = 1, 3
2367         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2368        END DO
2369        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2370        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2371        facd2 = d2 * vbld_inv(j+nres)
2372        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2373        DO k = 1, 3
2374         condor = (erhead_tail(k,2)
2375      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2376
2377         gvdwx(k,i) = gvdwx(k,i)
2378      &             - dPOLdR2 * (erhead_tail(k,2)
2379      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2380         gvdwx(k,j) = gvdwx(k,j)
2381      &             + dPOLdR2 * condor
2382
2383         gvdwc(k,i) = gvdwc(k,i)
2384      &             - dPOLdR2 * erhead_tail(k,2)
2385         gvdwc(k,j) = gvdwc(k,j)
2386      &             + dPOLdR2 * erhead_tail(k,2)
2387
2388        END DO
2389       RETURN
2390       END SUBROUTINE enq
2391
2392
2393 c!-------------------------------------------------------------------
2394
2395
2396       SUBROUTINE eqd(Ecl,Elj,Epol)
2397        IMPLICIT NONE
2398        INCLUDE 'DIMENSIONS'
2399        INCLUDE 'DIMENSIONS.ZSCOPT'
2400        INCLUDE 'COMMON.CALC'
2401        INCLUDE 'COMMON.CHAIN'
2402        INCLUDE 'COMMON.CONTROL'
2403        INCLUDE 'COMMON.DERIV'
2404        INCLUDE 'COMMON.EMP'
2405        INCLUDE 'COMMON.GEO'
2406        INCLUDE 'COMMON.INTERACT'
2407        INCLUDE 'COMMON.IOUNITS'
2408        INCLUDE 'COMMON.LOCAL'
2409        INCLUDE 'COMMON.NAMES'
2410        INCLUDE 'COMMON.VAR'
2411        double precision scalar, facd4, federmaus
2412        alphapol1 = alphapol(itypi,itypj)
2413        w1        = wqdip(1,itypi,itypj)
2414        w2        = wqdip(2,itypi,itypj)
2415        pis       = sig0head(itypi,itypj)
2416        eps_head   = epshead(itypi,itypj)
2417 c!-------------------------------------------------------------------
2418 c! R1 - distance between head of ith side chain and tail of jth sidechain
2419        R1 = 0.0d0
2420        DO k = 1, 3
2421 c! Calculate head-to-tail distances
2422         R1=R1+(ctail(k,2)-chead(k,1))**2
2423        END DO
2424 c! Pitagoras
2425        R1 = dsqrt(R1)
2426
2427 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2428 c!     &        +dhead(1,1,itypi,itypj))**2))
2429 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2430 c!     &        +dhead(2,1,itypi,itypj))**2))
2431
2432 c!-------------------------------------------------------------------
2433 c! ecl
2434        sparrow  = w1 * Qi * om1
2435        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2436        Ecl = sparrow / Rhead**2.0d0
2437      &     - hawk    / Rhead**4.0d0
2438 c!-------------------------------------------------------------------
2439 c! derivative of ecl is Gcl
2440 c! dF/dr part
2441        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2442      &           + 4.0d0 * hawk    / Rhead**5.0d0
2443 c! dF/dom1
2444        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2445 c! dF/dom2
2446        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2447 c--------------------------------------------------------------------
2448 c Polarization energy
2449 c Epol
2450        MomoFac1 = (1.0d0 - chi1 * sqom2)
2451        RR1  = R1 * R1 / MomoFac1
2452        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2453        fgb1 = sqrt( RR1 + a12sq * ee1)
2454        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2455 c!       epol = 0.0d0
2456 c!------------------------------------------------------------------
2457 c! derivative of Epol is Gpol...
2458        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2459      &          / (fgb1 ** 5.0d0)
2460        dFGBdR1 = ( (R1 / MomoFac1)
2461      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2462      &        / ( 2.0d0 * fgb1 )
2463        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2464      &          * (2.0d0 - 0.5d0 * ee1) )
2465      &          / (2.0d0 * fgb1)
2466        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2467 c!       dPOLdR1 = 0.0d0
2468        dPOLdOM1 = 0.0d0
2469        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2470 c!       dPOLdOM2 = 0.0d0
2471 c!-------------------------------------------------------------------
2472 c! Elj
2473        pom = (pis / Rhead)**6.0d0
2474        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2475 c! derivative of Elj is Glj
2476        dGLJdR = 4.0d0 * eps_head
2477      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2478      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2479 c!-------------------------------------------------------------------
2480 c! Return the results
2481        DO k = 1, 3
2482         erhead(k) = Rhead_distance(k)/Rhead
2483         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2484        END DO
2485
2486        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2487        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2488        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2489        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2490        facd1 = d1 * vbld_inv(i+nres)
2491        facd2 = d2 * vbld_inv(j+nres)
2492        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2493
2494        DO k = 1, 3
2495         hawk = (erhead_tail(k,1) +
2496      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2497
2498         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2499         gvdwx(k,i) = gvdwx(k,i)
2500      &             - dGCLdR * pom
2501      &             - dPOLdR1 * hawk
2502      &             - dGLJdR * pom
2503
2504         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2505         gvdwx(k,j) = gvdwx(k,j)
2506      &             + dGCLdR * pom
2507      &             + dPOLdR1 * (erhead_tail(k,1)
2508      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2509      &             + dGLJdR * pom
2510
2511
2512         gvdwc(k,i) = gvdwc(k,i)
2513      &             - dGCLdR * erhead(k)
2514      &             - dPOLdR1 * erhead_tail(k,1)
2515      &             - dGLJdR * erhead(k)
2516
2517         gvdwc(k,j) = gvdwc(k,j)
2518      &             + dGCLdR * erhead(k)
2519      &             + dPOLdR1 * erhead_tail(k,1)
2520      &             + dGLJdR * erhead(k)
2521
2522        END DO
2523        RETURN
2524       END SUBROUTINE eqd
2525
2526
2527 c!-------------------------------------------------------------------
2528
2529
2530       SUBROUTINE edq(Ecl,Elj,Epol)
2531        IMPLICIT NONE
2532        INCLUDE 'DIMENSIONS'
2533        INCLUDE 'DIMENSIONS.ZSCOPT'
2534        INCLUDE 'COMMON.CALC'
2535        INCLUDE 'COMMON.CHAIN'
2536        INCLUDE 'COMMON.CONTROL'
2537        INCLUDE 'COMMON.DERIV'
2538        INCLUDE 'COMMON.EMP'
2539        INCLUDE 'COMMON.GEO'
2540        INCLUDE 'COMMON.INTERACT'
2541        INCLUDE 'COMMON.IOUNITS'
2542        INCLUDE 'COMMON.LOCAL'
2543        INCLUDE 'COMMON.NAMES'
2544        INCLUDE 'COMMON.VAR'
2545        double precision scalar, facd3, adler
2546        alphapol2 = alphapol(itypj,itypi)
2547        w1        = wqdip(1,itypi,itypj)
2548        w2        = wqdip(2,itypi,itypj)
2549        pis       = sig0head(itypi,itypj)
2550        eps_head  = epshead(itypi,itypj)
2551 c!-------------------------------------------------------------------
2552 c! R2 - distance between head of jth side chain and tail of ith sidechain
2553        R2 = 0.0d0
2554        DO k = 1, 3
2555 c! Calculate head-to-tail distances
2556         R2=R2+(chead(k,2)-ctail(k,1))**2
2557        END DO
2558 c! Pitagoras
2559        R2 = dsqrt(R2)
2560
2561 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2562 c!     &        +dhead(1,1,itypi,itypj))**2))
2563 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2564 c!     &        +dhead(2,1,itypi,itypj))**2))
2565
2566
2567 c!-------------------------------------------------------------------
2568 c! ecl
2569        sparrow  = w1 * Qi * om1
2570        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2571        ECL = sparrow / Rhead**2.0d0
2572      &     - hawk    / Rhead**4.0d0
2573 c!-------------------------------------------------------------------
2574 c! derivative of ecl is Gcl
2575 c! dF/dr part
2576        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2577      &           + 4.0d0 * hawk    / Rhead**5.0d0
2578 c! dF/dom1
2579        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2580 c! dF/dom2
2581        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2582 c--------------------------------------------------------------------
2583 c Polarization energy
2584 c Epol
2585        MomoFac2 = (1.0d0 - chi2 * sqom1)
2586        RR2  = R2 * R2 / MomoFac2
2587        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2588        fgb2 = sqrt(RR2  + a12sq * ee2)
2589        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2590 c!       epol = 0.0d0
2591 c! derivative of Epol is Gpol...
2592        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2593      &          / (fgb2 ** 5.0d0)
2594        dFGBdR2 = ( (R2 / MomoFac2)
2595      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2596      &        / (2.0d0 * fgb2)
2597        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2598      &          * (2.0d0 - 0.5d0 * ee2) )
2599      &          / (2.0d0 * fgb2)
2600        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2601 c!       dPOLdR2 = 0.0d0
2602        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2603 c!       dPOLdOM1 = 0.0d0
2604        dPOLdOM2 = 0.0d0
2605 c!-------------------------------------------------------------------
2606 c! Elj
2607        pom = (pis / Rhead)**6.0d0
2608        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2609 c! derivative of Elj is Glj
2610        dGLJdR = 4.0d0 * eps_head
2611      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2612      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2613 c!-------------------------------------------------------------------
2614 c! Return the results
2615 c! (see comments in Eqq)
2616        DO k = 1, 3
2617         erhead(k) = Rhead_distance(k)/Rhead
2618         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2619        END DO
2620        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2621        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2622        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2623        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2624        facd1 = d1 * vbld_inv(i+nres)
2625        facd2 = d2 * vbld_inv(j+nres)
2626        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2627
2628        DO k = 1, 3
2629         condor = (erhead_tail(k,2)
2630      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2631
2632         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2633         gvdwx(k,i) = gvdwx(k,i)
2634      &             - dGCLdR * pom
2635      &             - dPOLdR2 * (erhead_tail(k,2)
2636      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2637      &             - dGLJdR * pom
2638
2639         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2640         gvdwx(k,j) = gvdwx(k,j)
2641      &             + dGCLdR * pom
2642      &             + dPOLdR2 * condor
2643      &             + dGLJdR * pom
2644
2645
2646         gvdwc(k,i) = gvdwc(k,i)
2647      &             - dGCLdR * erhead(k)
2648      &             - dPOLdR2 * erhead_tail(k,2)
2649      &             - dGLJdR * erhead(k)
2650
2651         gvdwc(k,j) = gvdwc(k,j)
2652      &             + dGCLdR * erhead(k)
2653      &             + dPOLdR2 * erhead_tail(k,2)
2654      &             + dGLJdR * erhead(k)
2655
2656        END DO
2657        RETURN
2658       END SUBROUTINE edq
2659
2660
2661 C--------------------------------------------------------------------
2662
2663
2664       SUBROUTINE edd(ECL)
2665        IMPLICIT NONE
2666        INCLUDE 'DIMENSIONS'
2667        INCLUDE 'DIMENSIONS.ZSCOPT'
2668        INCLUDE 'COMMON.CALC'
2669        INCLUDE 'COMMON.CHAIN'
2670        INCLUDE 'COMMON.CONTROL'
2671        INCLUDE 'COMMON.DERIV'
2672        INCLUDE 'COMMON.EMP'
2673        INCLUDE 'COMMON.GEO'
2674        INCLUDE 'COMMON.INTERACT'
2675        INCLUDE 'COMMON.IOUNITS'
2676        INCLUDE 'COMMON.LOCAL'
2677        INCLUDE 'COMMON.NAMES'
2678        INCLUDE 'COMMON.VAR'
2679        double precision scalar
2680 c!       csig = sigiso(itypi,itypj)
2681        w1 = wqdip(1,itypi,itypj)
2682        w2 = wqdip(2,itypi,itypj)
2683 c!-------------------------------------------------------------------
2684 c! ECL
2685        fac = (om12 - 3.0d0 * om1 * om2)
2686        c1 = (w1 / (Rhead**3.0d0)) * fac
2687        c2 = (w2 / Rhead ** 6.0d0)
2688      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2689        ECL = c1 - c2
2690 c!       write (*,*) "w1 = ", w1
2691 c!       write (*,*) "w2 = ", w2
2692 c!       write (*,*) "om1 = ", om1
2693 c!       write (*,*) "om2 = ", om2
2694 c!       write (*,*) "om12 = ", om12
2695 c!       write (*,*) "fac = ", fac
2696 c!       write (*,*) "c1 = ", c1
2697 c!       write (*,*) "c2 = ", c2
2698 c!       write (*,*) "Ecl = ", Ecl
2699 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2700 c!       write (*,*) "c2_2 = ",
2701 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2702 c!-------------------------------------------------------------------
2703 c! dervative of ECL is GCL...
2704 c! dECL/dr
2705        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2706        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2707      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2708        dGCLdR = c1 - c2
2709 c! dECL/dom1
2710        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2711        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2712      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2713        dGCLdOM1 = c1 - c2
2714 c! dECL/dom2
2715        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2716        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2717      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2718        dGCLdOM2 = c1 - c2
2719 c! dECL/dom12
2720        c1 = w1 / (Rhead ** 3.0d0)
2721        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2722        dGCLdOM12 = c1 - c2
2723 c!-------------------------------------------------------------------
2724 c! Return the results
2725 c! (see comments in Eqq)
2726        DO k= 1, 3
2727         erhead(k) = Rhead_distance(k)/Rhead
2728        END DO
2729        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2730        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2731        facd1 = d1 * vbld_inv(i+nres)
2732        facd2 = d2 * vbld_inv(j+nres)
2733        DO k = 1, 3
2734
2735         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2736         gvdwx(k,i) = gvdwx(k,i)
2737      &             - dGCLdR * pom
2738         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2739         gvdwx(k,j) = gvdwx(k,j)
2740      &             + dGCLdR * pom
2741
2742         gvdwc(k,i) = gvdwc(k,i)
2743      &             - dGCLdR * erhead(k)
2744         gvdwc(k,j) = gvdwc(k,j)
2745      &             + dGCLdR * erhead(k)
2746        END DO
2747        RETURN
2748       END SUBROUTINE edd
2749
2750
2751 c!-------------------------------------------------------------------
2752
2753
2754       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2755        IMPLICIT NONE
2756 c! maxres
2757        INCLUDE 'DIMENSIONS'
2758        INCLUDE 'DIMENSIONS.ZSCOPT'
2759 c! itypi, itypj, i, j, k, l, chead,
2760        INCLUDE 'COMMON.CALC'
2761 c! c, nres, dc_norm
2762        INCLUDE 'COMMON.CHAIN'
2763 c! gradc, gradx
2764        INCLUDE 'COMMON.DERIV'
2765 c! electrostatic gradients-specific variables
2766        INCLUDE 'COMMON.EMP'
2767 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2768        INCLUDE 'COMMON.INTERACT'
2769 c! t_bath, Rb
2770 c       INCLUDE 'COMMON.MD'
2771 c! io for debug, disable it in final builds
2772        INCLUDE 'COMMON.IOUNITS'
2773        double precision Rb /1.987D-3/
2774 c!-------------------------------------------------------------------
2775 c! Variable Init
2776
2777 c! what amino acid is the aminoacid j'th?
2778        itypj = itype(j)
2779 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2780 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2781 c!       t_bath = 300
2782 c!       BetaT = 1.0d0 / (t_bath * Rb)
2783        BetaT = 1.0d0 / (298.0d0 * Rb)
2784 c! Gay-berne var's
2785        sig0ij = sigma( itypi,itypj )
2786        chi1   = chi( itypi, itypj )
2787        chi2   = chi( itypj, itypi )
2788        chi12  = chi1 * chi2
2789        chip1  = chipp( itypi, itypj )
2790        chip2  = chipp( itypj, itypi )
2791        chip12 = chip1 * chip2
2792 c! not used by momo potential, but needed by sc_angular which is shared
2793 c! by all energy_potential subroutines
2794        alf1   = 0.0d0
2795        alf2   = 0.0d0
2796        alf12  = 0.0d0
2797 c! location, location, location
2798        xj  = c( 1, nres+j ) - xi
2799        yj  = c( 2, nres+j ) - yi
2800        zj  = c( 3, nres+j ) - zi
2801        dxj = dc_norm( 1, nres+j )
2802        dyj = dc_norm( 2, nres+j )
2803        dzj = dc_norm( 3, nres+j )
2804 c! distance from center of chain(?) to polar/charged head
2805 c!       write (*,*) "istate = ", 1
2806 c!       write (*,*) "ii = ", 1
2807 c!       write (*,*) "jj = ", 1
2808        d1 = dhead(1, 1, itypi, itypj)
2809        d2 = dhead(2, 1, itypi, itypj)
2810 c! ai*aj from Fgb
2811        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2812 c!       a12sq = a12sq * a12sq
2813 c! charge of amino acid itypi is...
2814        Qi  = icharge(itypi)
2815        Qj  = icharge(itypj)
2816        Qij = Qi * Qj
2817 c! chis1,2,12
2818        chis1 = chis(itypi,itypj)
2819        chis2 = chis(itypj,itypi)
2820        chis12 = chis1 * chis2
2821        sig1 = sigmap1(itypi,itypj)
2822        sig2 = sigmap2(itypi,itypj)
2823 c!       write (*,*) "sig1 = ", sig1
2824 c!       write (*,*) "sig2 = ", sig2
2825 c! alpha factors from Fcav/Gcav
2826        b1 = alphasur(1,itypi,itypj)
2827        b2 = alphasur(2,itypi,itypj)
2828        b3 = alphasur(3,itypi,itypj)
2829        b4 = alphasur(4,itypi,itypj)
2830 c! used to determine whether we want to do quadrupole calculations
2831        wqd = wquad(itypi, itypj)
2832 c! used by Fgb
2833        eps_in = epsintab(itypi,itypj)
2834        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2835 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2836 c!-------------------------------------------------------------------
2837 c! tail location and distance calculations
2838        Rtail = 0.0d0
2839        DO k = 1, 3
2840         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2841         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2842        END DO
2843 c! tail distances will be themselves usefull elswhere
2844 c1 (in Gcav, for example)
2845        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2846        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2847        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2848        Rtail = dsqrt(
2849      &     (Rtail_distance(1)*Rtail_distance(1))
2850      &   + (Rtail_distance(2)*Rtail_distance(2))
2851      &   + (Rtail_distance(3)*Rtail_distance(3)))
2852 c!-------------------------------------------------------------------
2853 c! Calculate location and distance between polar heads
2854 c! distance between heads
2855 c! for each one of our three dimensional space...
2856        DO k = 1,3
2857 c! location of polar head is computed by taking hydrophobic centre
2858 c! and moving by a d1 * dc_norm vector
2859 c! see unres publications for very informative images
2860         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2861         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2862 c! distance
2863 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2864 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2865         Rhead_distance(k) = chead(k,2) - chead(k,1)
2866        END DO
2867 c! pitagoras (root of sum of squares)
2868        Rhead = dsqrt(
2869      &     (Rhead_distance(1)*Rhead_distance(1))
2870      &   + (Rhead_distance(2)*Rhead_distance(2))
2871      &   + (Rhead_distance(3)*Rhead_distance(3)))
2872 c!-------------------------------------------------------------------
2873 c! zero everything that should be zero'ed
2874        Egb = 0.0d0
2875        ECL = 0.0d0
2876        Elj = 0.0d0
2877        Equad = 0.0d0
2878        Epol = 0.0d0
2879        eheadtail = 0.0d0
2880        dGCLdOM1 = 0.0d0
2881        dGCLdOM2 = 0.0d0
2882        dGCLdOM12 = 0.0d0
2883        dPOLdOM1 = 0.0d0
2884        dPOLdOM2 = 0.0d0
2885        RETURN
2886       END SUBROUTINE elgrad_init
2887
2888
2889 C-----------------------------------------------------------------------------
2890       subroutine sc_angular
2891 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2892 C om12. Called by ebp, egb, and egbv.
2893       implicit none
2894       include 'COMMON.CALC'
2895       erij(1)=xj*rij
2896       erij(2)=yj*rij
2897       erij(3)=zj*rij
2898       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2899       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2900       om12=dxi*dxj+dyi*dyj+dzi*dzj
2901       chiom12=chi12*om12
2902 C Calculate eps1(om12) and its derivative in om12
2903       faceps1=1.0D0-om12*chiom12
2904       faceps1_inv=1.0D0/faceps1
2905       eps1=dsqrt(faceps1_inv)
2906 C Following variable is eps1*deps1/dom12
2907       eps1_om12=faceps1_inv*chiom12
2908 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2909 C and om12.
2910       om1om2=om1*om2
2911       chiom1=chi1*om1
2912       chiom2=chi2*om2
2913       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2914       sigsq=1.0D0-facsig*faceps1_inv
2915       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2916       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2917       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2918 C Calculate eps2 and its derivatives in om1, om2, and om12.
2919       chipom1=chip1*om1
2920       chipom2=chip2*om2
2921       chipom12=chip12*om12
2922       facp=1.0D0-om12*chipom12
2923       facp_inv=1.0D0/facp
2924       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2925 C Following variable is the square root of eps2
2926       eps2rt=1.0D0-facp1*facp_inv
2927 C Following three variables are the derivatives of the square root of eps
2928 C in om1, om2, and om12.
2929       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2930       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2931       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2932 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2933       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2934 C Calculate whole angle-dependent part of epsilon and contributions
2935 C to its derivatives
2936       return
2937       end
2938 C----------------------------------------------------------------------------
2939       subroutine sc_grad
2940       implicit real*8 (a-h,o-z)
2941       include 'DIMENSIONS'
2942       include 'DIMENSIONS.ZSCOPT'
2943       include 'COMMON.CHAIN'
2944       include 'COMMON.DERIV'
2945       include 'COMMON.CALC'
2946       double precision dcosom1(3),dcosom2(3)
2947       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2948       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2949       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2950      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2951       do k=1,3
2952         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2953         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2954       enddo
2955       do k=1,3
2956         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2957       enddo
2958       do k=1,3
2959         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2960      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2961      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2962         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2963      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2964      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2965       enddo
2966 C
2967 C Calculate the components of the gradient in DC and X
2968 C
2969 c      do k=i,j-1
2970 c        do l=1,3
2971 c          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2972 c        enddo
2973 c      enddo
2974       do l=1,3
2975         gvdwc(l,i)=gvdwc(l,i)-gg(l)!+gg_lipi(l)
2976         gvdwc(l,j)=gvdwc(l,j)+gg(l)!+gg_lipj(l)
2977       enddo
2978
2979       return
2980       end
2981 c------------------------------------------------------------------------------
2982       subroutine vec_and_deriv
2983       implicit real*8 (a-h,o-z)
2984       include 'DIMENSIONS'
2985       include 'DIMENSIONS.ZSCOPT'
2986       include 'COMMON.IOUNITS'
2987       include 'COMMON.GEO'
2988       include 'COMMON.VAR'
2989       include 'COMMON.LOCAL'
2990       include 'COMMON.CHAIN'
2991       include 'COMMON.VECTORS'
2992       include 'COMMON.DERIV'
2993       include 'COMMON.INTERACT'
2994       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2995 C Compute the local reference systems. For reference system (i), the
2996 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2997 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2998       do i=1,nres-1
2999 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
3000           if (i.eq.nres-1) then
3001 C Case of the last full residue
3002 C Compute the Z-axis
3003             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3004             costh=dcos(pi-theta(nres))
3005             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3006             do k=1,3
3007               uz(k,i)=fac*uz(k,i)
3008             enddo
3009             if (calc_grad) then
3010 C Compute the derivatives of uz
3011             uzder(1,1,1)= 0.0d0
3012             uzder(2,1,1)=-dc_norm(3,i-1)
3013             uzder(3,1,1)= dc_norm(2,i-1)
3014             uzder(1,2,1)= dc_norm(3,i-1)
3015             uzder(2,2,1)= 0.0d0
3016             uzder(3,2,1)=-dc_norm(1,i-1)
3017             uzder(1,3,1)=-dc_norm(2,i-1)
3018             uzder(2,3,1)= dc_norm(1,i-1)
3019             uzder(3,3,1)= 0.0d0
3020             uzder(1,1,2)= 0.0d0
3021             uzder(2,1,2)= dc_norm(3,i)
3022             uzder(3,1,2)=-dc_norm(2,i)
3023             uzder(1,2,2)=-dc_norm(3,i)
3024             uzder(2,2,2)= 0.0d0
3025             uzder(3,2,2)= dc_norm(1,i)
3026             uzder(1,3,2)= dc_norm(2,i)
3027             uzder(2,3,2)=-dc_norm(1,i)
3028             uzder(3,3,2)= 0.0d0
3029             endif
3030 C Compute the Y-axis
3031             facy=fac
3032             do k=1,3
3033               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3034             enddo
3035             if (calc_grad) then
3036 C Compute the derivatives of uy
3037             do j=1,3
3038               do k=1,3
3039                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3040      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3041                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3042               enddo
3043               uyder(j,j,1)=uyder(j,j,1)-costh
3044               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3045             enddo
3046             do j=1,2
3047               do k=1,3
3048                 do l=1,3
3049                   uygrad(l,k,j,i)=uyder(l,k,j)
3050                   uzgrad(l,k,j,i)=uzder(l,k,j)
3051                 enddo
3052               enddo
3053             enddo
3054             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3055             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3056             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3057             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3058             endif
3059           else
3060 C Other residues
3061 C Compute the Z-axis
3062             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3063             costh=dcos(pi-theta(i+2))
3064             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3065             do k=1,3
3066               uz(k,i)=fac*uz(k,i)
3067             enddo
3068             if (calc_grad) then
3069 C Compute the derivatives of uz
3070             uzder(1,1,1)= 0.0d0
3071             uzder(2,1,1)=-dc_norm(3,i+1)
3072             uzder(3,1,1)= dc_norm(2,i+1)
3073             uzder(1,2,1)= dc_norm(3,i+1)
3074             uzder(2,2,1)= 0.0d0
3075             uzder(3,2,1)=-dc_norm(1,i+1)
3076             uzder(1,3,1)=-dc_norm(2,i+1)
3077             uzder(2,3,1)= dc_norm(1,i+1)
3078             uzder(3,3,1)= 0.0d0
3079             uzder(1,1,2)= 0.0d0
3080             uzder(2,1,2)= dc_norm(3,i)
3081             uzder(3,1,2)=-dc_norm(2,i)
3082             uzder(1,2,2)=-dc_norm(3,i)
3083             uzder(2,2,2)= 0.0d0
3084             uzder(3,2,2)= dc_norm(1,i)
3085             uzder(1,3,2)= dc_norm(2,i)
3086             uzder(2,3,2)=-dc_norm(1,i)
3087             uzder(3,3,2)= 0.0d0
3088             endif
3089 C Compute the Y-axis
3090             facy=fac
3091             do k=1,3
3092               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3093             enddo
3094             if (calc_grad) then
3095 C Compute the derivatives of uy
3096             do j=1,3
3097               do k=1,3
3098                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3099      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3100                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3101               enddo
3102               uyder(j,j,1)=uyder(j,j,1)-costh
3103               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3104             enddo
3105             do j=1,2
3106               do k=1,3
3107                 do l=1,3
3108                   uygrad(l,k,j,i)=uyder(l,k,j)
3109                   uzgrad(l,k,j,i)=uzder(l,k,j)
3110                 enddo
3111               enddo
3112             enddo
3113             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3114             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3115             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3116             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3117           endif
3118           endif
3119       enddo
3120       if (calc_grad) then
3121       do i=1,nres-1
3122         vbld_inv_temp(1)=vbld_inv(i+1)
3123         if (i.lt.nres-1) then
3124           vbld_inv_temp(2)=vbld_inv(i+2)
3125         else
3126           vbld_inv_temp(2)=vbld_inv(i)
3127         endif
3128         do j=1,2
3129           do k=1,3
3130             do l=1,3
3131               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3132               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3133             enddo
3134           enddo
3135         enddo
3136       enddo
3137       endif
3138       return
3139       end
3140 c------------------------------------------------------------------------------
3141       subroutine set_matrices
3142       implicit real*8 (a-h,o-z)
3143       include 'DIMENSIONS'
3144 #ifdef MPI
3145       include "mpif.h"
3146       integer IERR
3147       integer status(MPI_STATUS_SIZE)
3148 #endif
3149       include 'DIMENSIONS.ZSCOPT'
3150       include 'COMMON.IOUNITS'
3151       include 'COMMON.GEO'
3152       include 'COMMON.VAR'
3153       include 'COMMON.LOCAL'
3154       include 'COMMON.CHAIN'
3155       include 'COMMON.DERIV'
3156       include 'COMMON.INTERACT'
3157       include 'COMMON.CONTACTS'
3158       include 'COMMON.TORSION'
3159       include 'COMMON.VECTORS'
3160       include 'COMMON.FFIELD'
3161       double precision auxvec(2),auxmat(2,2)
3162 C
3163 C Compute the virtual-bond-torsional-angle dependent quantities needed
3164 C to calculate the el-loc multibody terms of various order.
3165 C
3166 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3167       do i=3,nres+1
3168         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3169           iti = itype2loc(itype(i-2))
3170         else
3171           iti=nloctyp
3172         endif
3173 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3174         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3175           iti1 = itype2loc(itype(i-1))
3176         else
3177           iti1=nloctyp
3178         endif
3179 #ifdef NEWCORR
3180         cost1=dcos(theta(i-1))
3181         sint1=dsin(theta(i-1))
3182         sint1sq=sint1*sint1
3183         sint1cub=sint1sq*sint1
3184         sint1cost1=2*sint1*cost1
3185 #ifdef DEBUG
3186         write (iout,*) "bnew1",i,iti
3187         write (iout,*) (bnew1(k,1,iti),k=1,3)
3188         write (iout,*) (bnew1(k,2,iti),k=1,3)
3189         write (iout,*) "bnew2",i,iti
3190         write (iout,*) (bnew2(k,1,iti),k=1,3)
3191         write (iout,*) (bnew2(k,2,iti),k=1,3)
3192 #endif
3193         do k=1,2
3194           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3195           b1(k,i-2)=sint1*b1k
3196           gtb1(k,i-2)=cost1*b1k-sint1sq*
3197      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3198           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3199           b2(k,i-2)=sint1*b2k
3200           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3201      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3202         enddo
3203         do k=1,2
3204           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3205           cc(1,k,i-2)=sint1sq*aux
3206           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3207      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3208           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3209           dd(1,k,i-2)=sint1sq*aux
3210           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3211      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3212         enddo
3213         cc(2,1,i-2)=cc(1,2,i-2)
3214         cc(2,2,i-2)=-cc(1,1,i-2)
3215         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3216         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3217         dd(2,1,i-2)=dd(1,2,i-2)
3218         dd(2,2,i-2)=-dd(1,1,i-2)
3219         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3220         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3221         do k=1,2
3222           do l=1,2
3223             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3224             EE(l,k,i-2)=sint1sq*aux
3225             if (calc_grad)
3226      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3227           enddo
3228         enddo
3229         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3230         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3231         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3232         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3233         if (calc_grad) then
3234         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3235         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3236         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3237         endif
3238 c        b1tilde(1,i-2)=b1(1,i-2)
3239 c        b1tilde(2,i-2)=-b1(2,i-2)
3240 c        b2tilde(1,i-2)=b2(1,i-2)
3241 c        b2tilde(2,i-2)=-b2(2,i-2)
3242 #ifdef DEBUG
3243         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3244         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3245         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3246         write (iout,*) 'theta=', theta(i-1)
3247 #endif
3248 #else
3249         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3250           iti = itype2loc(itype(i-2))
3251         else
3252           iti=nloctyp
3253         endif
3254 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3255         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3256           iti1 = itype2loc(itype(i-1))
3257         else
3258           iti1=nloctyp
3259         endif
3260         b1(1,i-2)=b(3,iti)
3261         b1(2,i-2)=b(5,iti)
3262         b2(1,i-2)=b(2,iti)
3263         b2(2,i-2)=b(4,iti)
3264         do k=1,2
3265           do l=1,2
3266            CC(k,l,i-2)=ccold(k,l,iti)
3267            DD(k,l,i-2)=ddold(k,l,iti)
3268            EE(k,l,i-2)=eeold(k,l,iti)
3269           enddo
3270         enddo
3271 #endif
3272         b1tilde(1,i-2)= b1(1,i-2)
3273         b1tilde(2,i-2)=-b1(2,i-2)
3274         b2tilde(1,i-2)= b2(1,i-2)
3275         b2tilde(2,i-2)=-b2(2,i-2)
3276 c
3277         Ctilde(1,1,i-2)= CC(1,1,i-2)
3278         Ctilde(1,2,i-2)= CC(1,2,i-2)
3279         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3280         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3281 c
3282         Dtilde(1,1,i-2)= DD(1,1,i-2)
3283         Dtilde(1,2,i-2)= DD(1,2,i-2)
3284         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3285         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3286 c        write(iout,*) "i",i," iti",iti
3287 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3288 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3289       enddo
3290       do i=3,nres+1
3291         if (i .lt. nres+1) then
3292           sin1=dsin(phi(i))
3293           cos1=dcos(phi(i))
3294           sintab(i-2)=sin1
3295           costab(i-2)=cos1
3296           obrot(1,i-2)=cos1
3297           obrot(2,i-2)=sin1
3298           sin2=dsin(2*phi(i))
3299           cos2=dcos(2*phi(i))
3300           sintab2(i-2)=sin2
3301           costab2(i-2)=cos2
3302           obrot2(1,i-2)=cos2
3303           obrot2(2,i-2)=sin2
3304           Ug(1,1,i-2)=-cos1
3305           Ug(1,2,i-2)=-sin1
3306           Ug(2,1,i-2)=-sin1
3307           Ug(2,2,i-2)= cos1
3308           Ug2(1,1,i-2)=-cos2
3309           Ug2(1,2,i-2)=-sin2
3310           Ug2(2,1,i-2)=-sin2
3311           Ug2(2,2,i-2)= cos2
3312         else
3313           costab(i-2)=1.0d0
3314           sintab(i-2)=0.0d0
3315           obrot(1,i-2)=1.0d0
3316           obrot(2,i-2)=0.0d0
3317           obrot2(1,i-2)=0.0d0
3318           obrot2(2,i-2)=0.0d0
3319           Ug(1,1,i-2)=1.0d0
3320           Ug(1,2,i-2)=0.0d0
3321           Ug(2,1,i-2)=0.0d0
3322           Ug(2,2,i-2)=1.0d0
3323           Ug2(1,1,i-2)=0.0d0
3324           Ug2(1,2,i-2)=0.0d0
3325           Ug2(2,1,i-2)=0.0d0
3326           Ug2(2,2,i-2)=0.0d0
3327         endif
3328         if (i .gt. 3 .and. i .lt. nres+1) then
3329           obrot_der(1,i-2)=-sin1
3330           obrot_der(2,i-2)= cos1
3331           Ugder(1,1,i-2)= sin1
3332           Ugder(1,2,i-2)=-cos1
3333           Ugder(2,1,i-2)=-cos1
3334           Ugder(2,2,i-2)=-sin1
3335           dwacos2=cos2+cos2
3336           dwasin2=sin2+sin2
3337           obrot2_der(1,i-2)=-dwasin2
3338           obrot2_der(2,i-2)= dwacos2
3339           Ug2der(1,1,i-2)= dwasin2
3340           Ug2der(1,2,i-2)=-dwacos2
3341           Ug2der(2,1,i-2)=-dwacos2
3342           Ug2der(2,2,i-2)=-dwasin2
3343         else
3344           obrot_der(1,i-2)=0.0d0
3345           obrot_der(2,i-2)=0.0d0
3346           Ugder(1,1,i-2)=0.0d0
3347           Ugder(1,2,i-2)=0.0d0
3348           Ugder(2,1,i-2)=0.0d0
3349           Ugder(2,2,i-2)=0.0d0
3350           obrot2_der(1,i-2)=0.0d0
3351           obrot2_der(2,i-2)=0.0d0
3352           Ug2der(1,1,i-2)=0.0d0
3353           Ug2der(1,2,i-2)=0.0d0
3354           Ug2der(2,1,i-2)=0.0d0
3355           Ug2der(2,2,i-2)=0.0d0
3356         endif
3357 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3358         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3359           iti = itype2loc(itype(i-2))
3360         else
3361           iti=nloctyp
3362         endif
3363 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3364         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3365           iti1 = itype2loc(itype(i-1))
3366         else
3367           iti1=nloctyp
3368         endif
3369 cd        write (iout,*) '*******i',i,' iti1',iti
3370 cd        write (iout,*) 'b1',b1(:,iti)
3371 cd        write (iout,*) 'b2',b2(:,iti)
3372 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3373 c        if (i .gt. iatel_s+2) then
3374         if (i .gt. nnt+2) then
3375           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3376 #ifdef NEWCORR
3377           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3378 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3379 #endif
3380 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3381 c     &    EE(1,2,iti),EE(2,2,i)
3382           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3383           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3384 c          write(iout,*) "Macierz EUG",
3385 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3386 c     &    eug(2,2,i-2)
3387           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3388      &    then
3389           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3390           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3391           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3392           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3393           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3394           endif
3395         else
3396           do k=1,2
3397             Ub2(k,i-2)=0.0d0
3398             Ctobr(k,i-2)=0.0d0
3399             Dtobr2(k,i-2)=0.0d0
3400             do l=1,2
3401               EUg(l,k,i-2)=0.0d0
3402               CUg(l,k,i-2)=0.0d0
3403               DUg(l,k,i-2)=0.0d0
3404               DtUg2(l,k,i-2)=0.0d0
3405             enddo
3406           enddo
3407         endif
3408         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3409         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3410         do k=1,2
3411           muder(k,i-2)=Ub2der(k,i-2)
3412         enddo
3413 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3414         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3415           if (itype(i-1).le.ntyp) then
3416             iti1 = itype2loc(itype(i-1))
3417           else
3418             iti1=nloctyp
3419           endif
3420         else
3421           iti1=nloctyp
3422         endif
3423         do k=1,2
3424           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3425         enddo
3426 #ifdef MUOUT
3427         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3428      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3429      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3430      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3431      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3432      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3433 #endif
3434 cd        write (iout,*) 'mu1',mu1(:,i-2)
3435 cd        write (iout,*) 'mu2',mu2(:,i-2)
3436         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3437      &  then
3438         if (calc_grad) then
3439         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3440         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3441         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3442         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3443         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3444         endif
3445 C Vectors and matrices dependent on a single virtual-bond dihedral.
3446         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3447         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3448         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3449         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3450         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3451         if (calc_grad) then
3452         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3453         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3454         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3455         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3456         endif
3457         endif
3458       enddo
3459 C Matrices dependent on two consecutive virtual-bond dihedrals.
3460 C The order of matrices is from left to right.
3461       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3462      &then
3463       do i=2,nres-1
3464         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3465         if (calc_grad) then
3466         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3467         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3468         endif
3469         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3470         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3471         if (calc_grad) then
3472         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3473         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3474         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3475         endif
3476       enddo
3477       endif
3478       return
3479       end
3480 C--------------------------------------------------------------------------
3481       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3482 C
3483 C This subroutine calculates the average interaction energy and its gradient
3484 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3485 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3486 C The potential depends both on the distance of peptide-group centers and on
3487 C the orientation of the CA-CA virtual bonds.
3488 C
3489       implicit real*8 (a-h,o-z)
3490 #ifdef MPI
3491       include 'mpif.h'
3492 #endif
3493       include 'DIMENSIONS'
3494       include 'DIMENSIONS.ZSCOPT'
3495       include 'COMMON.CONTROL'
3496       include 'COMMON.IOUNITS'
3497       include 'COMMON.GEO'
3498       include 'COMMON.VAR'
3499       include 'COMMON.LOCAL'
3500       include 'COMMON.CHAIN'
3501       include 'COMMON.DERIV'
3502       include 'COMMON.INTERACT'
3503       include 'COMMON.CONTACTS'
3504       include 'COMMON.TORSION'
3505       include 'COMMON.VECTORS'
3506       include 'COMMON.FFIELD'
3507       include 'COMMON.TIME1'
3508       include 'COMMON.SPLITELE'
3509       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3510      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3511       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3512      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3514      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3515      &    num_conti,j1,j2
3516 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3517 #ifdef MOMENT
3518       double precision scal_el /1.0d0/
3519 #else
3520       double precision scal_el /0.5d0/
3521 #endif
3522 C 12/13/98
3523 C 13-go grudnia roku pamietnego...
3524       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3525      &                   0.0d0,1.0d0,0.0d0,
3526      &                   0.0d0,0.0d0,1.0d0/
3527 cd      write(iout,*) 'In EELEC'
3528 cd      do i=1,nloctyp
3529 cd        write(iout,*) 'Type',i
3530 cd        write(iout,*) 'B1',B1(:,i)
3531 cd        write(iout,*) 'B2',B2(:,i)
3532 cd        write(iout,*) 'CC',CC(:,:,i)
3533 cd        write(iout,*) 'DD',DD(:,:,i)
3534 cd        write(iout,*) 'EE',EE(:,:,i)
3535 cd      enddo
3536 cd      call check_vecgrad
3537 cd      stop
3538       if (icheckgrad.eq.1) then
3539         do i=1,nres-1
3540           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3541           do k=1,3
3542             dc_norm(k,i)=dc(k,i)*fac
3543           enddo
3544 c          write (iout,*) 'i',i,' fac',fac
3545         enddo
3546       endif
3547       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3548      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3549      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3550 c        call vec_and_deriv
3551 #ifdef TIMING
3552         time01=MPI_Wtime()
3553 #endif
3554         call set_matrices
3555 #ifdef TIMING
3556         time_mat=time_mat+MPI_Wtime()-time01
3557 #endif
3558       endif
3559 cd      do i=1,nres-1
3560 cd        write (iout,*) 'i=',i
3561 cd        do k=1,3
3562 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3563 cd        enddo
3564 cd        do k=1,3
3565 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3566 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3567 cd        enddo
3568 cd      enddo
3569       t_eelecij=0.0d0
3570       ees=0.0D0
3571       evdw1=0.0D0
3572       eel_loc=0.0d0
3573       eello_turn3=0.0d0
3574       eello_turn4=0.0d0
3575       ind=0
3576       do i=1,nres
3577         num_cont_hb(i)=0
3578       enddo
3579 cd      print '(a)','Enter EELEC'
3580 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3581       do i=1,nres
3582         gel_loc_loc(i)=0.0d0
3583         gcorr_loc(i)=0.0d0
3584       enddo
3585 c
3586 c
3587 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3588 C
3589 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3590 C
3591 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3592       do i=iturn3_start,iturn3_end
3593 c        if (i.le.1) cycle
3594 C        write(iout,*) "tu jest i",i
3595         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3596 C changes suggested by Ana to avoid out of bounds
3597 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3598 c     & .or.((i+4).gt.nres)
3599 c     & .or.((i-1).le.0)
3600 C end of changes by Ana
3601 C dobra zmiana wycofana
3602      &  .or. itype(i+2).eq.ntyp1
3603      &  .or. itype(i+3).eq.ntyp1) cycle
3604 C Adam: Instructions below will switch off existing interactions
3605 c        if(i.gt.1)then
3606 c          if(itype(i-1).eq.ntyp1)cycle
3607 c        end if
3608 c        if(i.LT.nres-3)then
3609 c          if (itype(i+4).eq.ntyp1) cycle
3610 c        end if
3611         dxi=dc(1,i)
3612         dyi=dc(2,i)
3613         dzi=dc(3,i)
3614         dx_normi=dc_norm(1,i)
3615         dy_normi=dc_norm(2,i)
3616         dz_normi=dc_norm(3,i)
3617         xmedi=c(1,i)+0.5d0*dxi
3618         ymedi=c(2,i)+0.5d0*dyi
3619         zmedi=c(3,i)+0.5d0*dzi
3620           xmedi=mod(xmedi,boxxsize)
3621           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3622           ymedi=mod(ymedi,boxysize)
3623           if (ymedi.lt.0) ymedi=ymedi+boxysize
3624           zmedi=mod(zmedi,boxzsize)
3625           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3626         num_conti=0
3627         call eelecij(i,i+2,ees,evdw1,eel_loc)
3628         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3629         num_cont_hb(i)=num_conti
3630       enddo
3631       do i=iturn4_start,iturn4_end
3632         if (i.lt.1) cycle
3633         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3634 C changes suggested by Ana to avoid out of bounds
3635 c     & .or.((i+5).gt.nres)
3636 c     & .or.((i-1).le.0)
3637 C end of changes suggested by Ana
3638      &    .or. itype(i+3).eq.ntyp1
3639      &    .or. itype(i+4).eq.ntyp1
3640 c     &    .or. itype(i+5).eq.ntyp1
3641 c     &    .or. itype(i).eq.ntyp1
3642 c     &    .or. itype(i-1).eq.ntyp1
3643      &                             ) cycle
3644         dxi=dc(1,i)
3645         dyi=dc(2,i)
3646         dzi=dc(3,i)
3647         dx_normi=dc_norm(1,i)
3648         dy_normi=dc_norm(2,i)
3649         dz_normi=dc_norm(3,i)
3650         xmedi=c(1,i)+0.5d0*dxi
3651         ymedi=c(2,i)+0.5d0*dyi
3652         zmedi=c(3,i)+0.5d0*dzi
3653 C Return atom into box, boxxsize is size of box in x dimension
3654 c  194   continue
3655 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3656 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3657 C Condition for being inside the proper box
3658 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3659 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3660 c        go to 194
3661 c        endif
3662 c  195   continue
3663 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3664 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3665 C Condition for being inside the proper box
3666 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3667 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3668 c        go to 195
3669 c        endif
3670 c  196   continue
3671 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3672 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3673 C Condition for being inside the proper box
3674 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3675 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3676 c        go to 196
3677 c        endif
3678           xmedi=mod(xmedi,boxxsize)
3679           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3680           ymedi=mod(ymedi,boxysize)
3681           if (ymedi.lt.0) ymedi=ymedi+boxysize
3682           zmedi=mod(zmedi,boxzsize)
3683           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3684
3685         num_conti=num_cont_hb(i)
3686 c        write(iout,*) "JESTEM W PETLI"
3687         call eelecij(i,i+3,ees,evdw1,eel_loc)
3688         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3689      &   call eturn4(i,eello_turn4)
3690         num_cont_hb(i)=num_conti
3691       enddo   ! i
3692 C Loop over all neighbouring boxes
3693 C      do xshift=-1,1
3694 C      do yshift=-1,1
3695 C      do zshift=-1,1
3696 c
3697 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3698 c
3699 CTU KURWA
3700       do i=iatel_s,iatel_e
3701 C        do i=75,75
3702 c        if (i.le.1) cycle
3703         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3704 C changes suggested by Ana to avoid out of bounds
3705 c     & .or.((i+2).gt.nres)
3706 c     & .or.((i-1).le.0)
3707 C end of changes by Ana
3708 c     &  .or. itype(i+2).eq.ntyp1
3709 c     &  .or. itype(i-1).eq.ntyp1
3710      &                ) cycle
3711         dxi=dc(1,i)
3712         dyi=dc(2,i)
3713         dzi=dc(3,i)
3714         dx_normi=dc_norm(1,i)
3715         dy_normi=dc_norm(2,i)
3716         dz_normi=dc_norm(3,i)
3717         xmedi=c(1,i)+0.5d0*dxi
3718         ymedi=c(2,i)+0.5d0*dyi
3719         zmedi=c(3,i)+0.5d0*dzi
3720           xmedi=mod(xmedi,boxxsize)
3721           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3722           ymedi=mod(ymedi,boxysize)
3723           if (ymedi.lt.0) ymedi=ymedi+boxysize
3724           zmedi=mod(zmedi,boxzsize)
3725           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3726 C          xmedi=xmedi+xshift*boxxsize
3727 C          ymedi=ymedi+yshift*boxysize
3728 C          zmedi=zmedi+zshift*boxzsize
3729
3730 C Return tom into box, boxxsize is size of box in x dimension
3731 c  164   continue
3732 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3733 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3734 C Condition for being inside the proper box
3735 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3736 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3737 c        go to 164
3738 c        endif
3739 c  165   continue
3740 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3741 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3742 C Condition for being inside the proper box
3743 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3744 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3745 c        go to 165
3746 c        endif
3747 c  166   continue
3748 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3749 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3750 cC Condition for being inside the proper box
3751 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3752 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3753 c        go to 166
3754 c        endif
3755
3756 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3757         num_conti=num_cont_hb(i)
3758 C I TU KURWA
3759         do j=ielstart(i),ielend(i)
3760 C          do j=16,17
3761 C          write (iout,*) i,j
3762 C         if (j.le.1) cycle
3763           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3764 C changes suggested by Ana to avoid out of bounds
3765 c     & .or.((j+2).gt.nres)
3766 c     & .or.((j-1).le.0)
3767 C end of changes by Ana
3768 c     & .or.itype(j+2).eq.ntyp1
3769 c     & .or.itype(j-1).eq.ntyp1
3770      &) cycle
3771           call eelecij(i,j,ees,evdw1,eel_loc)
3772         enddo ! j
3773         num_cont_hb(i)=num_conti
3774       enddo   ! i
3775 C     enddo   ! zshift
3776 C      enddo   ! yshift
3777 C      enddo   ! xshift
3778
3779 c      write (iout,*) "Number of loop steps in EELEC:",ind
3780 cd      do i=1,nres
3781 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3782 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3783 cd      enddo
3784 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3785 ccc      eel_loc=eel_loc+eello_turn3
3786 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3787       return
3788       end
3789 C-------------------------------------------------------------------------------
3790       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3791       implicit real*8 (a-h,o-z)
3792       include 'DIMENSIONS'
3793       include 'DIMENSIONS.ZSCOPT'
3794 #ifdef MPI
3795       include "mpif.h"
3796 #endif
3797       include 'COMMON.CONTROL'
3798       include 'COMMON.IOUNITS'
3799       include 'COMMON.GEO'
3800       include 'COMMON.VAR'
3801       include 'COMMON.LOCAL'
3802       include 'COMMON.CHAIN'
3803       include 'COMMON.DERIV'
3804       include 'COMMON.INTERACT'
3805       include 'COMMON.CONTACTS'
3806       include 'COMMON.TORSION'
3807       include 'COMMON.VECTORS'
3808       include 'COMMON.FFIELD'
3809       include 'COMMON.TIME1'
3810       include 'COMMON.SPLITELE'
3811       include 'COMMON.SHIELD'
3812       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3813      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3814       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3815      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3816      &    gmuij2(4),gmuji2(4)
3817       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3818      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3819      &    num_conti,j1,j2
3820 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3821 #ifdef MOMENT
3822       double precision scal_el /1.0d0/
3823 #else
3824       double precision scal_el /0.5d0/
3825 #endif
3826 C 12/13/98
3827 C 13-go grudnia roku pamietnego...
3828       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3829      &                   0.0d0,1.0d0,0.0d0,
3830      &                   0.0d0,0.0d0,1.0d0/
3831        integer xshift,yshift,zshift
3832 c          time00=MPI_Wtime()
3833 cd      write (iout,*) "eelecij",i,j
3834 c          ind=ind+1
3835           iteli=itel(i)
3836           itelj=itel(j)
3837           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3838           aaa=app(iteli,itelj)
3839           bbb=bpp(iteli,itelj)
3840           ael6i=ael6(iteli,itelj)
3841           ael3i=ael3(iteli,itelj)
3842           dxj=dc(1,j)
3843           dyj=dc(2,j)
3844           dzj=dc(3,j)
3845           dx_normj=dc_norm(1,j)
3846           dy_normj=dc_norm(2,j)
3847           dz_normj=dc_norm(3,j)
3848 C          xj=c(1,j)+0.5D0*dxj-xmedi
3849 C          yj=c(2,j)+0.5D0*dyj-ymedi
3850 C          zj=c(3,j)+0.5D0*dzj-zmedi
3851           xj=c(1,j)+0.5D0*dxj
3852           yj=c(2,j)+0.5D0*dyj
3853           zj=c(3,j)+0.5D0*dzj
3854           xj=mod(xj,boxxsize)
3855           if (xj.lt.0) xj=xj+boxxsize
3856           yj=mod(yj,boxysize)
3857           if (yj.lt.0) yj=yj+boxysize
3858           zj=mod(zj,boxzsize)
3859           if (zj.lt.0) zj=zj+boxzsize
3860           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3861       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3862       xj_safe=xj
3863       yj_safe=yj
3864       zj_safe=zj
3865       isubchap=0
3866       do xshift=-1,1
3867       do yshift=-1,1
3868       do zshift=-1,1
3869           xj=xj_safe+xshift*boxxsize
3870           yj=yj_safe+yshift*boxysize
3871           zj=zj_safe+zshift*boxzsize
3872           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3873           if(dist_temp.lt.dist_init) then
3874             dist_init=dist_temp
3875             xj_temp=xj
3876             yj_temp=yj
3877             zj_temp=zj
3878             isubchap=1
3879           endif
3880        enddo
3881        enddo
3882        enddo
3883        if (isubchap.eq.1) then
3884           xj=xj_temp-xmedi
3885           yj=yj_temp-ymedi
3886           zj=zj_temp-zmedi
3887        else
3888           xj=xj_safe-xmedi
3889           yj=yj_safe-ymedi
3890           zj=zj_safe-zmedi
3891        endif
3892 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3893 c  174   continue
3894 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3895 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3896 C Condition for being inside the proper box
3897 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3898 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3899 c        go to 174
3900 c        endif
3901 c  175   continue
3902 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3903 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3904 C Condition for being inside the proper box
3905 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3906 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3907 c        go to 175
3908 c        endif
3909 c  176   continue
3910 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3911 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3912 C Condition for being inside the proper box
3913 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3914 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3915 c        go to 176
3916 c        endif
3917 C        endif !endPBC condintion
3918 C        xj=xj-xmedi
3919 C        yj=yj-ymedi
3920 C        zj=zj-zmedi
3921           rij=xj*xj+yj*yj+zj*zj
3922
3923             sss=sscale(sqrt(rij))
3924             sssgrad=sscagrad(sqrt(rij))
3925 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3926 c     &       " rlamb",rlamb," sss",sss
3927 c            if (sss.gt.0.0d0) then
3928           rrmij=1.0D0/rij
3929           rij=dsqrt(rij)
3930           rmij=1.0D0/rij
3931           r3ij=rrmij*rmij
3932           r6ij=r3ij*r3ij
3933           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3934           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3935           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3936           fac=cosa-3.0D0*cosb*cosg
3937           ev1=aaa*r6ij*r6ij
3938 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3939           if (j.eq.i+2) ev1=scal_el*ev1
3940           ev2=bbb*r6ij
3941           fac3=ael6i*r6ij
3942           fac4=ael3i*r3ij
3943           evdwij=(ev1+ev2)
3944           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3945           el2=fac4*fac
3946 C MARYSIA
3947 C          eesij=(el1+el2)
3948 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3949           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3950           if (shield_mode.gt.0) then
3951 C          fac_shield(i)=0.4
3952 C          fac_shield(j)=0.6
3953           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3954           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3955           eesij=(el1+el2)
3956           ees=ees+eesij
3957           else
3958           fac_shield(i)=1.0
3959           fac_shield(j)=1.0
3960           eesij=(el1+el2)
3961           ees=ees+eesij
3962           endif
3963           evdw1=evdw1+evdwij*sss
3964 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3965 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3966 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3967 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3968
3969           if (energy_dec) then
3970               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3971      &'evdw1',i,j,evdwij
3972      &,iteli,itelj,aaa,evdw1,sss
3973               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3974      &fac_shield(i),fac_shield(j)
3975           endif
3976
3977 C
3978 C Calculate contributions to the Cartesian gradient.
3979 C
3980 #ifdef SPLITELE
3981           facvdw=-6*rrmij*(ev1+evdwij)*sss
3982           facel=-3*rrmij*(el1+eesij)
3983           fac1=fac
3984           erij(1)=xj*rmij
3985           erij(2)=yj*rmij
3986           erij(3)=zj*rmij
3987
3988 *
3989 * Radial derivatives. First process both termini of the fragment (i,j)
3990 *
3991           if (calc_grad) then
3992           ggg(1)=facel*xj
3993           ggg(2)=facel*yj
3994           ggg(3)=facel*zj
3995           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3996      &  (shield_mode.gt.0)) then
3997 C          print *,i,j
3998           do ilist=1,ishield_list(i)
3999            iresshield=shield_list(ilist,i)
4000            do k=1,3
4001            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4002      &      *2.0
4003            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4004      &              rlocshield
4005      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4006             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4007 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4008 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4009 C             if (iresshield.gt.i) then
4010 C               do ishi=i+1,iresshield-1
4011 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4012 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4013 C
4014 C              enddo
4015 C             else
4016 C               do ishi=iresshield,i
4017 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4018 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4019 C
4020 C               enddo
4021 C              endif
4022            enddo
4023           enddo
4024           do ilist=1,ishield_list(j)
4025            iresshield=shield_list(ilist,j)
4026            do k=1,3
4027            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4028      &     *2.0
4029            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4030      &              rlocshield
4031      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4032            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4033
4034 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4035 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4036 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4037 C             if (iresshield.gt.j) then
4038 C               do ishi=j+1,iresshield-1
4039 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4040 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4041 C
4042 C               enddo
4043 C            else
4044 C               do ishi=iresshield,j
4045 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4046 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4047 C               enddo
4048 C              endif
4049            enddo
4050           enddo
4051
4052           do k=1,3
4053             gshieldc(k,i)=gshieldc(k,i)+
4054      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4055             gshieldc(k,j)=gshieldc(k,j)+
4056      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4057             gshieldc(k,i-1)=gshieldc(k,i-1)+
4058      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4059             gshieldc(k,j-1)=gshieldc(k,j-1)+
4060      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4061
4062            enddo
4063            endif
4064 c          do k=1,3
4065 c            ghalf=0.5D0*ggg(k)
4066 c            gelc(k,i)=gelc(k,i)+ghalf
4067 c            gelc(k,j)=gelc(k,j)+ghalf
4068 c          enddo
4069 c 9/28/08 AL Gradient compotents will be summed only at the end
4070 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4071           do k=1,3
4072             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4073 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4074             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4075 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4076 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4077 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4078 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4079 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4080           enddo
4081 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4082
4083 *
4084 * Loop over residues i+1 thru j-1.
4085 *
4086 cgrad          do k=i+1,j-1
4087 cgrad            do l=1,3
4088 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4089 cgrad            enddo
4090 cgrad          enddo
4091           if (sss.gt.0.0) then
4092           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4093           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4094           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4095           else
4096           ggg(1)=0.0
4097           ggg(2)=0.0
4098           ggg(3)=0.0
4099           endif
4100 c          do k=1,3
4101 c            ghalf=0.5D0*ggg(k)
4102 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4103 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4104 c          enddo
4105 c 9/28/08 AL Gradient compotents will be summed only at the end
4106           do k=1,3
4107             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4108             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4109           enddo
4110 *
4111 * Loop over residues i+1 thru j-1.
4112 *
4113 cgrad          do k=i+1,j-1
4114 cgrad            do l=1,3
4115 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4116 cgrad            enddo
4117 cgrad          enddo
4118           endif ! calc_grad
4119 #else
4120 C MARYSIA
4121           facvdw=(ev1+evdwij)*sss
4122           facel=(el1+eesij)
4123           fac1=fac
4124           fac=-3*rrmij*(facvdw+facvdw+facel)
4125           erij(1)=xj*rmij
4126           erij(2)=yj*rmij
4127           erij(3)=zj*rmij
4128 *
4129 * Radial derivatives. First process both termini of the fragment (i,j)
4130 *
4131           if (calc_grad) then
4132           ggg(1)=fac*xj
4133 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4134           ggg(2)=fac*yj
4135 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4136           ggg(3)=fac*zj
4137 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4138 c          do k=1,3
4139 c            ghalf=0.5D0*ggg(k)
4140 c            gelc(k,i)=gelc(k,i)+ghalf
4141 c            gelc(k,j)=gelc(k,j)+ghalf
4142 c          enddo
4143 c 9/28/08 AL Gradient compotents will be summed only at the end
4144           do k=1,3
4145             gelc_long(k,j)=gelc(k,j)+ggg(k)
4146             gelc_long(k,i)=gelc(k,i)-ggg(k)
4147           enddo
4148 *
4149 * Loop over residues i+1 thru j-1.
4150 *
4151 cgrad          do k=i+1,j-1
4152 cgrad            do l=1,3
4153 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4154 cgrad            enddo
4155 cgrad          enddo
4156 c 9/28/08 AL Gradient compotents will be summed only at the end
4157           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4158           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4159           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4160           do k=1,3
4161             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4162             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4163           enddo
4164           endif ! calc_grad
4165 #endif
4166 *
4167 * Angular part
4168 *
4169           if (calc_grad) then
4170           ecosa=2.0D0*fac3*fac1+fac4
4171           fac4=-3.0D0*fac4
4172           fac3=-6.0D0*fac3
4173           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4174           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4175           do k=1,3
4176             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4177             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4178           enddo
4179 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4180 cd   &          (dcosg(k),k=1,3)
4181           do k=1,3
4182             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4183      &      fac_shield(i)**2*fac_shield(j)**2
4184           enddo
4185 c          do k=1,3
4186 c            ghalf=0.5D0*ggg(k)
4187 c            gelc(k,i)=gelc(k,i)+ghalf
4188 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4189 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4190 c            gelc(k,j)=gelc(k,j)+ghalf
4191 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4192 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4193 c          enddo
4194 cgrad          do k=i+1,j-1
4195 cgrad            do l=1,3
4196 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4197 cgrad            enddo
4198 cgrad          enddo
4199 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4200           do k=1,3
4201             gelc(k,i)=gelc(k,i)
4202      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4203      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4204      &           *fac_shield(i)**2*fac_shield(j)**2
4205             gelc(k,j)=gelc(k,j)
4206      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4207      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4208      &           *fac_shield(i)**2*fac_shield(j)**2
4209             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4210             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4211           enddo
4212 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4213
4214 C MARYSIA
4215 c          endif !sscale
4216           endif ! calc_grad
4217           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4218      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4219      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4220 C
4221 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4222 C   energy of a peptide unit is assumed in the form of a second-order
4223 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4224 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4225 C   are computed for EVERY pair of non-contiguous peptide groups.
4226 C
4227
4228           if (j.lt.nres-1) then
4229             j1=j+1
4230             j2=j-1
4231           else
4232             j1=j-1
4233             j2=j-2
4234           endif
4235           kkk=0
4236           lll=0
4237           do k=1,2
4238             do l=1,2
4239               kkk=kkk+1
4240               muij(kkk)=mu(k,i)*mu(l,j)
4241 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4242 #ifdef NEWCORR
4243              if (calc_grad) then
4244              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4245 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4246              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4247              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4248 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4249              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4250              endif
4251 #endif
4252             enddo
4253           enddo
4254 #ifdef DEBUG
4255           write (iout,*) 'EELEC: i',i,' j',j
4256           write (iout,*) 'j',j,' j1',j1,' j2',j2
4257           write(iout,*) 'muij',muij
4258           write (iout,*) "uy",uy(:,i)
4259           write (iout,*) "uz",uz(:,j)
4260           write (iout,*) "erij",erij
4261 #endif
4262           ury=scalar(uy(1,i),erij)
4263           urz=scalar(uz(1,i),erij)
4264           vry=scalar(uy(1,j),erij)
4265           vrz=scalar(uz(1,j),erij)
4266           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4267           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4268           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4269           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4270           fac=dsqrt(-ael6i)*r3ij
4271           a22=a22*fac
4272           a23=a23*fac
4273           a32=a32*fac
4274           a33=a33*fac
4275 cd          write (iout,'(4i5,4f10.5)')
4276 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4277 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4278 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4279 cd     &      uy(:,j),uz(:,j)
4280 cd          write (iout,'(4f10.5)')
4281 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4282 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4283 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4284 cd           write (iout,'(9f10.5/)')
4285 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4286 C Derivatives of the elements of A in virtual-bond vectors
4287           if (calc_grad) then
4288           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4289           do k=1,3
4290             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4291             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4292             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4293             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4294             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4295             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4296             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4297             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4298             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4299             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4300             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4301             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4302           enddo
4303 C Compute radial contributions to the gradient
4304           facr=-3.0d0*rrmij
4305           a22der=a22*facr
4306           a23der=a23*facr
4307           a32der=a32*facr
4308           a33der=a33*facr
4309           agg(1,1)=a22der*xj
4310           agg(2,1)=a22der*yj
4311           agg(3,1)=a22der*zj
4312           agg(1,2)=a23der*xj
4313           agg(2,2)=a23der*yj
4314           agg(3,2)=a23der*zj
4315           agg(1,3)=a32der*xj
4316           agg(2,3)=a32der*yj
4317           agg(3,3)=a32der*zj
4318           agg(1,4)=a33der*xj
4319           agg(2,4)=a33der*yj
4320           agg(3,4)=a33der*zj
4321 C Add the contributions coming from er
4322           fac3=-3.0d0*fac
4323           do k=1,3
4324             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4325             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4326             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4327             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4328           enddo
4329           do k=1,3
4330 C Derivatives in DC(i)
4331 cgrad            ghalf1=0.5d0*agg(k,1)
4332 cgrad            ghalf2=0.5d0*agg(k,2)
4333 cgrad            ghalf3=0.5d0*agg(k,3)
4334 cgrad            ghalf4=0.5d0*agg(k,4)
4335             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4336      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4337             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4338      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4339             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4340      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4341             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4342      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4343 C Derivatives in DC(i+1)
4344             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4345      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4346             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4347      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4348             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4349      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4350             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4351      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4352 C Derivatives in DC(j)
4353             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4354      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4355             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4356      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4357             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4358      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4359             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4360      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4361 C Derivatives in DC(j+1) or DC(nres-1)
4362             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4363      &      -3.0d0*vryg(k,3)*ury)
4364             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4365      &      -3.0d0*vrzg(k,3)*ury)
4366             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4367      &      -3.0d0*vryg(k,3)*urz)
4368             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4369      &      -3.0d0*vrzg(k,3)*urz)
4370 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4371 cgrad              do l=1,4
4372 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4373 cgrad              enddo
4374 cgrad            endif
4375           enddo
4376           endif ! calc_grad
4377           acipa(1,1)=a22
4378           acipa(1,2)=a23
4379           acipa(2,1)=a32
4380           acipa(2,2)=a33
4381           a22=-a22
4382           a23=-a23
4383           if (calc_grad) then
4384           do l=1,2
4385             do k=1,3
4386               agg(k,l)=-agg(k,l)
4387               aggi(k,l)=-aggi(k,l)
4388               aggi1(k,l)=-aggi1(k,l)
4389               aggj(k,l)=-aggj(k,l)
4390               aggj1(k,l)=-aggj1(k,l)
4391             enddo
4392           enddo
4393           endif ! calc_grad
4394           if (j.lt.nres-1) then
4395             a22=-a22
4396             a32=-a32
4397             do l=1,3,2
4398               do k=1,3
4399                 agg(k,l)=-agg(k,l)
4400                 aggi(k,l)=-aggi(k,l)
4401                 aggi1(k,l)=-aggi1(k,l)
4402                 aggj(k,l)=-aggj(k,l)
4403                 aggj1(k,l)=-aggj1(k,l)
4404               enddo
4405             enddo
4406           else
4407             a22=-a22
4408             a23=-a23
4409             a32=-a32
4410             a33=-a33
4411             do l=1,4
4412               do k=1,3
4413                 agg(k,l)=-agg(k,l)
4414                 aggi(k,l)=-aggi(k,l)
4415                 aggi1(k,l)=-aggi1(k,l)
4416                 aggj(k,l)=-aggj(k,l)
4417                 aggj1(k,l)=-aggj1(k,l)
4418               enddo
4419             enddo
4420           endif
4421           ENDIF ! WCORR
4422           IF (wel_loc.gt.0.0d0) THEN
4423 C Contribution to the local-electrostatic energy coming from the i-j pair
4424           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4425      &     +a33*muij(4)
4426 #ifdef DEBUG
4427           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4428      &     " a33",a33
4429           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4430      &     " wel_loc",wel_loc
4431 #endif
4432           if (shield_mode.eq.0) then
4433            fac_shield(i)=1.0
4434            fac_shield(j)=1.0
4435 C          else
4436 C           fac_shield(i)=0.4
4437 C           fac_shield(j)=0.6
4438           endif
4439           eel_loc_ij=eel_loc_ij
4440      &    *fac_shield(i)*fac_shield(j)
4441           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4442      &            'eelloc',i,j,eel_loc_ij
4443 c           if (eel_loc_ij.ne.0)
4444 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4445 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4446
4447           eel_loc=eel_loc+eel_loc_ij
4448 C Now derivative over eel_loc
4449           if (calc_grad) then
4450           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4451      &  (shield_mode.gt.0)) then
4452 C          print *,i,j
4453
4454           do ilist=1,ishield_list(i)
4455            iresshield=shield_list(ilist,i)
4456            do k=1,3
4457            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4458      &                                          /fac_shield(i)
4459 C     &      *2.0
4460            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4461      &              rlocshield
4462      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4463             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4464      &      +rlocshield
4465            enddo
4466           enddo
4467           do ilist=1,ishield_list(j)
4468            iresshield=shield_list(ilist,j)
4469            do k=1,3
4470            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4471      &                                       /fac_shield(j)
4472 C     &     *2.0
4473            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4474      &              rlocshield
4475      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4476            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4477      &             +rlocshield
4478
4479            enddo
4480           enddo
4481
4482           do k=1,3
4483             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4484      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4485             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4486      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4487             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4488      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4489             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4490      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4491            enddo
4492            endif
4493
4494
4495 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4496 c     &                     ' eel_loc_ij',eel_loc_ij
4497 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4498 C Calculate patrial derivative for theta angle
4499 #ifdef NEWCORR
4500          geel_loc_ij=(a22*gmuij1(1)
4501      &     +a23*gmuij1(2)
4502      &     +a32*gmuij1(3)
4503      &     +a33*gmuij1(4))
4504      &    *fac_shield(i)*fac_shield(j)
4505 c         write(iout,*) "derivative over thatai"
4506 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4507 c     &   a33*gmuij1(4)
4508          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4509      &      geel_loc_ij*wel_loc
4510          gloc_compon(7,nphi+i)=gloc_compon(7,nphi+i)+
4511      &      geel_loc_ij
4512 c         write(iout,*) "derivative over thatai-1"
4513 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4514 c     &   a33*gmuij2(4)
4515          geel_loc_ij=
4516      &     a22*gmuij2(1)
4517      &     +a23*gmuij2(2)
4518      &     +a32*gmuij2(3)
4519      &     +a33*gmuij2(4)
4520          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4521      &      geel_loc_ij*wel_loc
4522      &    *fac_shield(i)*fac_shield(j)
4523          gloc_compon(7,nphi+i-1)=gloc_compon(7,nphi+i-1)+
4524      &      geel_loc_ij*fac_shield(i)*fac_shield(j)
4525
4526 c  Derivative over j residue
4527          geel_loc_ji=a22*gmuji1(1)
4528      &     +a23*gmuji1(2)
4529      &     +a32*gmuji1(3)
4530      &     +a33*gmuji1(4)
4531 c         write(iout,*) "derivative over thataj"
4532 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4533 c     &   a33*gmuji1(4)
4534
4535         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4536      &      geel_loc_ji*wel_loc
4537      &    *fac_shield(i)*fac_shield(j)
4538          gloc_compon(7,nphi+j)=gloc_compon(7,nphi+j)+
4539      &      geel_loc_ji*fac_shield(i)*fac_shield(j)
4540          geel_loc_ji=
4541      &     +a22*gmuji2(1)
4542      &     +a23*gmuji2(2)
4543      &     +a32*gmuji2(3)
4544      &     +a33*gmuji2(4)
4545 c         write(iout,*) "derivative over thataj-1"
4546 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4547 c     &   a33*gmuji2(4)
4548          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4549      &      geel_loc_ji*wel_loc
4550      &    *fac_shield(i)*fac_shield(j)
4551          gloc_compon(7,nphi+j-1)=gloc_compon(7,nphi+j-1)+
4552      &      geel_loc_ji*fac_shield(i)*fac_shield(j)
4553 #endif
4554 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4555
4556 C Partial derivatives in virtual-bond dihedral angles gamma
4557           if (i.gt.1)
4558      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4559      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4560      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4561      &    *fac_shield(i)*fac_shield(j)
4562
4563           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4564      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4565      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4566      &    *fac_shield(i)*fac_shield(j)
4567 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4568           do l=1,3
4569             ggg(l)=(agg(l,1)*muij(1)+
4570      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4571      &    *fac_shield(i)*fac_shield(j)
4572             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4573             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4574 cgrad            ghalf=0.5d0*ggg(l)
4575 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4576 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4577           enddo
4578 cgrad          do k=i+1,j2
4579 cgrad            do l=1,3
4580 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4581 cgrad            enddo
4582 cgrad          enddo
4583 C Remaining derivatives of eello
4584           do l=1,3
4585             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4586      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4587      &    *fac_shield(i)*fac_shield(j)
4588
4589             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4590      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4591      &    *fac_shield(i)*fac_shield(j)
4592
4593             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4594      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4595      &    *fac_shield(i)*fac_shield(j)
4596
4597             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4598      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4599      &    *fac_shield(i)*fac_shield(j)
4600
4601           enddo
4602           endif ! calc_grad
4603           ENDIF
4604
4605
4606 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4607 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4608           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4609      &       .and. num_conti.le.maxconts) then
4610 c            write (iout,*) i,j," entered corr"
4611 C
4612 C Calculate the contact function. The ith column of the array JCONT will
4613 C contain the numbers of atoms that make contacts with the atom I (of numbers
4614 C greater than I). The arrays FACONT and GACONT will contain the values of
4615 C the contact function and its derivative.
4616 c           r0ij=1.02D0*rpp(iteli,itelj)
4617 c           r0ij=1.11D0*rpp(iteli,itelj)
4618             r0ij=2.20D0*rpp(iteli,itelj)
4619 c           r0ij=1.55D0*rpp(iteli,itelj)
4620             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4621             if (fcont.gt.0.0D0) then
4622               num_conti=num_conti+1
4623               if (num_conti.gt.maxconts) then
4624                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4625      &                         ' will skip next contacts for this conf.'
4626               else
4627                 jcont_hb(num_conti,i)=j
4628 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4629 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4630                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4631      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4632 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4633 C  terms.
4634                 d_cont(num_conti,i)=rij
4635 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4636 C     --- Electrostatic-interaction matrix ---
4637                 a_chuj(1,1,num_conti,i)=a22
4638                 a_chuj(1,2,num_conti,i)=a23
4639                 a_chuj(2,1,num_conti,i)=a32
4640                 a_chuj(2,2,num_conti,i)=a33
4641 C     --- Gradient of rij
4642                 if (calc_grad) then
4643                 do kkk=1,3
4644                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4645                 enddo
4646                 kkll=0
4647                 do k=1,2
4648                   do l=1,2
4649                     kkll=kkll+1
4650                     do m=1,3
4651                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4652                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4653                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4654                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4655                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4656                     enddo
4657                   enddo
4658                 enddo
4659                 endif ! calc_grad
4660                 ENDIF
4661                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4662 C Calculate contact energies
4663                 cosa4=4.0D0*cosa
4664                 wij=cosa-3.0D0*cosb*cosg
4665                 cosbg1=cosb+cosg
4666                 cosbg2=cosb-cosg
4667 c               fac3=dsqrt(-ael6i)/r0ij**3
4668                 fac3=dsqrt(-ael6i)*r3ij
4669 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4670                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4671                 if (ees0tmp.gt.0) then
4672                   ees0pij=dsqrt(ees0tmp)
4673                 else
4674                   ees0pij=0
4675                 endif
4676 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4677                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4678                 if (ees0tmp.gt.0) then
4679                   ees0mij=dsqrt(ees0tmp)
4680                 else
4681                   ees0mij=0
4682                 endif
4683 c               ees0mij=0.0D0
4684                 if (shield_mode.eq.0) then
4685                 fac_shield(i)=1.0d0
4686                 fac_shield(j)=1.0d0
4687                 else
4688                 ees0plist(num_conti,i)=j
4689 C                fac_shield(i)=0.4d0
4690 C                fac_shield(j)=0.6d0
4691                 endif
4692                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4693      &          *fac_shield(i)*fac_shield(j)
4694                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4695      &          *fac_shield(i)*fac_shield(j)
4696 C Diagnostics. Comment out or remove after debugging!
4697 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4698 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4699 c               ees0m(num_conti,i)=0.0D0
4700 C End diagnostics.
4701 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4702 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4703 C Angular derivatives of the contact function
4704
4705                 ees0pij1=fac3/ees0pij
4706                 ees0mij1=fac3/ees0mij
4707                 fac3p=-3.0D0*fac3*rrmij
4708                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4709                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4710 c               ees0mij1=0.0D0
4711                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4712                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4713                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4714                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4715                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4716                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4717                 ecosap=ecosa1+ecosa2
4718                 ecosbp=ecosb1+ecosb2
4719                 ecosgp=ecosg1+ecosg2
4720                 ecosam=ecosa1-ecosa2
4721                 ecosbm=ecosb1-ecosb2
4722                 ecosgm=ecosg1-ecosg2
4723 C Diagnostics
4724 c               ecosap=ecosa1
4725 c               ecosbp=ecosb1
4726 c               ecosgp=ecosg1
4727 c               ecosam=0.0D0
4728 c               ecosbm=0.0D0
4729 c               ecosgm=0.0D0
4730 C End diagnostics
4731                 facont_hb(num_conti,i)=fcont
4732
4733                 if (calc_grad) then
4734                 fprimcont=fprimcont/rij
4735 cd              facont_hb(num_conti,i)=1.0D0
4736 C Following line is for diagnostics.
4737 cd              fprimcont=0.0D0
4738                 do k=1,3
4739                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4740                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4741                 enddo
4742                 do k=1,3
4743                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4744                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4745                 enddo
4746                 gggp(1)=gggp(1)+ees0pijp*xj
4747                 gggp(2)=gggp(2)+ees0pijp*yj
4748                 gggp(3)=gggp(3)+ees0pijp*zj
4749                 gggm(1)=gggm(1)+ees0mijp*xj
4750                 gggm(2)=gggm(2)+ees0mijp*yj
4751                 gggm(3)=gggm(3)+ees0mijp*zj
4752 C Derivatives due to the contact function
4753                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4754                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4755                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4756                 do k=1,3
4757 c
4758 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4759 c          following the change of gradient-summation algorithm.
4760 c
4761 cgrad                  ghalfp=0.5D0*gggp(k)
4762 cgrad                  ghalfm=0.5D0*gggm(k)
4763                   gacontp_hb1(k,num_conti,i)=!ghalfp
4764      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4765      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4766      &          *fac_shield(i)*fac_shield(j)
4767
4768                   gacontp_hb2(k,num_conti,i)=!ghalfp
4769      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4770      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4771      &          *fac_shield(i)*fac_shield(j)
4772
4773                   gacontp_hb3(k,num_conti,i)=gggp(k)
4774      &          *fac_shield(i)*fac_shield(j)
4775
4776                   gacontm_hb1(k,num_conti,i)=!ghalfm
4777      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4778      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4779      &          *fac_shield(i)*fac_shield(j)
4780
4781                   gacontm_hb2(k,num_conti,i)=!ghalfm
4782      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4783      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4784      &          *fac_shield(i)*fac_shield(j)
4785
4786                   gacontm_hb3(k,num_conti,i)=gggm(k)
4787      &          *fac_shield(i)*fac_shield(j)
4788
4789                 enddo
4790 C Diagnostics. Comment out or remove after debugging!
4791 cdiag           do k=1,3
4792 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4793 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4794 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4795 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4796 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4797 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4798 cdiag           enddo
4799
4800                  endif ! calc_grad
4801
4802               ENDIF ! wcorr
4803               endif  ! num_conti.le.maxconts
4804             endif  ! fcont.gt.0
4805           endif    ! j.gt.i+1
4806           if (calc_grad) then
4807           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4808             do k=1,4
4809               do l=1,3
4810                 ghalf=0.5d0*agg(l,k)
4811                 aggi(l,k)=aggi(l,k)+ghalf
4812                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4813                 aggj(l,k)=aggj(l,k)+ghalf
4814               enddo
4815             enddo
4816             if (j.eq.nres-1 .and. i.lt.j-2) then
4817               do k=1,4
4818                 do l=1,3
4819                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4820                 enddo
4821               enddo
4822             endif
4823           endif
4824           endif ! calc_grad
4825 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4826       return
4827       end
4828 C-----------------------------------------------------------------------------
4829       subroutine eturn3(i,eello_turn3)
4830 C Third- and fourth-order contributions from turns
4831       implicit real*8 (a-h,o-z)
4832       include 'DIMENSIONS'
4833       include 'DIMENSIONS.ZSCOPT'
4834       include 'COMMON.IOUNITS'
4835       include 'COMMON.GEO'
4836       include 'COMMON.VAR'
4837       include 'COMMON.LOCAL'
4838       include 'COMMON.CHAIN'
4839       include 'COMMON.DERIV'
4840       include 'COMMON.INTERACT'
4841       include 'COMMON.CONTACTS'
4842       include 'COMMON.TORSION'
4843       include 'COMMON.VECTORS'
4844       include 'COMMON.FFIELD'
4845       include 'COMMON.CONTROL'
4846       include 'COMMON.SHIELD'
4847       dimension ggg(3)
4848       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4849      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4850      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4851      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4852      &  auxgmat2(2,2),auxgmatt2(2,2)
4853       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4854      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4855       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4856      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4857      &    num_conti,j1,j2
4858       j=i+2
4859 c      write (iout,*) "eturn3",i,j,j1,j2
4860       a_temp(1,1)=a22
4861       a_temp(1,2)=a23
4862       a_temp(2,1)=a32
4863       a_temp(2,2)=a33
4864 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4865 C
4866 C               Third-order contributions
4867 C
4868 C                 (i+2)o----(i+3)
4869 C                      | |
4870 C                      | |
4871 C                 (i+1)o----i
4872 C
4873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4874 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4875         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4876 c auxalary matices for theta gradient
4877 c auxalary matrix for i+1 and constant i+2
4878         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4879 c auxalary matrix for i+2 and constant i+1
4880         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4881         call transpose2(auxmat(1,1),auxmat1(1,1))
4882         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4883         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4884         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4885         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4886         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4887         if (shield_mode.eq.0) then
4888         fac_shield(i)=1.0
4889         fac_shield(j)=1.0
4890 C        else
4891 C        fac_shield(i)=0.4
4892 C        fac_shield(j)=0.6
4893         endif
4894         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4895      &  *fac_shield(i)*fac_shield(j)
4896         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4897      &  *fac_shield(i)*fac_shield(j)
4898         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4899      &    eello_t3
4900         if (calc_grad) then
4901 C#ifdef NEWCORR
4902 C Derivatives in theta
4903         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4904      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4905      &   *fac_shield(i)*fac_shield(j)
4906         gloc_compon(8,nphi+i)=gloc_compon(8,nphi+i)+
4907      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))
4908      &   *fac_shield(i)*fac_shield(j)
4909         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4910      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4911      &   *fac_shield(i)*fac_shield(j)
4912         gloc_compon(8,nphi+i+1)=gloc_compon(8,nphi+i+1)+
4913      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))
4914      &   *fac_shield(i)*fac_shield(j)
4915 C#endif
4916
4917 C Derivatives in shield mode
4918           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4919      &  (shield_mode.gt.0)) then
4920 C          print *,i,j
4921
4922           do ilist=1,ishield_list(i)
4923            iresshield=shield_list(ilist,i)
4924            do k=1,3
4925            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4926 C     &      *2.0
4927            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4928      &              rlocshield
4929      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4930             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4931      &      +rlocshield
4932            enddo
4933           enddo
4934           do ilist=1,ishield_list(j)
4935            iresshield=shield_list(ilist,j)
4936            do k=1,3
4937            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4938 C     &     *2.0
4939            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4940      &              rlocshield
4941      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4942            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4943      &             +rlocshield
4944
4945            enddo
4946           enddo
4947
4948           do k=1,3
4949             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4950      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4951             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4952      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4953             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4954      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4955             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4956      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4957            enddo
4958            endif
4959
4960 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4961 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4962 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4963 cd     &    ' eello_turn3_num',4*eello_turn3_num
4964 C Derivatives in gamma(i)
4965         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4966         call transpose2(auxmat2(1,1),auxmat3(1,1))
4967         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4968         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4969      &   *fac_shield(i)*fac_shield(j)
4970 C Derivatives in gamma(i+1)
4971         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4972         call transpose2(auxmat2(1,1),auxmat3(1,1))
4973         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4974         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4975      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4976      &   *fac_shield(i)*fac_shield(j)
4977 C Cartesian derivatives
4978         do l=1,3
4979 c            ghalf1=0.5d0*agg(l,1)
4980 c            ghalf2=0.5d0*agg(l,2)
4981 c            ghalf3=0.5d0*agg(l,3)
4982 c            ghalf4=0.5d0*agg(l,4)
4983           a_temp(1,1)=aggi(l,1)!+ghalf1
4984           a_temp(1,2)=aggi(l,2)!+ghalf2
4985           a_temp(2,1)=aggi(l,3)!+ghalf3
4986           a_temp(2,2)=aggi(l,4)!+ghalf4
4987           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4988           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4989      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4990      &   *fac_shield(i)*fac_shield(j)
4991
4992           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4993           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4994           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4995           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4996           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4997           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4998      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4999      &   *fac_shield(i)*fac_shield(j)
5000           a_temp(1,1)=aggj(l,1)!+ghalf1
5001           a_temp(1,2)=aggj(l,2)!+ghalf2
5002           a_temp(2,1)=aggj(l,3)!+ghalf3
5003           a_temp(2,2)=aggj(l,4)!+ghalf4
5004           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5005           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5006      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5007      &   *fac_shield(i)*fac_shield(j)
5008           a_temp(1,1)=aggj1(l,1)
5009           a_temp(1,2)=aggj1(l,2)
5010           a_temp(2,1)=aggj1(l,3)
5011           a_temp(2,2)=aggj1(l,4)
5012           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5013           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5014      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5015      &   *fac_shield(i)*fac_shield(j)
5016         enddo
5017
5018         endif ! calc_grad
5019
5020       return
5021       end
5022 C-------------------------------------------------------------------------------
5023       subroutine eturn4(i,eello_turn4)
5024 C Third- and fourth-order contributions from turns
5025       implicit real*8 (a-h,o-z)
5026       include 'DIMENSIONS'
5027       include 'DIMENSIONS.ZSCOPT'
5028       include 'COMMON.IOUNITS'
5029       include 'COMMON.GEO'
5030       include 'COMMON.VAR'
5031       include 'COMMON.LOCAL'
5032       include 'COMMON.CHAIN'
5033       include 'COMMON.DERIV'
5034       include 'COMMON.INTERACT'
5035       include 'COMMON.CONTACTS'
5036       include 'COMMON.TORSION'
5037       include 'COMMON.VECTORS'
5038       include 'COMMON.FFIELD'
5039       include 'COMMON.CONTROL'
5040       include 'COMMON.SHIELD'
5041       dimension ggg(3)
5042       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5043      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5044      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5045      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5046      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5047      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5048      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5049       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5050      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5051       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5052      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5053      &    num_conti,j1,j2
5054       j=i+3
5055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5056 C
5057 C               Fourth-order contributions
5058 C
5059 C                 (i+3)o----(i+4)
5060 C                     /  |
5061 C               (i+2)o   |
5062 C                     \  |
5063 C                 (i+1)o----i
5064 C
5065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5066 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5067 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5068 c        write(iout,*)"WCHODZE W PROGRAM"
5069         a_temp(1,1)=a22
5070         a_temp(1,2)=a23
5071         a_temp(2,1)=a32
5072         a_temp(2,2)=a33
5073         iti1=itype2loc(itype(i+1))
5074         iti2=itype2loc(itype(i+2))
5075         iti3=itype2loc(itype(i+3))
5076 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5077         call transpose2(EUg(1,1,i+1),e1t(1,1))
5078         call transpose2(Eug(1,1,i+2),e2t(1,1))
5079         call transpose2(Eug(1,1,i+3),e3t(1,1))
5080 C Ematrix derivative in theta
5081         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5082         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5083         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5084         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5085 c       eta1 in derivative theta
5086         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5087         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5088 c       auxgvec is derivative of Ub2 so i+3 theta
5089         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5090 c       auxalary matrix of E i+1
5091         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5092 c        s1=0.0
5093 c        gs1=0.0
5094         s1=scalar2(b1(1,i+2),auxvec(1))
5095 c derivative of theta i+2 with constant i+3
5096         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5097 c derivative of theta i+2 with constant i+2
5098         gs32=scalar2(b1(1,i+2),auxgvec(1))
5099 c derivative of E matix in theta of i+1
5100         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5101
5102         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5103 c       ea31 in derivative theta
5104         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5105         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5106 c auxilary matrix auxgvec of Ub2 with constant E matirx
5107         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5108 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5109         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5110
5111 c        s2=0.0
5112 c        gs2=0.0
5113         s2=scalar2(b1(1,i+1),auxvec(1))
5114 c derivative of theta i+1 with constant i+3
5115         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5116 c derivative of theta i+2 with constant i+1
5117         gs21=scalar2(b1(1,i+1),auxgvec(1))
5118 c derivative of theta i+3 with constant i+1
5119         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5120 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5121 c     &  gtb1(1,i+1)
5122         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5123 c two derivatives over diffetent matrices
5124 c gtae3e2 is derivative over i+3
5125         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5126 c ae3gte2 is derivative over i+2
5127         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5128         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5129 c three possible derivative over theta E matices
5130 c i+1
5131         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5132 c i+2
5133         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5134 c i+3
5135         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5136         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5137
5138         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5139         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5140         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5141         if (shield_mode.eq.0) then
5142         fac_shield(i)=1.0
5143         fac_shield(j)=1.0
5144 C        else
5145 C        fac_shield(i)=0.6
5146 C        fac_shield(j)=0.4
5147         endif
5148         eello_turn4=eello_turn4-(s1+s2+s3)
5149      &  *fac_shield(i)*fac_shield(j)
5150         eello_t4=-(s1+s2+s3)
5151      &  *fac_shield(i)*fac_shield(j)
5152 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5153         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5154      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5155 C Now derivative over shield:
5156           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5157      &  (shield_mode.gt.0)) then
5158 C          print *,i,j
5159
5160           do ilist=1,ishield_list(i)
5161            iresshield=shield_list(ilist,i)
5162            do k=1,3
5163            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5164 C     &      *2.0
5165            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5166      &              rlocshield
5167      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5168             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5169      &      +rlocshield
5170            enddo
5171           enddo
5172           do ilist=1,ishield_list(j)
5173            iresshield=shield_list(ilist,j)
5174            do k=1,3
5175            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5176 C     &     *2.0
5177            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5178      &              rlocshield
5179      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5180            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5181      &             +rlocshield
5182
5183            enddo
5184           enddo
5185
5186           do k=1,3
5187             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5188      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5189             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5190      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5191             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5192      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5193             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5194      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5195            enddo
5196            endif
5197 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5198 cd     &    ' eello_turn4_num',8*eello_turn4_num
5199 #ifdef NEWCORR
5200         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5201      &                  -(gs13+gsE13+gsEE1)*wturn4
5202      &  *fac_shield(i)*fac_shield(j)
5203         gloc_compon(9,nphi+i)=gloc_compon(9,nphi+i)
5204      &     -(gs13+gsE13+gsEE1)*fac_shield(i)*fac_shield(j)
5205         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5206      &                    -(gs23+gs21+gsEE2)*wturn4
5207      &  *fac_shield(i)*fac_shield(j)
5208
5209         gloc_compon(9,nphi+i+1)=gloc_compon(9,nphi+i+1)
5210      &     -(gs23+gs21+gsEE2)*fac_shield(i)*fac_shield(j)
5211         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5212      &                    -(gs32+gsE31+gsEE3)*wturn4
5213      &  *fac_shield(i)*fac_shield(j)
5214         gloc_compon(9,nphi+i+2)=gloc_compon(9,nphi+i+2)
5215      &     -(gs32+gsE31+gsEE3)*fac_shield(i)*fac_shield(j)
5216
5217 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5218 c     &   gs2
5219 #endif
5220         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5221      &      'eturn4',i,j,-(s1+s2+s3)
5222 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5223 c     &    ' eello_turn4_num',8*eello_turn4_num
5224 C Derivatives in gamma(i)
5225         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5226         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5227         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5228         s1=scalar2(b1(1,i+2),auxvec(1))
5229         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5230         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5231         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5232      &  *fac_shield(i)*fac_shield(j)
5233 C Derivatives in gamma(i+1)
5234         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5235         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5236         s2=scalar2(b1(1,i+1),auxvec(1))
5237         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5238         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5239         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5240         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5241      &  *fac_shield(i)*fac_shield(j)
5242 C Derivatives in gamma(i+2)
5243         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5244         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5245         s1=scalar2(b1(1,i+2),auxvec(1))
5246         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5247         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5248         s2=scalar2(b1(1,i+1),auxvec(1))
5249         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5250         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5251         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5252         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5253      &  *fac_shield(i)*fac_shield(j)
5254         if (calc_grad) then
5255 C Cartesian derivatives
5256 C Derivatives of this turn contributions in DC(i+2)
5257         if (j.lt.nres-1) then
5258           do l=1,3
5259             a_temp(1,1)=agg(l,1)
5260             a_temp(1,2)=agg(l,2)
5261             a_temp(2,1)=agg(l,3)
5262             a_temp(2,2)=agg(l,4)
5263             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5264             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5265             s1=scalar2(b1(1,i+2),auxvec(1))
5266             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5267             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5268             s2=scalar2(b1(1,i+1),auxvec(1))
5269             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5270             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5271             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5272             ggg(l)=-(s1+s2+s3)
5273             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5274      &  *fac_shield(i)*fac_shield(j)
5275           enddo
5276         endif
5277 C Remaining derivatives of this turn contribution
5278         do l=1,3
5279           a_temp(1,1)=aggi(l,1)
5280           a_temp(1,2)=aggi(l,2)
5281           a_temp(2,1)=aggi(l,3)
5282           a_temp(2,2)=aggi(l,4)
5283           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5284           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5285           s1=scalar2(b1(1,i+2),auxvec(1))
5286           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5287           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5288           s2=scalar2(b1(1,i+1),auxvec(1))
5289           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5290           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5291           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5292           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5293      &  *fac_shield(i)*fac_shield(j)
5294           a_temp(1,1)=aggi1(l,1)
5295           a_temp(1,2)=aggi1(l,2)
5296           a_temp(2,1)=aggi1(l,3)
5297           a_temp(2,2)=aggi1(l,4)
5298           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5299           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5300           s1=scalar2(b1(1,i+2),auxvec(1))
5301           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5302           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5303           s2=scalar2(b1(1,i+1),auxvec(1))
5304           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5305           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5306           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5307           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5308      &  *fac_shield(i)*fac_shield(j)
5309           a_temp(1,1)=aggj(l,1)
5310           a_temp(1,2)=aggj(l,2)
5311           a_temp(2,1)=aggj(l,3)
5312           a_temp(2,2)=aggj(l,4)
5313           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5314           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5315           s1=scalar2(b1(1,i+2),auxvec(1))
5316           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5317           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5318           s2=scalar2(b1(1,i+1),auxvec(1))
5319           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5320           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5321           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5322           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5323      &  *fac_shield(i)*fac_shield(j)
5324           a_temp(1,1)=aggj1(l,1)
5325           a_temp(1,2)=aggj1(l,2)
5326           a_temp(2,1)=aggj1(l,3)
5327           a_temp(2,2)=aggj1(l,4)
5328           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5329           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5330           s1=scalar2(b1(1,i+2),auxvec(1))
5331           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5332           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5333           s2=scalar2(b1(1,i+1),auxvec(1))
5334           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5335           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5336           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5337 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5338           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5339      &  *fac_shield(i)*fac_shield(j)
5340         enddo
5341
5342         endif ! calc_grad
5343
5344       return
5345       end
5346 C-----------------------------------------------------------------------------
5347       subroutine vecpr(u,v,w)
5348       implicit real*8(a-h,o-z)
5349       dimension u(3),v(3),w(3)
5350       w(1)=u(2)*v(3)-u(3)*v(2)
5351       w(2)=-u(1)*v(3)+u(3)*v(1)
5352       w(3)=u(1)*v(2)-u(2)*v(1)
5353       return
5354       end
5355 C-----------------------------------------------------------------------------
5356       subroutine unormderiv(u,ugrad,unorm,ungrad)
5357 C This subroutine computes the derivatives of a normalized vector u, given
5358 C the derivatives computed without normalization conditions, ugrad. Returns
5359 C ungrad.
5360       implicit none
5361       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5362       double precision vec(3)
5363       double precision scalar
5364       integer i,j
5365 c      write (2,*) 'ugrad',ugrad
5366 c      write (2,*) 'u',u
5367       do i=1,3
5368         vec(i)=scalar(ugrad(1,i),u(1))
5369       enddo
5370 c      write (2,*) 'vec',vec
5371       do i=1,3
5372         do j=1,3
5373           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5374         enddo
5375       enddo
5376 c      write (2,*) 'ungrad',ungrad
5377       return
5378       end
5379 C-----------------------------------------------------------------------------
5380       subroutine escp(evdw2,evdw2_14)
5381 C
5382 C This subroutine calculates the excluded-volume interaction energy between
5383 C peptide-group centers and side chains and its gradient in virtual-bond and
5384 C side-chain vectors.
5385 C
5386       implicit real*8 (a-h,o-z)
5387       include 'DIMENSIONS'
5388       include 'DIMENSIONS.ZSCOPT'
5389       include 'COMMON.GEO'
5390       include 'COMMON.VAR'
5391       include 'COMMON.LOCAL'
5392       include 'COMMON.CHAIN'
5393       include 'COMMON.DERIV'
5394       include 'COMMON.INTERACT'
5395       include 'COMMON.FFIELD'
5396       include 'COMMON.IOUNITS'
5397       dimension ggg(3)
5398       evdw2=0.0D0
5399       evdw2_14=0.0d0
5400 cd    print '(a)','Enter ESCP'
5401 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5402 c     &  ' scal14',scal14
5403       do i=iatscp_s,iatscp_e
5404         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5405         iteli=itel(i)
5406 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5407 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5408         if (iteli.eq.0) goto 1225
5409         xi=0.5D0*(c(1,i)+c(1,i+1))
5410         yi=0.5D0*(c(2,i)+c(2,i+1))
5411         zi=0.5D0*(c(3,i)+c(3,i+1))
5412 C Returning the ith atom to box
5413           xi=mod(xi,boxxsize)
5414           if (xi.lt.0) xi=xi+boxxsize
5415           yi=mod(yi,boxysize)
5416           if (yi.lt.0) yi=yi+boxysize
5417           zi=mod(zi,boxzsize)
5418           if (zi.lt.0) zi=zi+boxzsize
5419         do iint=1,nscp_gr(i)
5420
5421         do j=iscpstart(i,iint),iscpend(i,iint)
5422           itypj=iabs(itype(j))
5423           if (itypj.eq.ntyp1) cycle
5424 C Uncomment following three lines for SC-p interactions
5425 c         xj=c(1,nres+j)-xi
5426 c         yj=c(2,nres+j)-yi
5427 c         zj=c(3,nres+j)-zi
5428 C Uncomment following three lines for Ca-p interactions
5429           xj=c(1,j)
5430           yj=c(2,j)
5431           zj=c(3,j)
5432 C returning the jth atom to box
5433           xj=mod(xj,boxxsize)
5434           if (xj.lt.0) xj=xj+boxxsize
5435           yj=mod(yj,boxysize)
5436           if (yj.lt.0) yj=yj+boxysize
5437           zj=mod(zj,boxzsize)
5438           if (zj.lt.0) zj=zj+boxzsize
5439       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5440       xj_safe=xj
5441       yj_safe=yj
5442       zj_safe=zj
5443       subchap=0
5444 C Finding the closest jth atom
5445       do xshift=-1,1
5446       do yshift=-1,1
5447       do zshift=-1,1
5448           xj=xj_safe+xshift*boxxsize
5449           yj=yj_safe+yshift*boxysize
5450           zj=zj_safe+zshift*boxzsize
5451           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5452           if(dist_temp.lt.dist_init) then
5453             dist_init=dist_temp
5454             xj_temp=xj
5455             yj_temp=yj
5456             zj_temp=zj
5457             subchap=1
5458           endif
5459        enddo
5460        enddo
5461        enddo
5462        if (subchap.eq.1) then
5463           xj=xj_temp-xi
5464           yj=yj_temp-yi
5465           zj=zj_temp-zi
5466        else
5467           xj=xj_safe-xi
5468           yj=yj_safe-yi
5469           zj=zj_safe-zi
5470        endif
5471           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5472 C sss is scaling function for smoothing the cutoff gradient otherwise
5473 C the gradient would not be continuouse
5474           sss=sscale(1.0d0/(dsqrt(rrij)))
5475           if (sss.le.0.0d0) cycle
5476           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5477           fac=rrij**expon2
5478           e1=fac*fac*aad(itypj,iteli)
5479           e2=fac*bad(itypj,iteli)
5480           if (iabs(j-i) .le. 2) then
5481             e1=scal14*e1
5482             e2=scal14*e2
5483             evdw2_14=evdw2_14+(e1+e2)*sss
5484           endif
5485           evdwij=e1+e2
5486 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5487 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5488 c     &       bad(itypj,iteli)
5489           evdw2=evdw2+evdwij*sss
5490           if (calc_grad) then
5491 C
5492 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5493 C
5494           fac=-(evdwij+e1)*rrij*sss
5495           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5496           ggg(1)=xj*fac
5497           ggg(2)=yj*fac
5498           ggg(3)=zj*fac
5499 c          if (j.lt.i) then
5500 cd          write (iout,*) 'j<i'
5501 C Uncomment following three lines for SC-p interactions
5502 c           do k=1,3
5503 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5504 c           enddo
5505 c          else
5506 cd          write (iout,*) 'j>i'
5507 c            do k=1,3
5508 c              ggg(k)=-ggg(k)
5509 C Uncomment following line for SC-p interactions
5510 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5511 c            enddo
5512 c          endif
5513           do k=1,3
5514             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5515             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5516           enddo
5517           kstart=min0(i+1,j)
5518           kend=max0(i-1,j-1)
5519 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5520 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5521 c          do k=kstart,kend
5522 c            do l=1,3
5523 c              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5524 c            enddo
5525 c          enddo
5526           endif ! calc_grad
5527         enddo
5528         enddo ! iint
5529  1225   continue
5530       enddo ! i
5531       do i=1,nct
5532         do j=1,3
5533           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5534           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5535           gradx_scp(j,i)=expon*gradx_scp(j,i)
5536         enddo
5537       enddo
5538 C******************************************************************************
5539 C
5540 C                              N O T E !!!
5541 C
5542 C To save time the factor EXPON has been extracted from ALL components
5543 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5544 C use!
5545 C
5546 C******************************************************************************
5547 c      write (iout,*) "gvdwc_scp"
5548 c      do i=1,nres
5549 c        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gvdwc_scp(j,i),j=1,3),
5550 c     &    (gvdwc_scpp(j,i),j=1,3)
5551 c      enddo
5552       return
5553       end
5554 C--------------------------------------------------------------------------
5555       subroutine edis(ehpb)
5556 C
5557 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5558 C
5559       implicit real*8 (a-h,o-z)
5560       include 'DIMENSIONS'
5561       include 'DIMENSIONS.ZSCOPT'
5562       include 'COMMON.SBRIDGE'
5563       include 'COMMON.CHAIN'
5564       include 'COMMON.DERIV'
5565       include 'COMMON.VAR'
5566       include 'COMMON.INTERACT'
5567       include 'COMMON.CONTROL'
5568       include 'COMMON.IOUNITS'
5569       dimension ggg(3)
5570       ehpb=0.0D0
5571 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5572 cd    print *,'link_start=',link_start,' link_end=',link_end
5573 C      write(iout,*) link_end, "link_end"
5574       if (link_end.eq.0) return
5575       do i=link_start,link_end
5576 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5577 C CA-CA distance used in regularization of structure.
5578         ii=ihpb(i)
5579         jj=jhpb(i)
5580 C iii and jjj point to the residues for which the distance is assigned.
5581         if (ii.gt.nres) then
5582           iii=ii-nres
5583           jjj=jj-nres
5584         else
5585           iii=ii
5586           jjj=jj
5587         endif
5588 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5589 C    distance and angle dependent SS bond potential.
5590 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5591 C     & iabs(itype(jjj)).eq.1) then
5592 C       write(iout,*) constr_dist,"const"
5593        if (.not.dyn_ss .and. i.le.nss) then
5594          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5595      & iabs(itype(jjj)).eq.1) then
5596           call ssbond_ene(iii,jjj,eij)
5597           ehpb=ehpb+2*eij
5598            endif !ii.gt.neres
5599         else if (ii.gt.nres .and. jj.gt.nres) then
5600 c Restraints from contact prediction
5601           dd=dist(ii,jj)
5602           if (constr_dist.eq.11) then
5603 C            ehpb=ehpb+fordepth(i)**4.0d0
5604 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5605             ehpb=ehpb+fordepth(i)**4.0d0
5606      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5607             fac=fordepth(i)**4.0d0
5608      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5609 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5610 C     &    ehpb,fordepth(i),dd
5611 C            write(iout,*) ehpb,"atu?"
5612 C            ehpb,"tu?"
5613 C            fac=fordepth(i)**4.0d0
5614 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5615            else
5616           if (dhpb1(i).gt.0.0d0) then
5617             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5618             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5619 c            write (iout,*) "beta nmr",
5620 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5621           else
5622             dd=dist(ii,jj)
5623             rdis=dd-dhpb(i)
5624 C Get the force constant corresponding to this distance.
5625             waga=forcon(i)
5626 C Calculate the contribution to energy.
5627             ehpb=ehpb+waga*rdis*rdis
5628 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5629 C
5630 C Evaluate gradient.
5631 C
5632             fac=waga*rdis/dd
5633           endif !end dhpb1(i).gt.0
5634           endif !end const_dist=11
5635           do j=1,3
5636             ggg(j)=fac*(c(j,jj)-c(j,ii))
5637           enddo
5638           do j=1,3
5639             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5640             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5641           enddo
5642           do k=1,3
5643             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5644             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5645           enddo
5646         else !ii.gt.nres
5647 C          write(iout,*) "before"
5648           dd=dist(ii,jj)
5649 C          write(iout,*) "after",dd
5650           if (constr_dist.eq.11) then
5651             ehpb=ehpb+fordepth(i)**4.0d0
5652      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5653             fac=fordepth(i)**4.0d0
5654      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5655 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5656 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5657 C            print *,ehpb,"tu?"
5658 C            write(iout,*) ehpb,"btu?",
5659 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5660 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5661 C     &    ehpb,fordepth(i),dd
5662            else
5663           if (dhpb1(i).gt.0.0d0) then
5664             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5665             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5666 c            write (iout,*) "alph nmr",
5667 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5668           else
5669             rdis=dd-dhpb(i)
5670 C Get the force constant corresponding to this distance.
5671             waga=forcon(i)
5672 C Calculate the contribution to energy.
5673             ehpb=ehpb+waga*rdis*rdis
5674 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5675 C
5676 C Evaluate gradient.
5677 C
5678             fac=waga*rdis/dd
5679           endif
5680           endif
5681
5682         do j=1,3
5683           ggg(j)=fac*(c(j,jj)-c(j,ii))
5684         enddo
5685 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5686 C If this is a SC-SC distance, we need to calculate the contributions to the
5687 C Cartesian gradient in the SC vectors (ghpbx).
5688         if (iii.lt.ii) then
5689           do j=1,3
5690             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5691             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5692           enddo
5693         endif
5694         do j=iii,jjj-1
5695           do k=1,3
5696             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5697           enddo
5698         enddo
5699         endif
5700       enddo
5701       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5702       return
5703       end
5704 C--------------------------------------------------------------------------
5705       subroutine ssbond_ene(i,j,eij)
5706 C
5707 C Calculate the distance and angle dependent SS-bond potential energy
5708 C using a free-energy function derived based on RHF/6-31G** ab initio
5709 C calculations of diethyl disulfide.
5710 C
5711 C A. Liwo and U. Kozlowska, 11/24/03
5712 C
5713       implicit real*8 (a-h,o-z)
5714       include 'DIMENSIONS'
5715       include 'DIMENSIONS.ZSCOPT'
5716       include 'COMMON.SBRIDGE'
5717       include 'COMMON.CHAIN'
5718       include 'COMMON.DERIV'
5719       include 'COMMON.LOCAL'
5720       include 'COMMON.INTERACT'
5721       include 'COMMON.VAR'
5722       include 'COMMON.IOUNITS'
5723       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5724       itypi=iabs(itype(i))
5725       xi=c(1,nres+i)
5726       yi=c(2,nres+i)
5727       zi=c(3,nres+i)
5728       dxi=dc_norm(1,nres+i)
5729       dyi=dc_norm(2,nres+i)
5730       dzi=dc_norm(3,nres+i)
5731       dsci_inv=dsc_inv(itypi)
5732       itypj=iabs(itype(j))
5733       dscj_inv=dsc_inv(itypj)
5734       xj=c(1,nres+j)-xi
5735       yj=c(2,nres+j)-yi
5736       zj=c(3,nres+j)-zi
5737       dxj=dc_norm(1,nres+j)
5738       dyj=dc_norm(2,nres+j)
5739       dzj=dc_norm(3,nres+j)
5740       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5741       rij=dsqrt(rrij)
5742       erij(1)=xj*rij
5743       erij(2)=yj*rij
5744       erij(3)=zj*rij
5745       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5746       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5747       om12=dxi*dxj+dyi*dyj+dzi*dzj
5748       do k=1,3
5749         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5750         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5751       enddo
5752       rij=1.0d0/rij
5753       deltad=rij-d0cm
5754       deltat1=1.0d0-om1
5755       deltat2=1.0d0+om2
5756       deltat12=om2-om1+2.0d0
5757       cosphi=om12-om1*om2
5758       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5759      &  +akct*deltad*deltat12
5760      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5761 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5762 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5763 c     &  " deltat12",deltat12," eij",eij
5764       ed=2*akcm*deltad+akct*deltat12
5765       pom1=akct*deltad
5766       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5767       eom1=-2*akth*deltat1-pom1-om2*pom2
5768       eom2= 2*akth*deltat2+pom1-om1*pom2
5769       eom12=pom2
5770       do k=1,3
5771         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5772       enddo
5773       do k=1,3
5774         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5775      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5776         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5777      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5778       enddo
5779 C
5780 C Calculate the components of the gradient in DC and X
5781 C
5782       do k=i,j-1
5783         do l=1,3
5784           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5785         enddo
5786       enddo
5787       return
5788       end
5789 C--------------------------------------------------------------------------
5790       subroutine ebond(estr)
5791 c
5792 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5793 c
5794       implicit real*8 (a-h,o-z)
5795       include 'DIMENSIONS'
5796       include 'DIMENSIONS.ZSCOPT'
5797       include 'COMMON.LOCAL'
5798       include 'COMMON.GEO'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.VAR'
5802       include 'COMMON.CHAIN'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.NAMES'
5805       include 'COMMON.FFIELD'
5806       include 'COMMON.CONTROL'
5807       double precision u(3),ud(3)
5808       estr=0.0d0
5809       estr1=0.0d0
5810 c      write (iout,*) "distchainmax",distchainmax
5811       do i=nnt+1,nct
5812         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5813 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5814 C          do j=1,3
5815 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5816 C     &      *dc(j,i-1)/vbld(i)
5817 C          enddo
5818 C          if (energy_dec) write(iout,*)
5819 C     &       "estr1",i,vbld(i),distchainmax,
5820 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5821 C        else
5822          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5823         diff = vbld(i)-vbldpDUM
5824 C         write(iout,*) i,diff
5825          else
5826           diff = vbld(i)-vbldp0
5827 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5828          endif
5829           estr=estr+diff*diff
5830           do j=1,3
5831             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5832           enddo
5833 C        endif
5834 C        write (iout,'(a7,i5,4f7.3)')
5835 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5836       enddo
5837       estr=0.5d0*AKP*estr+estr1
5838 c
5839 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5840 c
5841       do i=nnt,nct
5842         iti=iabs(itype(i))
5843         if (iti.ne.10 .and. iti.ne.ntyp1) then
5844           nbi=nbondterm(iti)
5845           if (nbi.eq.1) then
5846             diff=vbld(i+nres)-vbldsc0(1,iti)
5847 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5848 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5849             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5850             do j=1,3
5851               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5852             enddo
5853           else
5854             do j=1,nbi
5855               diff=vbld(i+nres)-vbldsc0(j,iti)
5856               ud(j)=aksc(j,iti)*diff
5857               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5858             enddo
5859             uprod=u(1)
5860             do j=2,nbi
5861               uprod=uprod*u(j)
5862             enddo
5863             usum=0.0d0
5864             usumsqder=0.0d0
5865             do j=1,nbi
5866               uprod1=1.0d0
5867               uprod2=1.0d0
5868               do k=1,nbi
5869                 if (k.ne.j) then
5870                   uprod1=uprod1*u(k)
5871                   uprod2=uprod2*u(k)*u(k)
5872                 endif
5873               enddo
5874               usum=usum+uprod1
5875               usumsqder=usumsqder+ud(j)*uprod2
5876             enddo
5877 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5878 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5879             estr=estr+uprod/usum
5880             do j=1,3
5881              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5882             enddo
5883           endif
5884         endif
5885       enddo
5886       return
5887       end
5888 #ifdef CRYST_THETA
5889 C--------------------------------------------------------------------------
5890       subroutine ebend(etheta,ethetacnstr)
5891 C
5892 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5893 C angles gamma and its derivatives in consecutive thetas and gammas.
5894 C
5895       implicit real*8 (a-h,o-z)
5896       include 'DIMENSIONS'
5897       include 'DIMENSIONS.ZSCOPT'
5898       include 'COMMON.LOCAL'
5899       include 'COMMON.GEO'
5900       include 'COMMON.INTERACT'
5901       include 'COMMON.DERIV'
5902       include 'COMMON.VAR'
5903       include 'COMMON.CHAIN'
5904       include 'COMMON.IOUNITS'
5905       include 'COMMON.NAMES'
5906       include 'COMMON.FFIELD'
5907       include 'COMMON.TORCNSTR'
5908       common /calcthet/ term1,term2,termm,diffak,ratak,
5909      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5910      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5911       double precision y(2),z(2)
5912       delta=0.02d0*pi
5913 c      time11=dexp(-2*time)
5914 c      time12=1.0d0
5915       etheta=0.0D0
5916 c      write (iout,*) "nres",nres
5917 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5918 c      write (iout,*) ithet_start,ithet_end
5919       do i=ithet_start,ithet_end
5920 C        if (itype(i-1).eq.ntyp1) cycle
5921         if (i.le.2) cycle
5922         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5923      &  .or.itype(i).eq.ntyp1) cycle
5924 C Zero the energy function and its derivative at 0 or pi.
5925         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5926         it=itype(i-1)
5927         ichir1=isign(1,itype(i-2))
5928         ichir2=isign(1,itype(i))
5929          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5930          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5931          if (itype(i-1).eq.10) then
5932           itype1=isign(10,itype(i-2))
5933           ichir11=isign(1,itype(i-2))
5934           ichir12=isign(1,itype(i-2))
5935           itype2=isign(10,itype(i))
5936           ichir21=isign(1,itype(i))
5937           ichir22=isign(1,itype(i))
5938          endif
5939          if (i.eq.3) then
5940           y(1)=0.0D0
5941           y(2)=0.0D0
5942           else
5943
5944         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5945 #ifdef OSF
5946           phii=phi(i)
5947 c          icrc=0
5948 c          call proc_proc(phii,icrc)
5949           if (icrc.eq.1) phii=150.0
5950 #else
5951           phii=phi(i)
5952 #endif
5953           y(1)=dcos(phii)
5954           y(2)=dsin(phii)
5955         else
5956           y(1)=0.0D0
5957           y(2)=0.0D0
5958         endif
5959         endif
5960         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5961 #ifdef OSF
5962           phii1=phi(i+1)
5963 c          icrc=0
5964 c          call proc_proc(phii1,icrc)
5965           if (icrc.eq.1) phii1=150.0
5966           phii1=pinorm(phii1)
5967           z(1)=cos(phii1)
5968 #else
5969           phii1=phi(i+1)
5970           z(1)=dcos(phii1)
5971 #endif
5972           z(2)=dsin(phii1)
5973         else
5974           z(1)=0.0D0
5975           z(2)=0.0D0
5976         endif
5977 C Calculate the "mean" value of theta from the part of the distribution
5978 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5979 C In following comments this theta will be referred to as t_c.
5980         thet_pred_mean=0.0d0
5981         do k=1,2
5982             athetk=athet(k,it,ichir1,ichir2)
5983             bthetk=bthet(k,it,ichir1,ichir2)
5984           if (it.eq.10) then
5985              athetk=athet(k,itype1,ichir11,ichir12)
5986              bthetk=bthet(k,itype2,ichir21,ichir22)
5987           endif
5988           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5989         enddo
5990 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5991         dthett=thet_pred_mean*ssd
5992         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5993 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5994 C Derivatives of the "mean" values in gamma1 and gamma2.
5995         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5996      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5997          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5998      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5999          if (it.eq.10) then
6000       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6001      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6002         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6003      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6004          endif
6005         if (theta(i).gt.pi-delta) then
6006           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6007      &         E_tc0)
6008           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6009           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6010           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6011      &        E_theta)
6012           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6013      &        E_tc)
6014         else if (theta(i).lt.delta) then
6015           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6016           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6017           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6018      &        E_theta)
6019           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6020           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6021      &        E_tc)
6022         else
6023           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6024      &        E_theta,E_tc)
6025         endif
6026         etheta=etheta+ethetai
6027 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6028 c     &      'ebend',i,ethetai,theta(i),itype(i)
6029 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
6030 c     &    rad2deg*phii,rad2deg*phii1,ethetai
6031         if (i.gt.3) then
6032           gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6033           gloc_compon(11,i-3)=gloc_compon(11,i-3)+E_tc*dthetg1
6034         endif
6035         if (i.lt.nres) then
6036           gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6037           gloc_compon(11,i-2)=gloc_compon(11,i-2)+E_tc*dthetg2
6038         endif
6039         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6040         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)
6041      &     +E_theta+E_tc*dthett
6042 c 1215   continue
6043       enddo
6044       ethetacnstr=0.0d0
6045 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6046       do i=1,ntheta_constr
6047         itheta=itheta_constr(i)
6048         thetiii=theta(itheta)
6049         difi=pinorm(thetiii-theta_constr0(i))
6050         if (difi.gt.theta_drange(i)) then
6051           difi=difi-theta_drange(i)
6052           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6053           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6054      &    +for_thet_constr(i)*difi**3
6055           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
6056      &    +for_thet_constr(i)*difi**3
6057         else if (difi.lt.-drange(i)) then
6058           difi=difi+drange(i)
6059           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6060           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6061      &    +for_thet_constr(i)*difi**3
6062           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
6063      &    +for_thet_constr(i)*difi**3
6064         else
6065           difi=0.0
6066         endif
6067 C       if (energy_dec) then
6068 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6069 C     &    i,itheta,rad2deg*thetiii,
6070 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6071 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6072 C     &    gloc(itheta+nphi-2,icg)
6073 C        endif
6074       enddo
6075 C Ufff.... We've done all this!!!
6076       return
6077       end
6078 C---------------------------------------------------------------------------
6079       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6080      &     E_tc)
6081       implicit real*8 (a-h,o-z)
6082       include 'DIMENSIONS'
6083       include 'COMMON.LOCAL'
6084       include 'COMMON.IOUNITS'
6085       common /calcthet/ term1,term2,termm,diffak,ratak,
6086      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6087      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6088 C Calculate the contributions to both Gaussian lobes.
6089 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6090 C The "polynomial part" of the "standard deviation" of this part of
6091 C the distribution.
6092         sig=polthet(3,it)
6093         do j=2,0,-1
6094           sig=sig*thet_pred_mean+polthet(j,it)
6095         enddo
6096 C Derivative of the "interior part" of the "standard deviation of the"
6097 C gamma-dependent Gaussian lobe in t_c.
6098         sigtc=3*polthet(3,it)
6099         do j=2,1,-1
6100           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6101         enddo
6102         sigtc=sig*sigtc
6103 C Set the parameters of both Gaussian lobes of the distribution.
6104 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6105         fac=sig*sig+sigc0(it)
6106         sigcsq=fac+fac
6107         sigc=1.0D0/sigcsq
6108 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6109         sigsqtc=-4.0D0*sigcsq*sigtc
6110 c       print *,i,sig,sigtc,sigsqtc
6111 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6112         sigtc=-sigtc/(fac*fac)
6113 C Following variable is sigma(t_c)**(-2)
6114         sigcsq=sigcsq*sigcsq
6115         sig0i=sig0(it)
6116         sig0inv=1.0D0/sig0i**2
6117         delthec=thetai-thet_pred_mean
6118         delthe0=thetai-theta0i
6119         term1=-0.5D0*sigcsq*delthec*delthec
6120         term2=-0.5D0*sig0inv*delthe0*delthe0
6121 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6122 C NaNs in taking the logarithm. We extract the largest exponent which is added
6123 C to the energy (this being the log of the distribution) at the end of energy
6124 C term evaluation for this virtual-bond angle.
6125         if (term1.gt.term2) then
6126           termm=term1
6127           term2=dexp(term2-termm)
6128           term1=1.0d0
6129         else
6130           termm=term2
6131           term1=dexp(term1-termm)
6132           term2=1.0d0
6133         endif
6134 C The ratio between the gamma-independent and gamma-dependent lobes of
6135 C the distribution is a Gaussian function of thet_pred_mean too.
6136         diffak=gthet(2,it)-thet_pred_mean
6137         ratak=diffak/gthet(3,it)**2
6138         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6139 C Let's differentiate it in thet_pred_mean NOW.
6140         aktc=ak*ratak
6141 C Now put together the distribution terms to make complete distribution.
6142         termexp=term1+ak*term2
6143         termpre=sigc+ak*sig0i
6144 C Contribution of the bending energy from this theta is just the -log of
6145 C the sum of the contributions from the two lobes and the pre-exponential
6146 C factor. Simple enough, isn't it?
6147         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6148 C NOW the derivatives!!!
6149 C 6/6/97 Take into account the deformation.
6150         E_theta=(delthec*sigcsq*term1
6151      &       +ak*delthe0*sig0inv*term2)/termexp
6152         E_tc=((sigtc+aktc*sig0i)/termpre
6153      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6154      &       aktc*term2)/termexp)
6155       return
6156       end
6157 c-----------------------------------------------------------------------------
6158       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6159       implicit real*8 (a-h,o-z)
6160       include 'DIMENSIONS'
6161       include 'COMMON.LOCAL'
6162       include 'COMMON.IOUNITS'
6163       common /calcthet/ term1,term2,termm,diffak,ratak,
6164      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6165      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6166       delthec=thetai-thet_pred_mean
6167       delthe0=thetai-theta0i
6168 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6169       t3 = thetai-thet_pred_mean
6170       t6 = t3**2
6171       t9 = term1
6172       t12 = t3*sigcsq
6173       t14 = t12+t6*sigsqtc
6174       t16 = 1.0d0
6175       t21 = thetai-theta0i
6176       t23 = t21**2
6177       t26 = term2
6178       t27 = t21*t26
6179       t32 = termexp
6180       t40 = t32**2
6181       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6182      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6183      & *(-t12*t9-ak*sig0inv*t27)
6184       return
6185       end
6186 #else
6187 C--------------------------------------------------------------------------
6188       subroutine ebend(etheta)
6189 C
6190 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6191 C angles gamma and its derivatives in consecutive thetas and gammas.
6192 C ab initio-derived potentials from
6193 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6194 C
6195       implicit real*8 (a-h,o-z)
6196       include 'DIMENSIONS'
6197       include 'DIMENSIONS.ZSCOPT'
6198       include 'COMMON.LOCAL'
6199       include 'COMMON.GEO'
6200       include 'COMMON.INTERACT'
6201       include 'COMMON.DERIV'
6202       include 'COMMON.VAR'
6203       include 'COMMON.CHAIN'
6204       include 'COMMON.IOUNITS'
6205       include 'COMMON.NAMES'
6206       include 'COMMON.FFIELD'
6207       include 'COMMON.CONTROL'
6208       include 'COMMON.TORCNSTR'
6209       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6210      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6211      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6212      & sinph1ph2(maxdouble,maxdouble)
6213       logical lprn /.false./, lprn1 /.false./
6214       etheta=0.0D0
6215 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6216       do i=ithet_start,ithet_end
6217 C         if (i.eq.2) cycle
6218 C        if (itype(i-1).eq.ntyp1) cycle
6219         if (i.le.2) cycle
6220         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6221      &  .or.itype(i).eq.ntyp1) cycle
6222         if (iabs(itype(i+1)).eq.20) iblock=2
6223         if (iabs(itype(i+1)).ne.20) iblock=1
6224         dethetai=0.0d0
6225         dephii=0.0d0
6226         dephii1=0.0d0
6227         theti2=0.5d0*theta(i)
6228         ityp2=ithetyp((itype(i-1)))
6229         do k=1,nntheterm
6230           coskt(k)=dcos(k*theti2)
6231           sinkt(k)=dsin(k*theti2)
6232         enddo
6233         if (i.eq.3) then
6234           phii=0.0d0
6235           ityp1=nthetyp+1
6236           do k=1,nsingle
6237             cosph1(k)=0.0d0
6238             sinph1(k)=0.0d0
6239           enddo
6240         else
6241         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6242 #ifdef OSF
6243           phii=phi(i)
6244           if (phii.ne.phii) phii=150.0
6245 #else
6246           phii=phi(i)
6247 #endif
6248           ityp1=ithetyp((itype(i-2)))
6249           do k=1,nsingle
6250             cosph1(k)=dcos(k*phii)
6251             sinph1(k)=dsin(k*phii)
6252           enddo
6253         else
6254           phii=0.0d0
6255 c          ityp1=nthetyp+1
6256           do k=1,nsingle
6257             ityp1=ithetyp((itype(i-2)))
6258             cosph1(k)=0.0d0
6259             sinph1(k)=0.0d0
6260           enddo
6261         endif
6262         endif
6263         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6264 #ifdef OSF
6265           phii1=phi(i+1)
6266           if (phii1.ne.phii1) phii1=150.0
6267           phii1=pinorm(phii1)
6268 #else
6269           phii1=phi(i+1)
6270 #endif
6271           ityp3=ithetyp((itype(i)))
6272           do k=1,nsingle
6273             cosph2(k)=dcos(k*phii1)
6274             sinph2(k)=dsin(k*phii1)
6275           enddo
6276         else
6277           phii1=0.0d0
6278 c          ityp3=nthetyp+1
6279           ityp3=ithetyp((itype(i)))
6280           do k=1,nsingle
6281             cosph2(k)=0.0d0
6282             sinph2(k)=0.0d0
6283           enddo
6284         endif
6285 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6286 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6287 c        call flush(iout)
6288         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6289         do k=1,ndouble
6290           do l=1,k-1
6291             ccl=cosph1(l)*cosph2(k-l)
6292             ssl=sinph1(l)*sinph2(k-l)
6293             scl=sinph1(l)*cosph2(k-l)
6294             csl=cosph1(l)*sinph2(k-l)
6295             cosph1ph2(l,k)=ccl-ssl
6296             cosph1ph2(k,l)=ccl+ssl
6297             sinph1ph2(l,k)=scl+csl
6298             sinph1ph2(k,l)=scl-csl
6299           enddo
6300         enddo
6301         if (lprn) then
6302         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6303      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6304         write (iout,*) "coskt and sinkt"
6305         do k=1,nntheterm
6306           write (iout,*) k,coskt(k),sinkt(k)
6307         enddo
6308         endif
6309         do k=1,ntheterm
6310           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6311           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6312      &      *coskt(k)
6313           if (lprn)
6314      &    write (iout,*) "k",k,"
6315      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6316      &     " ethetai",ethetai
6317         enddo
6318         if (lprn) then
6319         write (iout,*) "cosph and sinph"
6320         do k=1,nsingle
6321           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6322         enddo
6323         write (iout,*) "cosph1ph2 and sinph2ph2"
6324         do k=2,ndouble
6325           do l=1,k-1
6326             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6327      &         sinph1ph2(l,k),sinph1ph2(k,l)
6328           enddo
6329         enddo
6330         write(iout,*) "ethetai",ethetai
6331         endif
6332         do m=1,ntheterm2
6333           do k=1,nsingle
6334             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6335      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6336      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6337      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6338             ethetai=ethetai+sinkt(m)*aux
6339             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6340             dephii=dephii+k*sinkt(m)*(
6341      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6342      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6343             dephii1=dephii1+k*sinkt(m)*(
6344      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6345      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6346             if (lprn)
6347      &      write (iout,*) "m",m," k",k," bbthet",
6348      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6349      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6350      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6351      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6352           enddo
6353         enddo
6354         if (lprn)
6355      &  write(iout,*) "ethetai",ethetai
6356         do m=1,ntheterm3
6357           do k=2,ndouble
6358             do l=1,k-1
6359               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6360      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6361      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6362      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6363               ethetai=ethetai+sinkt(m)*aux
6364               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6365               dephii=dephii+l*sinkt(m)*(
6366      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6367      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6368      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6369      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6370               dephii1=dephii1+(k-l)*sinkt(m)*(
6371      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6372      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6373      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6374      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6375               if (lprn) then
6376               write (iout,*) "m",m," k",k," l",l," ffthet",
6377      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6378      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6379      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6380      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6381      &            " ethetai",ethetai
6382               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6383      &            cosph1ph2(k,l)*sinkt(m),
6384      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6385               endif
6386             enddo
6387           enddo
6388         enddo
6389 10      continue
6390         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6391      &   i,theta(i)*rad2deg,phii*rad2deg,
6392      &   phii1*rad2deg,ethetai
6393         etheta=etheta+ethetai
6394         if (i.gt.3) then
6395           gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6396           gloc_compon(11,i-3)=gloc_compon(11,i-3)+dephii
6397         endif
6398         if (i.lt.nres) then
6399           gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6400           gloc_compon(11,i-2)=gloc_compon(11,i-2)+dephii1
6401         endif
6402 c        gloc(nphi+i-2,icg)=wang*dethetai
6403         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6404         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)+dethetai
6405       enddo
6406       return
6407       end
6408 #endif
6409 #ifdef CRYST_SC
6410 c-----------------------------------------------------------------------------
6411       subroutine esc(escloc)
6412 C Calculate the local energy of a side chain and its derivatives in the
6413 C corresponding virtual-bond valence angles THETA and the spherical angles
6414 C ALPHA and OMEGA.
6415       implicit real*8 (a-h,o-z)
6416       include 'DIMENSIONS'
6417       include 'DIMENSIONS.ZSCOPT'
6418       include 'COMMON.GEO'
6419       include 'COMMON.LOCAL'
6420       include 'COMMON.VAR'
6421       include 'COMMON.INTERACT'
6422       include 'COMMON.DERIV'
6423       include 'COMMON.CHAIN'
6424       include 'COMMON.IOUNITS'
6425       include 'COMMON.NAMES'
6426       include 'COMMON.FFIELD'
6427       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6428      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6429       common /sccalc/ time11,time12,time112,theti,it,nlobit
6430       delta=0.02d0*pi
6431       escloc=0.0D0
6432 C      write (iout,*) 'ESC'
6433       do i=loc_start,loc_end
6434         it=itype(i)
6435         if (it.eq.ntyp1) cycle
6436         if (it.eq.10) goto 1
6437         nlobit=nlob(iabs(it))
6438 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6439 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6440         theti=theta(i+1)-pipol
6441         x(1)=dtan(theti)
6442         x(2)=alph(i)
6443         x(3)=omeg(i)
6444 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6445
6446         if (x(2).gt.pi-delta) then
6447           xtemp(1)=x(1)
6448           xtemp(2)=pi-delta
6449           xtemp(3)=x(3)
6450           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6451           xtemp(2)=pi
6452           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6453           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6454      &        escloci,dersc(2))
6455           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6456      &        ddersc0(1),dersc(1))
6457           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6458      &        ddersc0(3),dersc(3))
6459           xtemp(2)=pi-delta
6460           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6461           xtemp(2)=pi
6462           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6463           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6464      &            dersc0(2),esclocbi,dersc02)
6465           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6466      &            dersc12,dersc01)
6467           call splinthet(x(2),0.5d0*delta,ss,ssd)
6468           dersc0(1)=dersc01
6469           dersc0(2)=dersc02
6470           dersc0(3)=0.0d0
6471           do k=1,3
6472             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6473           enddo
6474           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6475           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6476      &             esclocbi,ss,ssd
6477           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6478 c         escloci=esclocbi
6479 c         write (iout,*) escloci
6480         else if (x(2).lt.delta) then
6481           xtemp(1)=x(1)
6482           xtemp(2)=delta
6483           xtemp(3)=x(3)
6484           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6485           xtemp(2)=0.0d0
6486           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6487           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6488      &        escloci,dersc(2))
6489           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6490      &        ddersc0(1),dersc(1))
6491           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6492      &        ddersc0(3),dersc(3))
6493           xtemp(2)=delta
6494           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6495           xtemp(2)=0.0d0
6496           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6497           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6498      &            dersc0(2),esclocbi,dersc02)
6499           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6500      &            dersc12,dersc01)
6501           dersc0(1)=dersc01
6502           dersc0(2)=dersc02
6503           dersc0(3)=0.0d0
6504           call splinthet(x(2),0.5d0*delta,ss,ssd)
6505           do k=1,3
6506             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6507           enddo
6508           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6509 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6510 c     &             esclocbi,ss,ssd
6511           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6512 C         write (iout,*) 'i=',i, escloci
6513         else
6514           call enesc(x,escloci,dersc,ddummy,.false.)
6515         endif
6516
6517         escloc=escloc+escloci
6518 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6519             write (iout,'(a6,i5,0pf7.3)')
6520      &     'escloc',i,escloci
6521
6522         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6523      &   wscloc*dersc(1)
6524         gloc_compon(12,nphi+i-1)=gloc_compon(12,nphi+i-1)+dersc(1)
6525         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6526         gloc_compon(12,ialph(i,1))=gloc_compon(12,ialph(i,1))+dersc(2)
6527         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6528         gloc_compon(12,ialph(i,1))=gloc_compon(12,ialph(i,1))+dersc(3)
6529     1   continue
6530       enddo
6531       return
6532       end
6533 C---------------------------------------------------------------------------
6534       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6535       implicit real*8 (a-h,o-z)
6536       include 'DIMENSIONS'
6537       include 'COMMON.GEO'
6538       include 'COMMON.LOCAL'
6539       include 'COMMON.IOUNITS'
6540       common /sccalc/ time11,time12,time112,theti,it,nlobit
6541       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6542       double precision contr(maxlob,-1:1)
6543       logical mixed
6544 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6545         escloc_i=0.0D0
6546         do j=1,3
6547           dersc(j)=0.0D0
6548           if (mixed) ddersc(j)=0.0d0
6549         enddo
6550         x3=x(3)
6551
6552 C Because of periodicity of the dependence of the SC energy in omega we have
6553 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6554 C To avoid underflows, first compute & store the exponents.
6555
6556         do iii=-1,1
6557
6558           x(3)=x3+iii*dwapi
6559
6560           do j=1,nlobit
6561             do k=1,3
6562               z(k)=x(k)-censc(k,j,it)
6563             enddo
6564             do k=1,3
6565               Axk=0.0D0
6566               do l=1,3
6567                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6568               enddo
6569               Ax(k,j,iii)=Axk
6570             enddo
6571             expfac=0.0D0
6572             do k=1,3
6573               expfac=expfac+Ax(k,j,iii)*z(k)
6574             enddo
6575             contr(j,iii)=expfac
6576           enddo ! j
6577
6578         enddo ! iii
6579
6580         x(3)=x3
6581 C As in the case of ebend, we want to avoid underflows in exponentiation and
6582 C subsequent NaNs and INFs in energy calculation.
6583 C Find the largest exponent
6584         emin=contr(1,-1)
6585         do iii=-1,1
6586           do j=1,nlobit
6587             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6588           enddo
6589         enddo
6590         emin=0.5D0*emin
6591 cd      print *,'it=',it,' emin=',emin
6592
6593 C Compute the contribution to SC energy and derivatives
6594         do iii=-1,1
6595
6596           do j=1,nlobit
6597             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6598 cd          print *,'j=',j,' expfac=',expfac
6599             escloc_i=escloc_i+expfac
6600             do k=1,3
6601               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6602             enddo
6603             if (mixed) then
6604               do k=1,3,2
6605                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6606      &            +gaussc(k,2,j,it))*expfac
6607               enddo
6608             endif
6609           enddo
6610
6611         enddo ! iii
6612
6613         dersc(1)=dersc(1)/cos(theti)**2
6614         ddersc(1)=ddersc(1)/cos(theti)**2
6615         ddersc(3)=ddersc(3)
6616
6617         escloci=-(dlog(escloc_i)-emin)
6618         do j=1,3
6619           dersc(j)=dersc(j)/escloc_i
6620         enddo
6621         if (mixed) then
6622           do j=1,3,2
6623             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6624           enddo
6625         endif
6626       return
6627       end
6628 C------------------------------------------------------------------------------
6629       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6630       implicit real*8 (a-h,o-z)
6631       include 'DIMENSIONS'
6632       include 'COMMON.GEO'
6633       include 'COMMON.LOCAL'
6634       include 'COMMON.IOUNITS'
6635       common /sccalc/ time11,time12,time112,theti,it,nlobit
6636       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6637       double precision contr(maxlob)
6638       logical mixed
6639
6640       escloc_i=0.0D0
6641
6642       do j=1,3
6643         dersc(j)=0.0D0
6644       enddo
6645
6646       do j=1,nlobit
6647         do k=1,2
6648           z(k)=x(k)-censc(k,j,it)
6649         enddo
6650         z(3)=dwapi
6651         do k=1,3
6652           Axk=0.0D0
6653           do l=1,3
6654             Axk=Axk+gaussc(l,k,j,it)*z(l)
6655           enddo
6656           Ax(k,j)=Axk
6657         enddo
6658         expfac=0.0D0
6659         do k=1,3
6660           expfac=expfac+Ax(k,j)*z(k)
6661         enddo
6662         contr(j)=expfac
6663       enddo ! j
6664
6665 C As in the case of ebend, we want to avoid underflows in exponentiation and
6666 C subsequent NaNs and INFs in energy calculation.
6667 C Find the largest exponent
6668       emin=contr(1)
6669       do j=1,nlobit
6670         if (emin.gt.contr(j)) emin=contr(j)
6671       enddo
6672       emin=0.5D0*emin
6673
6674 C Compute the contribution to SC energy and derivatives
6675
6676       dersc12=0.0d0
6677       do j=1,nlobit
6678         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6679         escloc_i=escloc_i+expfac
6680         do k=1,2
6681           dersc(k)=dersc(k)+Ax(k,j)*expfac
6682         enddo
6683         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6684      &            +gaussc(1,2,j,it))*expfac
6685         dersc(3)=0.0d0
6686       enddo
6687
6688       dersc(1)=dersc(1)/cos(theti)**2
6689       dersc12=dersc12/cos(theti)**2
6690       escloci=-(dlog(escloc_i)-emin)
6691       do j=1,2
6692         dersc(j)=dersc(j)/escloc_i
6693       enddo
6694       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6695       return
6696       end
6697 #else
6698 c----------------------------------------------------------------------------------
6699       subroutine esc(escloc)
6700 C Calculate the local energy of a side chain and its derivatives in the
6701 C corresponding virtual-bond valence angles THETA and the spherical angles
6702 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6703 C added by Urszula Kozlowska. 07/11/2007
6704 C
6705       implicit real*8 (a-h,o-z)
6706       include 'DIMENSIONS'
6707       include 'DIMENSIONS.ZSCOPT'
6708       include 'COMMON.GEO'
6709       include 'COMMON.LOCAL'
6710       include 'COMMON.VAR'
6711       include 'COMMON.SCROT'
6712       include 'COMMON.INTERACT'
6713       include 'COMMON.DERIV'
6714       include 'COMMON.CHAIN'
6715       include 'COMMON.IOUNITS'
6716       include 'COMMON.NAMES'
6717       include 'COMMON.FFIELD'
6718       include 'COMMON.CONTROL'
6719       include 'COMMON.VECTORS'
6720       double precision x_prime(3),y_prime(3),z_prime(3)
6721      &    , sumene,dsc_i,dp2_i,x(65),
6722      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6723      &    de_dxx,de_dyy,de_dzz,de_dt
6724       double precision s1_t,s1_6_t,s2_t,s2_6_t
6725       double precision
6726      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6727      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6728      & dt_dCi(3),dt_dCi1(3)
6729       common /sccalc/ time11,time12,time112,theti,it,nlobit
6730       delta=0.02d0*pi
6731       escloc=0.0D0
6732       do i=loc_start,loc_end
6733         if (itype(i).eq.ntyp1) cycle
6734         costtab(i+1) =dcos(theta(i+1))
6735         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6736         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6737         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6738         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6739         cosfac=dsqrt(cosfac2)
6740         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6741         sinfac=dsqrt(sinfac2)
6742         it=iabs(itype(i))
6743         if (it.eq.10) goto 1
6744 c
6745 C  Compute the axes of tghe local cartesian coordinates system; store in
6746 c   x_prime, y_prime and z_prime
6747 c
6748         do j=1,3
6749           x_prime(j) = 0.00
6750           y_prime(j) = 0.00
6751           z_prime(j) = 0.00
6752         enddo
6753 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6754 C     &   dc_norm(3,i+nres)
6755         do j = 1,3
6756           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6757           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6758         enddo
6759         do j = 1,3
6760           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6761         enddo
6762 c       write (2,*) "i",i
6763 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6764 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6765 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6766 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6767 c      & " xy",scalar(x_prime(1),y_prime(1)),
6768 c      & " xz",scalar(x_prime(1),z_prime(1)),
6769 c      & " yy",scalar(y_prime(1),y_prime(1)),
6770 c      & " yz",scalar(y_prime(1),z_prime(1)),
6771 c      & " zz",scalar(z_prime(1),z_prime(1))
6772 c
6773 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6774 C to local coordinate system. Store in xx, yy, zz.
6775 c
6776         xx=0.0d0
6777         yy=0.0d0
6778         zz=0.0d0
6779         do j = 1,3
6780           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6781           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6782           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6783         enddo
6784
6785         xxtab(i)=xx
6786         yytab(i)=yy
6787         zztab(i)=zz
6788 C
6789 C Compute the energy of the ith side cbain
6790 C
6791 c        write (2,*) "xx",xx," yy",yy," zz",zz
6792         it=iabs(itype(i))
6793         do j = 1,65
6794           x(j) = sc_parmin(j,it)
6795         enddo
6796 #ifdef CHECK_COORD
6797 Cc diagnostics - remove later
6798         xx1 = dcos(alph(2))
6799         yy1 = dsin(alph(2))*dcos(omeg(2))
6800         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6801         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6802      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6803      &    xx1,yy1,zz1
6804 C,"  --- ", xx_w,yy_w,zz_w
6805 c end diagnostics
6806 #endif
6807         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6808      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6809      &   + x(10)*yy*zz
6810         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6811      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6812      & + x(20)*yy*zz
6813         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6814      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6815      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6816      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6817      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6818      &  +x(40)*xx*yy*zz
6819         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6820      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6821      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6822      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6823      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6824      &  +x(60)*xx*yy*zz
6825         dsc_i   = 0.743d0+x(61)
6826         dp2_i   = 1.9d0+x(62)
6827         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6828      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6829         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6830      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6831         s1=(1+x(63))/(0.1d0 + dscp1)
6832         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6833         s2=(1+x(65))/(0.1d0 + dscp2)
6834         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6835         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6836      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6837 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6838 c     &   sumene4,
6839 c     &   dscp1,dscp2,sumene
6840 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6841         escloc = escloc + sumene
6842 c        write (2,*) "escloc",escloc
6843 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6844 c     &  zz,xx,yy
6845         if (.not. calc_grad) goto 1
6846 #ifdef DEBUG
6847 C
6848 C This section to check the numerical derivatives of the energy of ith side
6849 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6850 C #define DEBUG in the code to turn it on.
6851 C
6852         write (2,*) "sumene               =",sumene
6853         aincr=1.0d-7
6854         xxsave=xx
6855         xx=xx+aincr
6856         write (2,*) xx,yy,zz
6857         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6858         de_dxx_num=(sumenep-sumene)/aincr
6859         xx=xxsave
6860         write (2,*) "xx+ sumene from enesc=",sumenep
6861         yysave=yy
6862         yy=yy+aincr
6863         write (2,*) xx,yy,zz
6864         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6865         de_dyy_num=(sumenep-sumene)/aincr
6866         yy=yysave
6867         write (2,*) "yy+ sumene from enesc=",sumenep
6868         zzsave=zz
6869         zz=zz+aincr
6870         write (2,*) xx,yy,zz
6871         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6872         de_dzz_num=(sumenep-sumene)/aincr
6873         zz=zzsave
6874         write (2,*) "zz+ sumene from enesc=",sumenep
6875         costsave=cost2tab(i+1)
6876         sintsave=sint2tab(i+1)
6877         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6878         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6879         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6880         de_dt_num=(sumenep-sumene)/aincr
6881         write (2,*) " t+ sumene from enesc=",sumenep
6882         cost2tab(i+1)=costsave
6883         sint2tab(i+1)=sintsave
6884 C End of diagnostics section.
6885 #endif
6886 C
6887 C Compute the gradient of esc
6888 C
6889         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6890         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6891         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6892         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6893         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6894         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6895         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6896         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6897         pom1=(sumene3*sint2tab(i+1)+sumene1)
6898      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6899         pom2=(sumene4*cost2tab(i+1)+sumene2)
6900      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6901         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6902         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6903      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6904      &  +x(40)*yy*zz
6905         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6906         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6907      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6908      &  +x(60)*yy*zz
6909         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6910      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6911      &        +(pom1+pom2)*pom_dx
6912 #ifdef DEBUG
6913         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6914 #endif
6915 C
6916         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6917         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6918      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6919      &  +x(40)*xx*zz
6920         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6921         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6922      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6923      &  +x(59)*zz**2 +x(60)*xx*zz
6924         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6925      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6926      &        +(pom1-pom2)*pom_dy
6927 #ifdef DEBUG
6928         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6929 #endif
6930 C
6931         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6932      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6933      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6934      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6935      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6936      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6937      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6938      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6939 #ifdef DEBUG
6940         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6941 #endif
6942 C
6943         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6944      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6945      &  +pom1*pom_dt1+pom2*pom_dt2
6946 #ifdef DEBUG
6947         write(2,*), "de_dt = ", de_dt,de_dt_num
6948 #endif
6949 c
6950 C
6951        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6952        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6953        cosfac2xx=cosfac2*xx
6954        sinfac2yy=sinfac2*yy
6955        do k = 1,3
6956          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6957      &      vbld_inv(i+1)
6958          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6959      &      vbld_inv(i)
6960          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6961          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6962 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6963 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6964 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6965 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6966          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6967          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6968          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6969          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6970          dZZ_Ci1(k)=0.0d0
6971          dZZ_Ci(k)=0.0d0
6972          do j=1,3
6973            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6974      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6975            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6976      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6977          enddo
6978
6979          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6980          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6981          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6982 c
6983          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6984          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6985        enddo
6986
6987        do k=1,3
6988          dXX_Ctab(k,i)=dXX_Ci(k)
6989          dXX_C1tab(k,i)=dXX_Ci1(k)
6990          dYY_Ctab(k,i)=dYY_Ci(k)
6991          dYY_C1tab(k,i)=dYY_Ci1(k)
6992          dZZ_Ctab(k,i)=dZZ_Ci(k)
6993          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6994          dXX_XYZtab(k,i)=dXX_XYZ(k)
6995          dYY_XYZtab(k,i)=dYY_XYZ(k)
6996          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6997        enddo
6998
6999        do k = 1,3
7000 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7001 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7002 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7003 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7004 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7005 c     &    dt_dci(k)
7006 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7007 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7008          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7009      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7010          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7011      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7012          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7013      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7014        enddo
7015 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7016 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7017
7018 C to check gradient call subroutine check_grad
7019
7020     1 continue
7021       enddo
7022       return
7023       end
7024 #endif
7025 c------------------------------------------------------------------------------
7026       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7027 C
7028 C This procedure calculates two-body contact function g(rij) and its derivative:
7029 C
7030 C           eps0ij                                     !       x < -1
7031 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7032 C            0                                         !       x > 1
7033 C
7034 C where x=(rij-r0ij)/delta
7035 C
7036 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7037 C
7038       implicit none
7039       double precision rij,r0ij,eps0ij,fcont,fprimcont
7040       double precision x,x2,x4,delta
7041 c     delta=0.02D0*r0ij
7042 c      delta=0.2D0*r0ij
7043       x=(rij-r0ij)/delta
7044       if (x.lt.-1.0D0) then
7045         fcont=eps0ij
7046         fprimcont=0.0D0
7047       else if (x.le.1.0D0) then
7048         x2=x*x
7049         x4=x2*x2
7050         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7051         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7052       else
7053         fcont=0.0D0
7054         fprimcont=0.0D0
7055       endif
7056       return
7057       end
7058 c------------------------------------------------------------------------------
7059       subroutine splinthet(theti,delta,ss,ssder)
7060       implicit real*8 (a-h,o-z)
7061       include 'DIMENSIONS'
7062       include 'DIMENSIONS.ZSCOPT'
7063       include 'COMMON.VAR'
7064       include 'COMMON.GEO'
7065       thetup=pi-delta
7066       thetlow=delta
7067       if (theti.gt.pipol) then
7068         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7069       else
7070         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7071         ssder=-ssder
7072       endif
7073       return
7074       end
7075 c------------------------------------------------------------------------------
7076       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7077       implicit none
7078       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7079       double precision ksi,ksi2,ksi3,a1,a2,a3
7080       a1=fprim0*delta/(f1-f0)
7081       a2=3.0d0-2.0d0*a1
7082       a3=a1-2.0d0
7083       ksi=(x-x0)/delta
7084       ksi2=ksi*ksi
7085       ksi3=ksi2*ksi
7086       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7087       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7088       return
7089       end
7090 c------------------------------------------------------------------------------
7091       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7092       implicit none
7093       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7094       double precision ksi,ksi2,ksi3,a1,a2,a3
7095       ksi=(x-x0)/delta
7096       ksi2=ksi*ksi
7097       ksi3=ksi2*ksi
7098       a1=fprim0x*delta
7099       a2=3*(f1x-f0x)-2*fprim0x*delta
7100       a3=fprim0x*delta-2*(f1x-f0x)
7101       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7102       return
7103       end
7104 C-----------------------------------------------------------------------------
7105 #ifdef CRYST_TOR
7106 C-----------------------------------------------------------------------------
7107       subroutine etor(etors)
7108       implicit real*8 (a-h,o-z)
7109       include 'DIMENSIONS'
7110       include 'DIMENSIONS.ZSCOPT'
7111       include 'COMMON.VAR'
7112       include 'COMMON.GEO'
7113       include 'COMMON.LOCAL'
7114       include 'COMMON.TORSION'
7115       include 'COMMON.INTERACT'
7116       include 'COMMON.DERIV'
7117       include 'COMMON.CHAIN'
7118       include 'COMMON.NAMES'
7119       include 'COMMON.IOUNITS'
7120       include 'COMMON.FFIELD'
7121       include 'COMMON.TORCNSTR'
7122       logical lprn
7123 C Set lprn=.true. for debugging
7124       lprn=.false.
7125 c      lprn=.true.
7126       etors=0.0D0
7127       do i=iphi_start,iphi_end
7128         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7129      &      .or. itype(i).eq.ntyp1) cycle
7130         itori=itortyp(itype(i-2))
7131         itori1=itortyp(itype(i-1))
7132         phii=phi(i)
7133         gloci=0.0D0
7134 C Proline-Proline pair is a special case...
7135         if (itori.eq.3 .and. itori1.eq.3) then
7136           if (phii.gt.-dwapi3) then
7137             cosphi=dcos(3*phii)
7138             fac=1.0D0/(1.0D0-cosphi)
7139             etorsi=v1(1,3,3)*fac
7140             etorsi=etorsi+etorsi
7141             etors=etors+etorsi-v1(1,3,3)
7142             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7143           endif
7144           do j=1,3
7145             v1ij=v1(j+1,itori,itori1)
7146             v2ij=v2(j+1,itori,itori1)
7147             cosphi=dcos(j*phii)
7148             sinphi=dsin(j*phii)
7149             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7150             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7151           enddo
7152         else
7153           do j=1,nterm_old
7154             v1ij=v1(j,itori,itori1)
7155             v2ij=v2(j,itori,itori1)
7156             cosphi=dcos(j*phii)
7157             sinphi=dsin(j*phii)
7158             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7159             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7160           enddo
7161         endif
7162         if (lprn)
7163      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7164      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7165      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7166         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7167         gloc_compon(13,i-3)=gloc_compon(13,i-3)+gloci
7168 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7169       enddo
7170       return
7171       end
7172 c------------------------------------------------------------------------------
7173 #else
7174       subroutine etor(etors)
7175       implicit real*8 (a-h,o-z)
7176       include 'DIMENSIONS'
7177       include 'DIMENSIONS.ZSCOPT'
7178       include 'COMMON.VAR'
7179       include 'COMMON.GEO'
7180       include 'COMMON.LOCAL'
7181       include 'COMMON.TORSION'
7182       include 'COMMON.INTERACT'
7183       include 'COMMON.DERIV'
7184       include 'COMMON.CHAIN'
7185       include 'COMMON.NAMES'
7186       include 'COMMON.IOUNITS'
7187       include 'COMMON.FFIELD'
7188       include 'COMMON.TORCNSTR'
7189       include 'COMMON.WEIGHTS'
7190       include 'COMMON.WEIGHTDER'
7191       logical lprn
7192 C Set lprn=.true. for debugging
7193       lprn=.false.
7194 c      lprn=.true.
7195       etors=0.0D0
7196       do iblock=1,2
7197       do i=-ntyp+1,ntyp-1
7198         do j=-ntyp+1,ntyp-1
7199           do k=0,3
7200             do l=0,2*maxterm
7201               etor_temp(l,k,j,i,iblock)=0.0d0
7202             enddo
7203           enddo
7204         enddo
7205       enddo
7206       enddo
7207       do i=iphi_start,iphi_end
7208         if (i.le.2) cycle
7209         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7210      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7211         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7212         if (iabs(itype(i)).eq.20) then
7213           iblock=2
7214         else
7215           iblock=1
7216         endif
7217         itori=itortyp(itype(i-2))
7218         itori1=itortyp(itype(i-1))
7219         weitori=weitor(0,itori,itori1,iblock)
7220         phii=phi(i)
7221         gloci=0.0D0
7222         etori=0.0d0
7223 C Regular cosine and sine terms
7224         do j=1,nterm(itori,itori1,iblock)
7225           v1ij=v1(j,itori,itori1,iblock)
7226           v2ij=v2(j,itori,itori1,iblock)
7227           cosphi=dcos(j*phii)
7228           sinphi=dsin(j*phii)
7229           etori=etori+v1ij*cosphi+v2ij*sinphi
7230           etor_temp(j,0,itori,itori1,iblock)=
7231      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7232           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7233      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7234      &      sinphi*ww(13)
7235           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7236         enddo
7237 C Lorentz terms
7238 C                         v1
7239 C  E = SUM ----------------------------------- - v1
7240 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7241 C
7242         cosphi=dcos(0.5d0*phii)
7243         sinphi=dsin(0.5d0*phii)
7244         do j=1,nlor(itori,itori1,iblock)
7245           vl1ij=vlor1(j,itori,itori1)
7246           vl2ij=vlor2(j,itori,itori1)
7247           vl3ij=vlor3(j,itori,itori1)
7248           pom=vl2ij*cosphi+vl3ij*sinphi
7249           pom1=1.0d0/(pom*pom+1.0d0)
7250           etori=etori+vl1ij*pom1
7251           pom=-pom*pom1*pom1
7252           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7253         enddo
7254 C Subtract the constant term
7255         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7256         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7257      &    (etori-v0(itori,itori1,iblock))*ww(13)
7258
7259         if (lprn) then
7260         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7261      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7262      &  weitori,v0(itori,itori1,iblock)*weitori,
7263      &  (v1(j,itori,itori1,iblock)*weitori,
7264      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7265         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7266      &    iloctyp(itori1)," etor_temp",
7267      &    etor_temp(0,0,itori,itori1,1)
7268         call flush(iout)
7269         endif
7270         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7271         gloc_compon(13,i-3)=gloc_compon(13,i-3)+gloci
7272 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7273  1215   continue
7274       enddo
7275       return
7276       end
7277 c----------------------------------------------------------------------------
7278       subroutine etor_d(etors_d)
7279 C 6/23/01 Compute double torsional energy
7280       implicit real*8 (a-h,o-z)
7281       include 'DIMENSIONS'
7282       include 'DIMENSIONS.ZSCOPT'
7283       include 'COMMON.VAR'
7284       include 'COMMON.GEO'
7285       include 'COMMON.LOCAL'
7286       include 'COMMON.TORSION'
7287       include 'COMMON.INTERACT'
7288       include 'COMMON.DERIV'
7289       include 'COMMON.CHAIN'
7290       include 'COMMON.NAMES'
7291       include 'COMMON.IOUNITS'
7292       include 'COMMON.FFIELD'
7293       include 'COMMON.TORCNSTR'
7294       logical lprn
7295 C Set lprn=.true. for debugging
7296       lprn=.false.
7297 c     lprn=.true.
7298       etors_d=0.0D0
7299       do i=iphi_start,iphi_end-1
7300         if (i.le.3) cycle
7301 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7302 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7303          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7304      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7305      &  (itype(i+1).eq.ntyp1)) cycle
7306         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7307      &     goto 1215
7308         itori=itortyp(itype(i-2))
7309         itori1=itortyp(itype(i-1))
7310         itori2=itortyp(itype(i))
7311         phii=phi(i)
7312         phii1=phi(i+1)
7313         gloci1=0.0D0
7314         gloci2=0.0D0
7315         iblock=1
7316         if (iabs(itype(i+1)).eq.20) iblock=2
7317 C Regular cosine and sine terms
7318         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7319           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7320           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7321           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7322           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7323           cosphi1=dcos(j*phii)
7324           sinphi1=dsin(j*phii)
7325           cosphi2=dcos(j*phii1)
7326           sinphi2=dsin(j*phii1)
7327           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7328      &     v2cij*cosphi2+v2sij*sinphi2
7329           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7330           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7331         enddo
7332         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7333           do l=1,k-1
7334             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7335             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7336             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7337             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7338             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7339             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7340             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7341             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7342             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7343      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7344             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7345      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7346             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7347      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7348           enddo
7349         enddo
7350         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7351         gloc_compon(14,i-3)=gloc_compon(14,i-3)+gloci1
7352         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7353         gloc_compon(14,i-2)=gloc_compon(14,i-2)+gloci2
7354  1215   continue
7355       enddo
7356       return
7357       end
7358 #endif
7359 c---------------------------------------------------------------------------
7360 C The rigorous attempt to derive energy function
7361       subroutine etor_kcc(etors)
7362       implicit real*8 (a-h,o-z)
7363       include 'DIMENSIONS'
7364       include 'DIMENSIONS.ZSCOPT'
7365       include 'COMMON.VAR'
7366       include 'COMMON.GEO'
7367       include 'COMMON.LOCAL'
7368       include 'COMMON.TORSION'
7369       include 'COMMON.INTERACT'
7370       include 'COMMON.DERIV'
7371       include 'COMMON.CHAIN'
7372       include 'COMMON.NAMES'
7373       include 'COMMON.IOUNITS'
7374       include 'COMMON.FFIELD'
7375       include 'COMMON.TORCNSTR'
7376       include 'COMMON.CONTROL'
7377       include 'COMMON.WEIGHTS'
7378       include 'COMMON.WEIGHTDER'
7379       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7380       logical lprn
7381 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7382 C Set lprn=.true. for debugging
7383       lprn=energy_dec
7384 c      lprn=.true.
7385       if (lprn) write (iout,*)"ETOR_KCC"
7386       do iblock=1,2
7387       do i=-ntyp+1,ntyp-1
7388         do j=-ntyp+1,ntyp-1
7389           do k=0,3
7390             do l=0,2*maxterm
7391               etor_temp(l,k,j,i,iblock)=0.0d0
7392             enddo
7393           enddo
7394         enddo
7395       enddo
7396       enddo
7397       do i=-ntyp+1,ntyp-1
7398         do j=-ntyp+1,ntyp-1
7399           do k=0,2*maxtor_kcc
7400             do l=1,maxval_kcc
7401               do ll=1,maxval_kcc
7402                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7403               enddo
7404             enddo
7405           enddo
7406         enddo
7407       enddo
7408       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7409       etors=0.0D0
7410       do i=iphi_start,iphi_end
7411 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7412 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7413 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7414 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7415         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7416      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7417         itori=itortyp(itype(i-2))
7418         itori1=itortyp(itype(i-1))
7419         weitori=weitor(0,itori,itori1,1)
7420         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7421         phii=phi(i)
7422         glocig=0.0D0
7423         glocit1=0.0d0
7424         glocit2=0.0d0
7425 C to avoid multiple devision by 2
7426 c        theti22=0.5d0*theta(i)
7427 C theta 12 is the theta_1 /2
7428 C theta 22 is theta_2 /2
7429 c        theti12=0.5d0*theta(i-1)
7430 C and appropriate sinus function
7431         sinthet1=dsin(theta(i-1))
7432         sinthet2=dsin(theta(i))
7433         costhet1=dcos(theta(i-1))
7434         costhet2=dcos(theta(i))
7435 C to speed up lets store its mutliplication
7436         sint1t2=sinthet2*sinthet1
7437         sint1t2n=1.0d0
7438 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7439 C +d_n*sin(n*gamma)) *
7440 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7441 C we have two sum 1) Non-Chebyshev which is with n and gamma
7442         nval=nterm_kcc_Tb(itori,itori1)
7443         c1(0)=0.0d0
7444         c2(0)=0.0d0
7445         c1(1)=1.0d0
7446         c2(1)=1.0d0
7447         do j=2,nval
7448           c1(j)=c1(j-1)*costhet1
7449           c2(j)=c2(j-1)*costhet2
7450         enddo
7451         etori=0.0d0
7452         do j=1,nterm_kcc(itori,itori1)
7453           cosphi=dcos(j*phii)
7454           sinphi=dsin(j*phii)
7455           sint1t2n1=sint1t2n
7456           sint1t2n=sint1t2n*sint1t2
7457           sumvalc=0.0d0
7458           gradvalct1=0.0d0
7459           gradvalct2=0.0d0
7460           do k=1,nval
7461             do l=1,nval
7462               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7463               etor_temp_kcc(l,k,j,itori,itori1)=
7464      &           etor_temp_kcc(l,k,j,itori,itori1)+
7465      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7466               gradvalct1=gradvalct1+
7467      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7468               gradvalct2=gradvalct2+
7469      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7470             enddo
7471           enddo
7472           gradvalct1=-gradvalct1*sinthet1
7473           gradvalct2=-gradvalct2*sinthet2
7474           sumvals=0.0d0
7475           gradvalst1=0.0d0
7476           gradvalst2=0.0d0
7477           do k=1,nval
7478             do l=1,nval
7479               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7480               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7481      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7482      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7483               gradvalst1=gradvalst1+
7484      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7485               gradvalst2=gradvalst2+
7486      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7487             enddo
7488           enddo
7489           gradvalst1=-gradvalst1*sinthet1
7490           gradvalst2=-gradvalst2*sinthet2
7491           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7492           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7493      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7494 C glocig is the gradient local i site in gamma
7495           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7496 C now gradient over theta_1
7497           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7498      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7499           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7500      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7501         enddo ! j
7502         etors=etors+etori*weitori
7503 C derivative over gamma
7504         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7505         gloc_compon(13,i-3)=gloc_compon(13,i-3)+glocig
7506 C derivative over theta1
7507         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7508         gloc_compon(13,nphi+i-3)=gloc_compon(13,nphi+i-3)+glocit1
7509 C now derivative over theta2
7510         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7511         gloc_compon(13,nphi+i-2)=gloc_compon(13,nphi+i-2)+glocit2
7512         if (lprn)
7513      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7514      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7515       enddo
7516       return
7517       end
7518 c---------------------------------------------------------------------------------------------
7519       subroutine etor_constr(edihcnstr)
7520       implicit real*8 (a-h,o-z)
7521       include 'DIMENSIONS'
7522       include 'DIMENSIONS.ZSCOPT'
7523       include 'COMMON.VAR'
7524       include 'COMMON.GEO'
7525       include 'COMMON.LOCAL'
7526       include 'COMMON.TORSION'
7527       include 'COMMON.INTERACT'
7528       include 'COMMON.DERIV'
7529       include 'COMMON.CHAIN'
7530       include 'COMMON.NAMES'
7531       include 'COMMON.IOUNITS'
7532       include 'COMMON.FFIELD'
7533       include 'COMMON.TORCNSTR'
7534       include 'COMMON.CONTROL'
7535 ! 6/20/98 - dihedral angle constraints
7536       edihcnstr=0.0d0
7537 c      do i=1,ndih_constr
7538 c      write (iout,*) "idihconstr_start",idihconstr_start,
7539 c     &  " idihconstr_end",idihconstr_end
7540       do i=idihconstr_start,idihconstr_end
7541         itori=idih_constr(i)
7542         phii=phi(itori)
7543         difi=pinorm(phii-phi0(i))
7544         if (difi.gt.drange(i)) then
7545           difi=difi-drange(i)
7546           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7547           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7548           gloc_compon(13,itori-3)=gloc_compon(13,itori-3)
7549      &        +ftors(i)*difi**3
7550         else if (difi.lt.-drange(i)) then
7551           difi=difi+drange(i)
7552           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7553           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7554           gloc_compon(13,itori-3)=gloc_compon(13,itori-3)
7555      &        +ftors(i)*difi**3
7556         else
7557           difi=0.0
7558         endif
7559       enddo
7560       return
7561       end
7562 c----------------------------------------------------------------------------
7563 C The rigorous attempt to derive energy function
7564       subroutine ebend_kcc(etheta)
7565
7566       implicit real*8 (a-h,o-z)
7567       include 'DIMENSIONS'
7568       include 'DIMENSIONS.ZSCOPT'
7569       include 'COMMON.VAR'
7570       include 'COMMON.GEO'
7571       include 'COMMON.LOCAL'
7572       include 'COMMON.TORSION'
7573       include 'COMMON.INTERACT'
7574       include 'COMMON.DERIV'
7575       include 'COMMON.CHAIN'
7576       include 'COMMON.NAMES'
7577       include 'COMMON.IOUNITS'
7578       include 'COMMON.FFIELD'
7579       include 'COMMON.TORCNSTR'
7580       include 'COMMON.CONTROL'
7581       include 'COMMON.WEIGHTDER'
7582       logical lprn
7583       double precision thybt1(maxang_kcc)
7584 C Set lprn=.true. for debugging
7585       lprn=energy_dec
7586 c     lprn=.true.
7587 C      print *,"wchodze kcc"
7588       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7589       do i=0,ntyp
7590         do j=1,maxang_kcc
7591           ebend_temp_kcc(j,i)=0.0d0
7592         enddo
7593       enddo
7594       etheta=0.0D0
7595       do i=ithet_start,ithet_end
7596 c        print *,i,itype(i-1),itype(i),itype(i-2)
7597         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7598      &  .or.itype(i).eq.ntyp1) cycle
7599         iti=iabs(itortyp(itype(i-1)))
7600         sinthet=dsin(theta(i))
7601         costhet=dcos(theta(i))
7602         do j=1,nbend_kcc_Tb(iti)
7603           thybt1(j)=v1bend_chyb(j,iti)
7604           ebend_temp_kcc(j,iabs(iti))=
7605      &      ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i))
7606         enddo
7607         sumth1thyb=v1bend_chyb(0,iti)+
7608      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7609         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7610      &    sumth1thyb
7611         ihelp=nbend_kcc_Tb(iti)-1
7612         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7613         etheta=etheta+sumth1thyb
7614 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7615         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7616         gloc_compon(11,nphi+i-2)=gloc_compon(11,nphi+i-2)
7617      &    -gradthybt1*sinthet
7618       enddo
7619       return
7620       end
7621 c-------------------------------------------------------------------------------------
7622       subroutine etheta_constr(ethetacnstr)
7623
7624       implicit real*8 (a-h,o-z)
7625       include 'DIMENSIONS'
7626       include 'DIMENSIONS.ZSCOPT'
7627       include 'COMMON.VAR'
7628       include 'COMMON.GEO'
7629       include 'COMMON.LOCAL'
7630       include 'COMMON.TORSION'
7631       include 'COMMON.INTERACT'
7632       include 'COMMON.DERIV'
7633       include 'COMMON.CHAIN'
7634       include 'COMMON.NAMES'
7635       include 'COMMON.IOUNITS'
7636       include 'COMMON.FFIELD'
7637       include 'COMMON.TORCNSTR'
7638       include 'COMMON.CONTROL'
7639       ethetacnstr=0.0d0
7640 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7641       do i=ithetaconstr_start,ithetaconstr_end
7642         itheta=itheta_constr(i)
7643         thetiii=theta(itheta)
7644         difi=pinorm(thetiii-theta_constr0(i))
7645         if (difi.gt.theta_drange(i)) then
7646           difi=difi-theta_drange(i)
7647           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7648           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7649      &    +for_thet_constr(i)*difi**3
7650           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
7651      &      +for_thet_constr(i)*difi**3
7652         else if (difi.lt.-drange(i)) then
7653           difi=difi+drange(i)
7654           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7655           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7656      &    +for_thet_constr(i)*difi**3
7657           gloc_compon(11,itheta+nphi-2)=gloc_compon(11,itheta+nphi-2)
7658      &    +for_thet_constr(i)*difi**3
7659         else
7660           difi=0.0
7661         endif
7662        if (energy_dec) then
7663         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7664      &    i,itheta,rad2deg*thetiii,
7665      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7666      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7667      &    gloc(itheta+nphi-2,icg)
7668         endif
7669       enddo
7670       return
7671       end
7672 c------------------------------------------------------------------------------
7673       subroutine eback_sc_corr(esccor)
7674 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7675 c        conformational states; temporarily implemented as differences
7676 c        between UNRES torsional potentials (dependent on three types of
7677 c        residues) and the torsional potentials dependent on all 20 types
7678 c        of residues computed from AM1 energy surfaces of terminally-blocked
7679 c        amino-acid residues.
7680       implicit real*8 (a-h,o-z)
7681       include 'DIMENSIONS'
7682       include 'DIMENSIONS.ZSCOPT'
7683       include 'COMMON.VAR'
7684       include 'COMMON.GEO'
7685       include 'COMMON.LOCAL'
7686       include 'COMMON.TORSION'
7687       include 'COMMON.SCCOR'
7688       include 'COMMON.INTERACT'
7689       include 'COMMON.DERIV'
7690       include 'COMMON.CHAIN'
7691       include 'COMMON.NAMES'
7692       include 'COMMON.IOUNITS'
7693       include 'COMMON.FFIELD'
7694       include 'COMMON.CONTROL'
7695       logical lprn
7696 C Set lprn=.true. for debugging
7697       lprn=.false.
7698 c      lprn=.true.
7699 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7700       esccor=0.0D0
7701       do i=itau_start,itau_end
7702         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7703         esccor_ii=0.0D0
7704         isccori=isccortyp(itype(i-2))
7705         isccori1=isccortyp(itype(i-1))
7706         phii=phi(i)
7707         do intertyp=1,3 !intertyp
7708 cc Added 09 May 2012 (Adasko)
7709 cc  Intertyp means interaction type of backbone mainchain correlation:
7710 c   1 = SC...Ca...Ca...Ca
7711 c   2 = Ca...Ca...Ca...SC
7712 c   3 = SC...Ca...Ca...SCi
7713         gloci=0.0D0
7714         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7715      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7716      &      (itype(i-1).eq.ntyp1)))
7717      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7718      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7719      &     .or.(itype(i).eq.ntyp1)))
7720      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7721      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7722      &      (itype(i-3).eq.ntyp1)))) cycle
7723         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7724         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7725      & cycle
7726        do j=1,nterm_sccor(isccori,isccori1)
7727           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7728           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7729           cosphi=dcos(j*tauangle(intertyp,i))
7730           sinphi=dsin(j*tauangle(intertyp,i))
7731            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7732            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7733          enddo
7734 C      write (iout,*)"EBACK_SC_COR",esccor,i
7735 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7736 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7737 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7738         if (lprn)
7739      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7740      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7741      &  (v1sccor(j,1,itori,itori1),j=1,6)
7742      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7743 c        gsccor_loc(i-3)=gloci
7744        enddo !intertyp
7745       enddo
7746       return
7747       end
7748 c------------------------------------------------------------------------------
7749       subroutine multibody(ecorr)
7750 C This subroutine calculates multi-body contributions to energy following
7751 C the idea of Skolnick et al. If side chains I and J make a contact and
7752 C at the same time side chains I+1 and J+1 make a contact, an extra
7753 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7754       implicit real*8 (a-h,o-z)
7755       include 'DIMENSIONS'
7756       include 'DIMENSIONS.ZSCOPT'
7757       include 'COMMON.IOUNITS'
7758       include 'COMMON.DERIV'
7759       include 'COMMON.INTERACT'
7760       include 'COMMON.CONTACTS'
7761       double precision gx(3),gx1(3)
7762       logical lprn
7763
7764 C Set lprn=.true. for debugging
7765       lprn=.false.
7766
7767       if (lprn) then
7768         write (iout,'(a)') 'Contact function values:'
7769         do i=nnt,nct-2
7770           write (iout,'(i2,20(1x,i2,f10.5))')
7771      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7772         enddo
7773       endif
7774       ecorr=0.0D0
7775       do i=nnt,nct
7776         do j=1,3
7777           gradcorr(j,i)=0.0D0
7778           gradxorr(j,i)=0.0D0
7779         enddo
7780       enddo
7781       do i=nnt,nct-2
7782
7783         DO ISHIFT = 3,4
7784
7785         i1=i+ishift
7786         num_conti=num_cont(i)
7787         num_conti1=num_cont(i1)
7788         do jj=1,num_conti
7789           j=jcont(jj,i)
7790           do kk=1,num_conti1
7791             j1=jcont(kk,i1)
7792             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7793 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7794 cd   &                   ' ishift=',ishift
7795 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7796 C The system gains extra energy.
7797               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7798             endif   ! j1==j+-ishift
7799           enddo     ! kk
7800         enddo       ! jj
7801
7802         ENDDO ! ISHIFT
7803
7804       enddo         ! i
7805       return
7806       end
7807 c------------------------------------------------------------------------------
7808       double precision function esccorr(i,j,k,l,jj,kk)
7809       implicit real*8 (a-h,o-z)
7810       include 'DIMENSIONS'
7811       include 'DIMENSIONS.ZSCOPT'
7812       include 'COMMON.IOUNITS'
7813       include 'COMMON.DERIV'
7814       include 'COMMON.INTERACT'
7815       include 'COMMON.CONTACTS'
7816       double precision gx(3),gx1(3)
7817       logical lprn
7818       lprn=.false.
7819       eij=facont(jj,i)
7820       ekl=facont(kk,k)
7821 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7822 C Calculate the multi-body contribution to energy.
7823 C Calculate multi-body contributions to the gradient.
7824 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7825 cd   & k,l,(gacont(m,kk,k),m=1,3)
7826       do m=1,3
7827         gx(m) =ekl*gacont(m,jj,i)
7828         gx1(m)=eij*gacont(m,kk,k)
7829         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7830         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7831         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7832         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7833       enddo
7834       do m=i,j-1
7835         do ll=1,3
7836           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7837         enddo
7838       enddo
7839       do m=k,l-1
7840         do ll=1,3
7841           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7842         enddo
7843       enddo
7844       esccorr=-eij*ekl
7845       return
7846       end
7847 c------------------------------------------------------------------------------
7848       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7849 C This subroutine calculates multi-body contributions to hydrogen-bonding
7850       implicit real*8 (a-h,o-z)
7851       include 'DIMENSIONS'
7852       include 'DIMENSIONS.ZSCOPT'
7853       include 'COMMON.IOUNITS'
7854       include 'COMMON.FFIELD'
7855       include 'COMMON.DERIV'
7856       include 'COMMON.INTERACT'
7857       include 'COMMON.CONTACTS'
7858       double precision gx(3),gx1(3)
7859       logical lprn,ldone
7860
7861 C Set lprn=.true. for debugging
7862       lprn=.false.
7863       if (lprn) then
7864         write (iout,'(a)') 'Contact function values:'
7865         do i=nnt,nct-2
7866           write (iout,'(2i3,50(1x,i2,f5.2))')
7867      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7868      &    j=1,num_cont_hb(i))
7869         enddo
7870       endif
7871       ecorr=0.0D0
7872 C Remove the loop below after debugging !!!
7873       do i=nnt,nct
7874         do j=1,3
7875           gradcorr(j,i)=0.0D0
7876           gradxorr(j,i)=0.0D0
7877         enddo
7878       enddo
7879 C Calculate the local-electrostatic correlation terms
7880       do i=iatel_s,iatel_e+1
7881         i1=i+1
7882         num_conti=num_cont_hb(i)
7883         num_conti1=num_cont_hb(i+1)
7884         do jj=1,num_conti
7885           j=jcont_hb(jj,i)
7886           do kk=1,num_conti1
7887             j1=jcont_hb(kk,i1)
7888 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7889 c     &         ' jj=',jj,' kk=',kk
7890             if (j1.eq.j+1 .or. j1.eq.j-1) then
7891 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7892 C The system gains extra energy.
7893               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7894               n_corr=n_corr+1
7895             else if (j1.eq.j) then
7896 C Contacts I-J and I-(J+1) occur simultaneously.
7897 C The system loses extra energy.
7898 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7899             endif
7900           enddo ! kk
7901           do kk=1,num_conti
7902             j1=jcont_hb(kk,i)
7903 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7904 c    &         ' jj=',jj,' kk=',kk
7905             if (j1.eq.j+1) then
7906 C Contacts I-J and (I+1)-J occur simultaneously.
7907 C The system loses extra energy.
7908 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7909             endif ! j1==j+1
7910           enddo ! kk
7911         enddo ! jj
7912       enddo ! i
7913       return
7914       end
7915 c------------------------------------------------------------------------------
7916       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7917      &  n_corr1)
7918 C This subroutine calculates multi-body contributions to hydrogen-bonding
7919       implicit real*8 (a-h,o-z)
7920       include 'DIMENSIONS'
7921       include 'DIMENSIONS.ZSCOPT'
7922       include 'COMMON.IOUNITS'
7923 #ifdef MPI
7924       include "mpif.h"
7925 #endif
7926       include 'COMMON.FFIELD'
7927       include 'COMMON.DERIV'
7928       include 'COMMON.LOCAL'
7929       include 'COMMON.INTERACT'
7930       include 'COMMON.CONTACTS'
7931       include 'COMMON.CHAIN'
7932       include 'COMMON.CONTROL'
7933       include 'COMMON.SHIELD'
7934       double precision gx(3),gx1(3)
7935       integer num_cont_hb_old(maxres)
7936       logical lprn,ldone
7937       double precision eello4,eello5,eelo6,eello_turn6
7938       external eello4,eello5,eello6,eello_turn6
7939 C Set lprn=.true. for debugging
7940       lprn=.false.
7941       eturn6=0.0d0
7942       if (lprn) then
7943         write (iout,'(a)') 'Contact function values:'
7944         do i=nnt,nct-2
7945           write (iout,'(2i3,50(1x,i2,5f6.3))')
7946      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7947      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7948         enddo
7949       endif
7950       ecorr=0.0D0
7951       ecorr5=0.0d0
7952       ecorr6=0.0d0
7953 C Remove the loop below after debugging !!!
7954       do i=nnt,nct
7955         do j=1,3
7956           gradcorr(j,i)=0.0D0
7957           gradxorr(j,i)=0.0D0
7958         enddo
7959       enddo
7960 C Calculate the dipole-dipole interaction energies
7961       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7962       do i=iatel_s,iatel_e+1
7963         num_conti=num_cont_hb(i)
7964         do jj=1,num_conti
7965           j=jcont_hb(jj,i)
7966 #ifdef MOMENT
7967           call dipole(i,j,jj)
7968 #endif
7969         enddo
7970       enddo
7971       endif
7972 C Calculate the local-electrostatic correlation terms
7973 c                write (iout,*) "gradcorr5 in eello5 before loop"
7974 c                do iii=1,nres
7975 c                  write (iout,'(i5,3f10.5)')
7976 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7977 c                enddo
7978       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7979 c        write (iout,*) "corr loop i",i
7980         i1=i+1
7981         num_conti=num_cont_hb(i)
7982         num_conti1=num_cont_hb(i+1)
7983         do jj=1,num_conti
7984           j=jcont_hb(jj,i)
7985           jp=iabs(j)
7986           do kk=1,num_conti1
7987             j1=jcont_hb(kk,i1)
7988             jp1=iabs(j1)
7989 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7990 c     &         ' jj=',jj,' kk=',kk
7991 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7992             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7993      &          .or. j.lt.0 .and. j1.gt.0) .and.
7994      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7995 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7996 C The system gains extra energy.
7997               n_corr=n_corr+1
7998               sqd1=dsqrt(d_cont(jj,i))
7999               sqd2=dsqrt(d_cont(kk,i1))
8000               sred_geom = sqd1*sqd2
8001               IF (sred_geom.lt.cutoff_corr) THEN
8002                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8003      &            ekont,fprimcont)
8004 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8005 cd     &         ' jj=',jj,' kk=',kk
8006                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8007                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8008                 do l=1,3
8009                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8010                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8011                 enddo
8012                 n_corr1=n_corr1+1
8013 cd               write (iout,*) 'sred_geom=',sred_geom,
8014 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8015 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8016 cd               write (iout,*) "g_contij",g_contij
8017 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8018 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8019                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8020                 if (wcorr4.gt.0.0d0)
8021      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8022 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8023                   if (energy_dec.and.wcorr4.gt.0.0d0)
8024      1                 write (iout,'(a6,4i5,0pf7.3)')
8025      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8026 c                write (iout,*) "gradcorr5 before eello5"
8027 c                do iii=1,nres
8028 c                  write (iout,'(i5,3f10.5)')
8029 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8030 c                enddo
8031                 if (wcorr5.gt.0.0d0)
8032      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8033 c                write (iout,*) "gradcorr5 after eello5"
8034 c                do iii=1,nres
8035 c                  write (iout,'(i5,3f10.5)')
8036 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8037 c                enddo
8038                   if (energy_dec.and.wcorr5.gt.0.0d0)
8039      1                 write (iout,'(a6,4i5,0pf7.3)')
8040      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8041 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8042 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8043                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8044      &               .or. wturn6.eq.0.0d0))then
8045 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8046                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8047                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8048      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8049 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8050 cd     &            'ecorr6=',ecorr6
8051 cd                write (iout,'(4e15.5)') sred_geom,
8052 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8053 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8054 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8055                 else if (wturn6.gt.0.0d0
8056      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8057 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8058                   eturn6=eturn6+eello_turn6(i,jj,kk)
8059                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8060      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8061 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8062                 endif
8063               ENDIF
8064 1111          continue
8065             endif
8066           enddo ! kk
8067         enddo ! jj
8068       enddo ! i
8069       do i=1,nres
8070         num_cont_hb(i)=num_cont_hb_old(i)
8071       enddo
8072 c                write (iout,*) "gradcorr5 in eello5"
8073 c                do iii=1,nres
8074 c                  write (iout,'(i5,3f10.5)')
8075 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8076 c                enddo
8077       return
8078       end
8079 c------------------------------------------------------------------------------
8080       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8081       implicit real*8 (a-h,o-z)
8082       include 'DIMENSIONS'
8083       include 'DIMENSIONS.ZSCOPT'
8084       include 'COMMON.IOUNITS'
8085       include 'COMMON.DERIV'
8086       include 'COMMON.INTERACT'
8087       include 'COMMON.CONTACTS'
8088       include 'COMMON.SHIELD'
8089       include 'COMMON.CONTROL'
8090       double precision gx(3),gx1(3)
8091       logical lprn
8092       lprn=.false.
8093 C      print *,"wchodze",fac_shield(i),shield_mode
8094       eij=facont_hb(jj,i)
8095       ekl=facont_hb(kk,k)
8096       ees0pij=ees0p(jj,i)
8097       ees0pkl=ees0p(kk,k)
8098       ees0mij=ees0m(jj,i)
8099       ees0mkl=ees0m(kk,k)
8100       ekont=eij*ekl
8101       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8102 C*
8103 C     & fac_shield(i)**2*fac_shield(j)**2
8104 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8105 C Following 4 lines for diagnostics.
8106 cd    ees0pkl=0.0D0
8107 cd    ees0pij=1.0D0
8108 cd    ees0mkl=0.0D0
8109 cd    ees0mij=1.0D0
8110 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8111 c     & 'Contacts ',i,j,
8112 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8113 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8114 c     & 'gradcorr_long'
8115 C Calculate the multi-body contribution to energy.
8116 C      ecorr=ecorr+ekont*ees
8117 C Calculate multi-body contributions to the gradient.
8118       coeffpees0pij=coeffp*ees0pij
8119       coeffmees0mij=coeffm*ees0mij
8120       coeffpees0pkl=coeffp*ees0pkl
8121       coeffmees0mkl=coeffm*ees0mkl
8122       do ll=1,3
8123 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8124         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8125      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8126      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8127         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8128      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8129      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8130 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8131         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8132      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8133      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8134         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8135      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8136      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8137         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8138      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8139      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8140         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8141         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8142         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8143      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8144      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8145         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8146         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8147 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8148       enddo
8149 c      write (iout,*)
8150 cgrad      do m=i+1,j-1
8151 cgrad        do ll=1,3
8152 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8153 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8154 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8155 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8156 cgrad        enddo
8157 cgrad      enddo
8158 cgrad      do m=k+1,l-1
8159 cgrad        do ll=1,3
8160 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8161 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8162 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8163 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8164 cgrad        enddo
8165 cgrad      enddo
8166 c      write (iout,*) "ehbcorr",ekont*ees
8167 C      print *,ekont,ees,i,k
8168       ehbcorr=ekont*ees
8169 C now gradient over shielding
8170 C      return
8171       if (shield_mode.gt.0) then
8172        j=ees0plist(jj,i)
8173        l=ees0plist(kk,k)
8174 C        print *,i,j,fac_shield(i),fac_shield(j),
8175 C     &fac_shield(k),fac_shield(l)
8176         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8177      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8178           do ilist=1,ishield_list(i)
8179            iresshield=shield_list(ilist,i)
8180            do m=1,3
8181            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8182 C     &      *2.0
8183            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8184      &              rlocshield
8185      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8186             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8187      &+rlocshield
8188            enddo
8189           enddo
8190           do ilist=1,ishield_list(j)
8191            iresshield=shield_list(ilist,j)
8192            do m=1,3
8193            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8194 C     &     *2.0
8195            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8196      &              rlocshield
8197      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8198            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8199      &     +rlocshield
8200            enddo
8201           enddo
8202
8203           do ilist=1,ishield_list(k)
8204            iresshield=shield_list(ilist,k)
8205            do m=1,3
8206            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8207 C     &     *2.0
8208            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8209      &              rlocshield
8210      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8211            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8212      &     +rlocshield
8213            enddo
8214           enddo
8215           do ilist=1,ishield_list(l)
8216            iresshield=shield_list(ilist,l)
8217            do m=1,3
8218            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8219 C     &     *2.0
8220            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8221      &              rlocshield
8222      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8223            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8224      &     +rlocshield
8225            enddo
8226           enddo
8227 C          print *,gshieldx(m,iresshield)
8228           do m=1,3
8229             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8230      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8231             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8232      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8233             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8234      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8235             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8236      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8237
8238             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8239      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8240             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8241      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8242             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8243      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8244             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8245      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8246
8247            enddo
8248       endif
8249       endif
8250       return
8251       end
8252 #ifdef MOMENT
8253 C---------------------------------------------------------------------------
8254       subroutine dipole(i,j,jj)
8255       implicit real*8 (a-h,o-z)
8256       include 'DIMENSIONS'
8257       include 'DIMENSIONS.ZSCOPT'
8258       include 'COMMON.IOUNITS'
8259       include 'COMMON.CHAIN'
8260       include 'COMMON.FFIELD'
8261       include 'COMMON.DERIV'
8262       include 'COMMON.INTERACT'
8263       include 'COMMON.CONTACTS'
8264       include 'COMMON.TORSION'
8265       include 'COMMON.VAR'
8266       include 'COMMON.GEO'
8267       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8268      &  auxmat(2,2)
8269       iti1 = itortyp(itype(i+1))
8270       if (j.lt.nres-1) then
8271         itj1 = itype2loc(itype(j+1))
8272       else
8273         itj1=nloctyp
8274       endif
8275       do iii=1,2
8276         dipi(iii,1)=Ub2(iii,i)
8277         dipderi(iii)=Ub2der(iii,i)
8278         dipi(iii,2)=b1(iii,i+1)
8279         dipj(iii,1)=Ub2(iii,j)
8280         dipderj(iii)=Ub2der(iii,j)
8281         dipj(iii,2)=b1(iii,j+1)
8282       enddo
8283       kkk=0
8284       do iii=1,2
8285         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8286         do jjj=1,2
8287           kkk=kkk+1
8288           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8289         enddo
8290       enddo
8291       do kkk=1,5
8292         do lll=1,3
8293           mmm=0
8294           do iii=1,2
8295             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8296      &        auxvec(1))
8297             do jjj=1,2
8298               mmm=mmm+1
8299               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8300             enddo
8301           enddo
8302         enddo
8303       enddo
8304       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8305       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8306       do iii=1,2
8307         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8308       enddo
8309       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8310       do iii=1,2
8311         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8312       enddo
8313       return
8314       end
8315 #endif
8316 C---------------------------------------------------------------------------
8317       subroutine calc_eello(i,j,k,l,jj,kk)
8318 C
8319 C This subroutine computes matrices and vectors needed to calculate
8320 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8321 C
8322       implicit real*8 (a-h,o-z)
8323       include 'DIMENSIONS'
8324       include 'DIMENSIONS.ZSCOPT'
8325       include 'COMMON.IOUNITS'
8326       include 'COMMON.CHAIN'
8327       include 'COMMON.DERIV'
8328       include 'COMMON.INTERACT'
8329       include 'COMMON.CONTACTS'
8330       include 'COMMON.TORSION'
8331       include 'COMMON.VAR'
8332       include 'COMMON.GEO'
8333       include 'COMMON.FFIELD'
8334       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8335      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8336       logical lprn
8337       common /kutas/ lprn
8338 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8339 cd     & ' jj=',jj,' kk=',kk
8340 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8341 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8342 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8343       do iii=1,2
8344         do jjj=1,2
8345           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8346           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8347         enddo
8348       enddo
8349       call transpose2(aa1(1,1),aa1t(1,1))
8350       call transpose2(aa2(1,1),aa2t(1,1))
8351       do kkk=1,5
8352         do lll=1,3
8353           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8354      &      aa1tder(1,1,lll,kkk))
8355           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8356      &      aa2tder(1,1,lll,kkk))
8357         enddo
8358       enddo
8359       if (l.eq.j+1) then
8360 C parallel orientation of the two CA-CA-CA frames.
8361         if (i.gt.1) then
8362           iti=itype2loc(itype(i))
8363         else
8364           iti=nloctyp
8365         endif
8366         itk1=itype2loc(itype(k+1))
8367         itj=itype2loc(itype(j))
8368         if (l.lt.nres-1) then
8369           itl1=itype2loc(itype(l+1))
8370         else
8371           itl1=nloctyp
8372         endif
8373 C A1 kernel(j+1) A2T
8374 cd        do iii=1,2
8375 cd          write (iout,'(3f10.5,5x,3f10.5)')
8376 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8377 cd        enddo
8378         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8379      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8380      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8381 C Following matrices are needed only for 6-th order cumulants
8382         IF (wcorr6.gt.0.0d0) THEN
8383         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8384      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8385      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8386         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8387      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8388      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8389      &   ADtEAderx(1,1,1,1,1,1))
8390         lprn=.false.
8391         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8392      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8393      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8394      &   ADtEA1derx(1,1,1,1,1,1))
8395         ENDIF
8396 C End 6-th order cumulants
8397 cd        lprn=.false.
8398 cd        if (lprn) then
8399 cd        write (2,*) 'In calc_eello6'
8400 cd        do iii=1,2
8401 cd          write (2,*) 'iii=',iii
8402 cd          do kkk=1,5
8403 cd            write (2,*) 'kkk=',kkk
8404 cd            do jjj=1,2
8405 cd              write (2,'(3(2f10.5),5x)')
8406 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8407 cd            enddo
8408 cd          enddo
8409 cd        enddo
8410 cd        endif
8411         call transpose2(EUgder(1,1,k),auxmat(1,1))
8412         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8413         call transpose2(EUg(1,1,k),auxmat(1,1))
8414         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8415         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8416         do iii=1,2
8417           do kkk=1,5
8418             do lll=1,3
8419               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8420      &          EAEAderx(1,1,lll,kkk,iii,1))
8421             enddo
8422           enddo
8423         enddo
8424 C A1T kernel(i+1) A2
8425         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8426      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8427      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8428 C Following matrices are needed only for 6-th order cumulants
8429         IF (wcorr6.gt.0.0d0) THEN
8430         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8431      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8432      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8433         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8434      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8435      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8436      &   ADtEAderx(1,1,1,1,1,2))
8437         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8438      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8439      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8440      &   ADtEA1derx(1,1,1,1,1,2))
8441         ENDIF
8442 C End 6-th order cumulants
8443         call transpose2(EUgder(1,1,l),auxmat(1,1))
8444         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8445         call transpose2(EUg(1,1,l),auxmat(1,1))
8446         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8447         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8448         do iii=1,2
8449           do kkk=1,5
8450             do lll=1,3
8451               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8452      &          EAEAderx(1,1,lll,kkk,iii,2))
8453             enddo
8454           enddo
8455         enddo
8456 C AEAb1 and AEAb2
8457 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8458 C They are needed only when the fifth- or the sixth-order cumulants are
8459 C indluded.
8460         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8461         call transpose2(AEA(1,1,1),auxmat(1,1))
8462         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8463         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8464         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8465         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8466         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8467         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8468         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8469         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8470         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8471         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8472         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8473         call transpose2(AEA(1,1,2),auxmat(1,1))
8474         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8475         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8476         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8477         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8478         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8479         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8480         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8481         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8482         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8483         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8484         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8485 C Calculate the Cartesian derivatives of the vectors.
8486         do iii=1,2
8487           do kkk=1,5
8488             do lll=1,3
8489               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8490               call matvec2(auxmat(1,1),b1(1,i),
8491      &          AEAb1derx(1,lll,kkk,iii,1,1))
8492               call matvec2(auxmat(1,1),Ub2(1,i),
8493      &          AEAb2derx(1,lll,kkk,iii,1,1))
8494               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8495      &          AEAb1derx(1,lll,kkk,iii,2,1))
8496               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8497      &          AEAb2derx(1,lll,kkk,iii,2,1))
8498               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8499               call matvec2(auxmat(1,1),b1(1,j),
8500      &          AEAb1derx(1,lll,kkk,iii,1,2))
8501               call matvec2(auxmat(1,1),Ub2(1,j),
8502      &          AEAb2derx(1,lll,kkk,iii,1,2))
8503               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8504      &          AEAb1derx(1,lll,kkk,iii,2,2))
8505               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8506      &          AEAb2derx(1,lll,kkk,iii,2,2))
8507             enddo
8508           enddo
8509         enddo
8510         ENDIF
8511 C End vectors
8512       else
8513 C Antiparallel orientation of the two CA-CA-CA frames.
8514         if (i.gt.1) then
8515           iti=itype2loc(itype(i))
8516         else
8517           iti=nloctyp
8518         endif
8519         itk1=itype2loc(itype(k+1))
8520         itl=itype2loc(itype(l))
8521         itj=itype2loc(itype(j))
8522         if (j.lt.nres-1) then
8523           itj1=itype2loc(itype(j+1))
8524         else
8525           itj1=nloctyp
8526         endif
8527 C A2 kernel(j-1)T A1T
8528         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8529      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8530      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8531 C Following matrices are needed only for 6-th order cumulants
8532         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8533      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8534         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8535      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8536      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8537         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8538      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8539      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8540      &   ADtEAderx(1,1,1,1,1,1))
8541         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8542      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8543      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8544      &   ADtEA1derx(1,1,1,1,1,1))
8545         ENDIF
8546 C End 6-th order cumulants
8547         call transpose2(EUgder(1,1,k),auxmat(1,1))
8548         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8549         call transpose2(EUg(1,1,k),auxmat(1,1))
8550         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8551         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8552         do iii=1,2
8553           do kkk=1,5
8554             do lll=1,3
8555               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8556      &          EAEAderx(1,1,lll,kkk,iii,1))
8557             enddo
8558           enddo
8559         enddo
8560 C A2T kernel(i+1)T A1
8561         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8562      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8563      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8564 C Following matrices are needed only for 6-th order cumulants
8565         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8566      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8567         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8568      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8569      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8570         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8571      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8572      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8573      &   ADtEAderx(1,1,1,1,1,2))
8574         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8575      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8576      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8577      &   ADtEA1derx(1,1,1,1,1,2))
8578         ENDIF
8579 C End 6-th order cumulants
8580         call transpose2(EUgder(1,1,j),auxmat(1,1))
8581         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8582         call transpose2(EUg(1,1,j),auxmat(1,1))
8583         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8584         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8585         do iii=1,2
8586           do kkk=1,5
8587             do lll=1,3
8588               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8589      &          EAEAderx(1,1,lll,kkk,iii,2))
8590             enddo
8591           enddo
8592         enddo
8593 C AEAb1 and AEAb2
8594 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8595 C They are needed only when the fifth- or the sixth-order cumulants are
8596 C indluded.
8597         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8598      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8599         call transpose2(AEA(1,1,1),auxmat(1,1))
8600         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8601         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8602         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8603         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8604         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8605         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8606         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8607         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8608         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8609         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8610         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8611         call transpose2(AEA(1,1,2),auxmat(1,1))
8612         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8613         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8614         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8615         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8616         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8617         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8618         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8619         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8620         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8621         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8622         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8623 C Calculate the Cartesian derivatives of the vectors.
8624         do iii=1,2
8625           do kkk=1,5
8626             do lll=1,3
8627               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8628               call matvec2(auxmat(1,1),b1(1,i),
8629      &          AEAb1derx(1,lll,kkk,iii,1,1))
8630               call matvec2(auxmat(1,1),Ub2(1,i),
8631      &          AEAb2derx(1,lll,kkk,iii,1,1))
8632               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8633      &          AEAb1derx(1,lll,kkk,iii,2,1))
8634               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8635      &          AEAb2derx(1,lll,kkk,iii,2,1))
8636               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8637               call matvec2(auxmat(1,1),b1(1,l),
8638      &          AEAb1derx(1,lll,kkk,iii,1,2))
8639               call matvec2(auxmat(1,1),Ub2(1,l),
8640      &          AEAb2derx(1,lll,kkk,iii,1,2))
8641               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8642      &          AEAb1derx(1,lll,kkk,iii,2,2))
8643               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8644      &          AEAb2derx(1,lll,kkk,iii,2,2))
8645             enddo
8646           enddo
8647         enddo
8648         ENDIF
8649 C End vectors
8650       endif
8651       return
8652       end
8653 C---------------------------------------------------------------------------
8654       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8655      &  KK,KKderg,AKA,AKAderg,AKAderx)
8656       implicit none
8657       integer nderg
8658       logical transp
8659       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8660      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8661      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8662       integer iii,kkk,lll
8663       integer jjj,mmm
8664       logical lprn
8665       common /kutas/ lprn
8666       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8667       do iii=1,nderg
8668         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8669      &    AKAderg(1,1,iii))
8670       enddo
8671 cd      if (lprn) write (2,*) 'In kernel'
8672       do kkk=1,5
8673 cd        if (lprn) write (2,*) 'kkk=',kkk
8674         do lll=1,3
8675           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8676      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8677 cd          if (lprn) then
8678 cd            write (2,*) 'lll=',lll
8679 cd            write (2,*) 'iii=1'
8680 cd            do jjj=1,2
8681 cd              write (2,'(3(2f10.5),5x)')
8682 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8683 cd            enddo
8684 cd          endif
8685           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8686      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8687 cd          if (lprn) then
8688 cd            write (2,*) 'lll=',lll
8689 cd            write (2,*) 'iii=2'
8690 cd            do jjj=1,2
8691 cd              write (2,'(3(2f10.5),5x)')
8692 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8693 cd            enddo
8694 cd          endif
8695         enddo
8696       enddo
8697       return
8698       end
8699 C---------------------------------------------------------------------------
8700       double precision function eello4(i,j,k,l,jj,kk)
8701       implicit real*8 (a-h,o-z)
8702       include 'DIMENSIONS'
8703       include 'DIMENSIONS.ZSCOPT'
8704       include 'COMMON.IOUNITS'
8705       include 'COMMON.CHAIN'
8706       include 'COMMON.DERIV'
8707       include 'COMMON.INTERACT'
8708       include 'COMMON.CONTACTS'
8709       include 'COMMON.TORSION'
8710       include 'COMMON.VAR'
8711       include 'COMMON.GEO'
8712       double precision pizda(2,2),ggg1(3),ggg2(3)
8713 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8714 cd        eello4=0.0d0
8715 cd        return
8716 cd      endif
8717 cd      print *,'eello4:',i,j,k,l,jj,kk
8718 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8719 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8720 cold      eij=facont_hb(jj,i)
8721 cold      ekl=facont_hb(kk,k)
8722 cold      ekont=eij*ekl
8723       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8724       if (calc_grad) then
8725 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8726       gcorr_loc(k-1)=gcorr_loc(k-1)
8727      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8728       if (l.eq.j+1) then
8729         gcorr_loc(l-1)=gcorr_loc(l-1)
8730      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8731       else
8732         gcorr_loc(j-1)=gcorr_loc(j-1)
8733      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8734       endif
8735       do iii=1,2
8736         do kkk=1,5
8737           do lll=1,3
8738             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8739      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8740 cd            derx(lll,kkk,iii)=0.0d0
8741           enddo
8742         enddo
8743       enddo
8744 cd      gcorr_loc(l-1)=0.0d0
8745 cd      gcorr_loc(j-1)=0.0d0
8746 cd      gcorr_loc(k-1)=0.0d0
8747 cd      eel4=1.0d0
8748 cd      write (iout,*)'Contacts have occurred for peptide groups',
8749 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8750 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8751       if (j.lt.nres-1) then
8752         j1=j+1
8753         j2=j-1
8754       else
8755         j1=j-1
8756         j2=j-2
8757       endif
8758       if (l.lt.nres-1) then
8759         l1=l+1
8760         l2=l-1
8761       else
8762         l1=l-1
8763         l2=l-2
8764       endif
8765       do ll=1,3
8766 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8767 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8768         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8769         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8770 cgrad        ghalf=0.5d0*ggg1(ll)
8771         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8772         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8773         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8774         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8775         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8776         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8777 cgrad        ghalf=0.5d0*ggg2(ll)
8778         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8779         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8780         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8781         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8782         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8783         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8784       enddo
8785 cgrad      do m=i+1,j-1
8786 cgrad        do ll=1,3
8787 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8788 cgrad        enddo
8789 cgrad      enddo
8790 cgrad      do m=k+1,l-1
8791 cgrad        do ll=1,3
8792 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8793 cgrad        enddo
8794 cgrad      enddo
8795 cgrad      do m=i+2,j2
8796 cgrad        do ll=1,3
8797 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8798 cgrad        enddo
8799 cgrad      enddo
8800 cgrad      do m=k+2,l2
8801 cgrad        do ll=1,3
8802 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8803 cgrad        enddo
8804 cgrad      enddo
8805 cd      do iii=1,nres-3
8806 cd        write (2,*) iii,gcorr_loc(iii)
8807 cd      enddo
8808       endif ! calc_grad
8809       eello4=ekont*eel4
8810 cd      write (2,*) 'ekont',ekont
8811 cd      write (iout,*) 'eello4',ekont*eel4
8812       return
8813       end
8814 C---------------------------------------------------------------------------
8815       double precision function eello5(i,j,k,l,jj,kk)
8816       implicit real*8 (a-h,o-z)
8817       include 'DIMENSIONS'
8818       include 'DIMENSIONS.ZSCOPT'
8819       include 'COMMON.IOUNITS'
8820       include 'COMMON.CHAIN'
8821       include 'COMMON.DERIV'
8822       include 'COMMON.INTERACT'
8823       include 'COMMON.CONTACTS'
8824       include 'COMMON.TORSION'
8825       include 'COMMON.VAR'
8826       include 'COMMON.GEO'
8827       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8828       double precision ggg1(3),ggg2(3)
8829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8830 C                                                                              C
8831 C                            Parallel chains                                   C
8832 C                                                                              C
8833 C          o             o                   o             o                   C
8834 C         /l\           / \             \   / \           / \   /              C
8835 C        /   \         /   \             \ /   \         /   \ /               C
8836 C       j| o |l1       | o |              o| o |         | o |o                C
8837 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8838 C      \i/   \         /   \ /             /   \         /   \                 C
8839 C       o    k1             o                                                  C
8840 C         (I)          (II)                (III)          (IV)                 C
8841 C                                                                              C
8842 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8843 C                                                                              C
8844 C                            Antiparallel chains                               C
8845 C                                                                              C
8846 C          o             o                   o             o                   C
8847 C         /j\           / \             \   / \           / \   /              C
8848 C        /   \         /   \             \ /   \         /   \ /               C
8849 C      j1| o |l        | o |              o| o |         | o |o                C
8850 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8851 C      \i/   \         /   \ /             /   \         /   \                 C
8852 C       o     k1            o                                                  C
8853 C         (I)          (II)                (III)          (IV)                 C
8854 C                                                                              C
8855 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8856 C                                                                              C
8857 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8858 C                                                                              C
8859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8860 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8861 cd        eello5=0.0d0
8862 cd        return
8863 cd      endif
8864 cd      write (iout,*)
8865 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8866 cd     &   ' and',k,l
8867       itk=itype2loc(itype(k))
8868       itl=itype2loc(itype(l))
8869       itj=itype2loc(itype(j))
8870       eello5_1=0.0d0
8871       eello5_2=0.0d0
8872       eello5_3=0.0d0
8873       eello5_4=0.0d0
8874 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8875 cd     &   eel5_3_num,eel5_4_num)
8876       do iii=1,2
8877         do kkk=1,5
8878           do lll=1,3
8879             derx(lll,kkk,iii)=0.0d0
8880           enddo
8881         enddo
8882       enddo
8883 cd      eij=facont_hb(jj,i)
8884 cd      ekl=facont_hb(kk,k)
8885 cd      ekont=eij*ekl
8886 cd      write (iout,*)'Contacts have occurred for peptide groups',
8887 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8888 cd      goto 1111
8889 C Contribution from the graph I.
8890 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8891 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8892       call transpose2(EUg(1,1,k),auxmat(1,1))
8893       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8894       vv(1)=pizda(1,1)-pizda(2,2)
8895       vv(2)=pizda(1,2)+pizda(2,1)
8896       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8897      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8898       if (calc_grad) then
8899 C Explicit gradient in virtual-dihedral angles.
8900       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8901      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8902      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8903       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8904       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8905       vv(1)=pizda(1,1)-pizda(2,2)
8906       vv(2)=pizda(1,2)+pizda(2,1)
8907       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8908      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8909      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8910       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8911       vv(1)=pizda(1,1)-pizda(2,2)
8912       vv(2)=pizda(1,2)+pizda(2,1)
8913       if (l.eq.j+1) then
8914         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8915      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8916      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8917       else
8918         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8919      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8920      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8921       endif
8922 C Cartesian gradient
8923       do iii=1,2
8924         do kkk=1,5
8925           do lll=1,3
8926             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8927      &        pizda(1,1))
8928             vv(1)=pizda(1,1)-pizda(2,2)
8929             vv(2)=pizda(1,2)+pizda(2,1)
8930             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8931      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8932      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8933           enddo
8934         enddo
8935       enddo
8936       endif ! calc_grad
8937 c      goto 1112
8938 c1111  continue
8939 C Contribution from graph II
8940       call transpose2(EE(1,1,k),auxmat(1,1))
8941       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8942       vv(1)=pizda(1,1)+pizda(2,2)
8943       vv(2)=pizda(2,1)-pizda(1,2)
8944       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8945      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8946       if (calc_grad) then
8947 C Explicit gradient in virtual-dihedral angles.
8948       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8949      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8950       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8951       vv(1)=pizda(1,1)+pizda(2,2)
8952       vv(2)=pizda(2,1)-pizda(1,2)
8953       if (l.eq.j+1) then
8954         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8955      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8956      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8957       else
8958         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8959      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8960      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8961       endif
8962 C Cartesian gradient
8963       do iii=1,2
8964         do kkk=1,5
8965           do lll=1,3
8966             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8967      &        pizda(1,1))
8968             vv(1)=pizda(1,1)+pizda(2,2)
8969             vv(2)=pizda(2,1)-pizda(1,2)
8970             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8971      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8972      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8973           enddo
8974         enddo
8975       enddo
8976       endif ! calc_grad
8977 cd      goto 1112
8978 cd1111  continue
8979       if (l.eq.j+1) then
8980 cd        goto 1110
8981 C Parallel orientation
8982 C Contribution from graph III
8983         call transpose2(EUg(1,1,l),auxmat(1,1))
8984         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8985         vv(1)=pizda(1,1)-pizda(2,2)
8986         vv(2)=pizda(1,2)+pizda(2,1)
8987         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8988      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8989         if (calc_grad) then
8990 C Explicit gradient in virtual-dihedral angles.
8991         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8992      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8993      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8994         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8995         vv(1)=pizda(1,1)-pizda(2,2)
8996         vv(2)=pizda(1,2)+pizda(2,1)
8997         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8998      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8999      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9000         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9001         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9002         vv(1)=pizda(1,1)-pizda(2,2)
9003         vv(2)=pizda(1,2)+pizda(2,1)
9004         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9005      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9006      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9007 C Cartesian gradient
9008         do iii=1,2
9009           do kkk=1,5
9010             do lll=1,3
9011               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9012      &          pizda(1,1))
9013               vv(1)=pizda(1,1)-pizda(2,2)
9014               vv(2)=pizda(1,2)+pizda(2,1)
9015               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9016      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9017      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9018             enddo
9019           enddo
9020         enddo
9021 cd        goto 1112
9022 C Contribution from graph IV
9023 cd1110    continue
9024         call transpose2(EE(1,1,l),auxmat(1,1))
9025         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9026         vv(1)=pizda(1,1)+pizda(2,2)
9027         vv(2)=pizda(2,1)-pizda(1,2)
9028         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9029      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9030 C Explicit gradient in virtual-dihedral angles.
9031         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9032      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9033         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9034         vv(1)=pizda(1,1)+pizda(2,2)
9035         vv(2)=pizda(2,1)-pizda(1,2)
9036         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9037      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9038      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9039 C Cartesian gradient
9040         do iii=1,2
9041           do kkk=1,5
9042             do lll=1,3
9043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9044      &          pizda(1,1))
9045               vv(1)=pizda(1,1)+pizda(2,2)
9046               vv(2)=pizda(2,1)-pizda(1,2)
9047               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9048      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9049      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9050             enddo
9051           enddo
9052         enddo
9053         endif ! calc_grad
9054       else
9055 C Antiparallel orientation
9056 C Contribution from graph III
9057 c        goto 1110
9058         call transpose2(EUg(1,1,j),auxmat(1,1))
9059         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9060         vv(1)=pizda(1,1)-pizda(2,2)
9061         vv(2)=pizda(1,2)+pizda(2,1)
9062         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9063      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9064         if (calc_grad) then
9065 C Explicit gradient in virtual-dihedral angles.
9066         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9067      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9068      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9069         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9070         vv(1)=pizda(1,1)-pizda(2,2)
9071         vv(2)=pizda(1,2)+pizda(2,1)
9072         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9073      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9074      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9075         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9076         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9077         vv(1)=pizda(1,1)-pizda(2,2)
9078         vv(2)=pizda(1,2)+pizda(2,1)
9079         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9080      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9081      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9082 C Cartesian gradient
9083         do iii=1,2
9084           do kkk=1,5
9085             do lll=1,3
9086               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9087      &          pizda(1,1))
9088               vv(1)=pizda(1,1)-pizda(2,2)
9089               vv(2)=pizda(1,2)+pizda(2,1)
9090               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9091      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9092      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9093             enddo
9094           enddo
9095         enddo
9096         endif ! calc_grad
9097 cd        goto 1112
9098 C Contribution from graph IV
9099 1110    continue
9100         call transpose2(EE(1,1,j),auxmat(1,1))
9101         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9102         vv(1)=pizda(1,1)+pizda(2,2)
9103         vv(2)=pizda(2,1)-pizda(1,2)
9104         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9105      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9106         if (calc_grad) then
9107 C Explicit gradient in virtual-dihedral angles.
9108         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9109      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9110         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9111         vv(1)=pizda(1,1)+pizda(2,2)
9112         vv(2)=pizda(2,1)-pizda(1,2)
9113         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9114      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9115      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9116 C Cartesian gradient
9117         do iii=1,2
9118           do kkk=1,5
9119             do lll=1,3
9120               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9121      &          pizda(1,1))
9122               vv(1)=pizda(1,1)+pizda(2,2)
9123               vv(2)=pizda(2,1)-pizda(1,2)
9124               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9125      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9126      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9127             enddo
9128           enddo
9129         enddo
9130         endif ! calc_grad
9131       endif
9132 1112  continue
9133       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9134 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9135 cd        write (2,*) 'ijkl',i,j,k,l
9136 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9137 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9138 cd      endif
9139 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9140 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9141 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9142 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9143       if (calc_grad) then
9144       if (j.lt.nres-1) then
9145         j1=j+1
9146         j2=j-1
9147       else
9148         j1=j-1
9149         j2=j-2
9150       endif
9151       if (l.lt.nres-1) then
9152         l1=l+1
9153         l2=l-1
9154       else
9155         l1=l-1
9156         l2=l-2
9157       endif
9158 cd      eij=1.0d0
9159 cd      ekl=1.0d0
9160 cd      ekont=1.0d0
9161 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9162 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9163 C        summed up outside the subrouine as for the other subroutines
9164 C        handling long-range interactions. The old code is commented out
9165 C        with "cgrad" to keep track of changes.
9166       do ll=1,3
9167 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9168 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9169         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9170         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9171 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9172 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9173 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9174 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9175 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9176 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9177 c     &   gradcorr5ij,
9178 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9179 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9180 cgrad        ghalf=0.5d0*ggg1(ll)
9181 cd        ghalf=0.0d0
9182         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9183         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9184         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9185         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9186         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9187         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9188 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9189 cgrad        ghalf=0.5d0*ggg2(ll)
9190 cd        ghalf=0.0d0
9191         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9192         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9193         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9194         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9195         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9196         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9197       enddo
9198       endif ! calc_grad
9199 cd      goto 1112
9200 cgrad      do m=i+1,j-1
9201 cgrad        do ll=1,3
9202 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9203 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9204 cgrad        enddo
9205 cgrad      enddo
9206 cgrad      do m=k+1,l-1
9207 cgrad        do ll=1,3
9208 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9209 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9210 cgrad        enddo
9211 cgrad      enddo
9212 c1112  continue
9213 cgrad      do m=i+2,j2
9214 cgrad        do ll=1,3
9215 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9216 cgrad        enddo
9217 cgrad      enddo
9218 cgrad      do m=k+2,l2
9219 cgrad        do ll=1,3
9220 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9221 cgrad        enddo
9222 cgrad      enddo
9223 cd      do iii=1,nres-3
9224 cd        write (2,*) iii,g_corr5_loc(iii)
9225 cd      enddo
9226       eello5=ekont*eel5
9227 cd      write (2,*) 'ekont',ekont
9228 cd      write (iout,*) 'eello5',ekont*eel5
9229       return
9230       end
9231 c--------------------------------------------------------------------------
9232       double precision function eello6(i,j,k,l,jj,kk)
9233       implicit real*8 (a-h,o-z)
9234       include 'DIMENSIONS'
9235       include 'DIMENSIONS.ZSCOPT'
9236       include 'COMMON.IOUNITS'
9237       include 'COMMON.CHAIN'
9238       include 'COMMON.DERIV'
9239       include 'COMMON.INTERACT'
9240       include 'COMMON.CONTACTS'
9241       include 'COMMON.TORSION'
9242       include 'COMMON.VAR'
9243       include 'COMMON.GEO'
9244       include 'COMMON.FFIELD'
9245       double precision ggg1(3),ggg2(3)
9246 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9247 cd        eello6=0.0d0
9248 cd        return
9249 cd      endif
9250 cd      write (iout,*)
9251 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9252 cd     &   ' and',k,l
9253       eello6_1=0.0d0
9254       eello6_2=0.0d0
9255       eello6_3=0.0d0
9256       eello6_4=0.0d0
9257       eello6_5=0.0d0
9258       eello6_6=0.0d0
9259 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9260 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9261       do iii=1,2
9262         do kkk=1,5
9263           do lll=1,3
9264             derx(lll,kkk,iii)=0.0d0
9265           enddo
9266         enddo
9267       enddo
9268 cd      eij=facont_hb(jj,i)
9269 cd      ekl=facont_hb(kk,k)
9270 cd      ekont=eij*ekl
9271 cd      eij=1.0d0
9272 cd      ekl=1.0d0
9273 cd      ekont=1.0d0
9274       if (l.eq.j+1) then
9275         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9276         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9277         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9278         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9279         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9280         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9281       else
9282         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9283         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9284         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9285         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9286         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9287           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9288         else
9289           eello6_5=0.0d0
9290         endif
9291         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9292       endif
9293 C If turn contributions are considered, they will be handled separately.
9294       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9295 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9296 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9297 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9298 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9299 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9300 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9301 cd      goto 1112
9302       if (calc_grad) then
9303       if (j.lt.nres-1) then
9304         j1=j+1
9305         j2=j-1
9306       else
9307         j1=j-1
9308         j2=j-2
9309       endif
9310       if (l.lt.nres-1) then
9311         l1=l+1
9312         l2=l-1
9313       else
9314         l1=l-1
9315         l2=l-2
9316       endif
9317       do ll=1,3
9318 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9319 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9320 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9321 cgrad        ghalf=0.5d0*ggg1(ll)
9322 cd        ghalf=0.0d0
9323         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9324         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9325         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9326         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9327         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9328         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9329         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9330         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9331 cgrad        ghalf=0.5d0*ggg2(ll)
9332 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9333 cd        ghalf=0.0d0
9334         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9335         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9336         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9337         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9338         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9339         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9340       enddo
9341       endif ! calc_grad
9342 cd      goto 1112
9343 cgrad      do m=i+1,j-1
9344 cgrad        do ll=1,3
9345 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9346 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9347 cgrad        enddo
9348 cgrad      enddo
9349 cgrad      do m=k+1,l-1
9350 cgrad        do ll=1,3
9351 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9352 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9353 cgrad        enddo
9354 cgrad      enddo
9355 cgrad1112  continue
9356 cgrad      do m=i+2,j2
9357 cgrad        do ll=1,3
9358 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9359 cgrad        enddo
9360 cgrad      enddo
9361 cgrad      do m=k+2,l2
9362 cgrad        do ll=1,3
9363 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9364 cgrad        enddo
9365 cgrad      enddo
9366 cd      do iii=1,nres-3
9367 cd        write (2,*) iii,g_corr6_loc(iii)
9368 cd      enddo
9369       eello6=ekont*eel6
9370 cd      write (2,*) 'ekont',ekont
9371 cd      write (iout,*) 'eello6',ekont*eel6
9372       return
9373       end
9374 c--------------------------------------------------------------------------
9375       double precision function eello6_graph1(i,j,k,l,imat,swap)
9376       implicit real*8 (a-h,o-z)
9377       include 'DIMENSIONS'
9378       include 'DIMENSIONS.ZSCOPT'
9379       include 'COMMON.IOUNITS'
9380       include 'COMMON.CHAIN'
9381       include 'COMMON.DERIV'
9382       include 'COMMON.INTERACT'
9383       include 'COMMON.CONTACTS'
9384       include 'COMMON.TORSION'
9385       include 'COMMON.VAR'
9386       include 'COMMON.GEO'
9387       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9388       logical swap
9389       logical lprn
9390       common /kutas/ lprn
9391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9392 C                                                                              C
9393 C      Parallel       Antiparallel                                             C
9394 C                                                                              C
9395 C          o             o                                                     C
9396 C         /l\           /j\                                                    C
9397 C        /   \         /   \                                                   C
9398 C       /| o |         | o |\                                                  C
9399 C     \ j|/k\|  /   \  |/k\|l /                                                C
9400 C      \ /   \ /     \ /   \ /                                                 C
9401 C       o     o       o     o                                                  C
9402 C       i             i                                                        C
9403 C                                                                              C
9404 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9405       itk=itype2loc(itype(k))
9406       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9407       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9408       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9409       call transpose2(EUgC(1,1,k),auxmat(1,1))
9410       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9411       vv1(1)=pizda1(1,1)-pizda1(2,2)
9412       vv1(2)=pizda1(1,2)+pizda1(2,1)
9413       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9414       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9415       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9416       s5=scalar2(vv(1),Dtobr2(1,i))
9417 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9418       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9419       if (calc_grad) then
9420       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9421      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9422      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9423      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9424      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9425      & +scalar2(vv(1),Dtobr2der(1,i)))
9426       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9427       vv1(1)=pizda1(1,1)-pizda1(2,2)
9428       vv1(2)=pizda1(1,2)+pizda1(2,1)
9429       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9430       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9431       if (l.eq.j+1) then
9432         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9433      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9434      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9435      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9436      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9437       else
9438         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9439      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9440      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9441      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9442      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9443       endif
9444       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9445       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9446       vv1(1)=pizda1(1,1)-pizda1(2,2)
9447       vv1(2)=pizda1(1,2)+pizda1(2,1)
9448       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9449      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9450      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9451      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9452       do iii=1,2
9453         if (swap) then
9454           ind=3-iii
9455         else
9456           ind=iii
9457         endif
9458         do kkk=1,5
9459           do lll=1,3
9460             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9461             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9462             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9463             call transpose2(EUgC(1,1,k),auxmat(1,1))
9464             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9465      &        pizda1(1,1))
9466             vv1(1)=pizda1(1,1)-pizda1(2,2)
9467             vv1(2)=pizda1(1,2)+pizda1(2,1)
9468             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9469             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9470      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9471             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9472      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9473             s5=scalar2(vv(1),Dtobr2(1,i))
9474             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9475           enddo
9476         enddo
9477       enddo
9478       endif ! calc_grad
9479       return
9480       end
9481 c----------------------------------------------------------------------------
9482       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9483       implicit real*8 (a-h,o-z)
9484       include 'DIMENSIONS'
9485       include 'DIMENSIONS.ZSCOPT'
9486       include 'COMMON.IOUNITS'
9487       include 'COMMON.CHAIN'
9488       include 'COMMON.DERIV'
9489       include 'COMMON.INTERACT'
9490       include 'COMMON.CONTACTS'
9491       include 'COMMON.TORSION'
9492       include 'COMMON.VAR'
9493       include 'COMMON.GEO'
9494       logical swap
9495       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9496      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9497       logical lprn
9498       common /kutas/ lprn
9499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9500 C                                                                              C
9501 C      Parallel       Antiparallel                                             C
9502 C                                                                              C
9503 C          o             o                                                     C
9504 C     \   /l\           /j\   /                                                C
9505 C      \ /   \         /   \ /                                                 C
9506 C       o| o |         | o |o                                                  C
9507 C     \ j|/k\|      \  |/k\|l                                                  C
9508 C      \ /   \       \ /   \                                                   C
9509 C       o             o                                                        C
9510 C       i             i                                                        C
9511 C                                                                              C
9512 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9513 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9514 C AL 7/4/01 s1 would occur in the sixth-order moment,
9515 C           but not in a cluster cumulant
9516 #ifdef MOMENT
9517       s1=dip(1,jj,i)*dip(1,kk,k)
9518 #endif
9519       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9520       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9521       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9522       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9523       call transpose2(EUg(1,1,k),auxmat(1,1))
9524       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9525       vv(1)=pizda(1,1)-pizda(2,2)
9526       vv(2)=pizda(1,2)+pizda(2,1)
9527       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9528 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9529 #ifdef MOMENT
9530       eello6_graph2=-(s1+s2+s3+s4)
9531 #else
9532       eello6_graph2=-(s2+s3+s4)
9533 #endif
9534 c      eello6_graph2=-s3
9535 C Derivatives in gamma(i-1)
9536       if (calc_grad) then
9537       if (i.gt.1) then
9538 #ifdef MOMENT
9539         s1=dipderg(1,jj,i)*dip(1,kk,k)
9540 #endif
9541         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9542         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9543         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9544         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9545 #ifdef MOMENT
9546         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9547 #else
9548         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9549 #endif
9550 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9551       endif
9552 C Derivatives in gamma(k-1)
9553 #ifdef MOMENT
9554       s1=dip(1,jj,i)*dipderg(1,kk,k)
9555 #endif
9556       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9557       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9558       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9559       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9560       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9561       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9562       vv(1)=pizda(1,1)-pizda(2,2)
9563       vv(2)=pizda(1,2)+pizda(2,1)
9564       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9565 #ifdef MOMENT
9566       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9567 #else
9568       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9569 #endif
9570 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9571 C Derivatives in gamma(j-1) or gamma(l-1)
9572       if (j.gt.1) then
9573 #ifdef MOMENT
9574         s1=dipderg(3,jj,i)*dip(1,kk,k)
9575 #endif
9576         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9577         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9578         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9579         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9580         vv(1)=pizda(1,1)-pizda(2,2)
9581         vv(2)=pizda(1,2)+pizda(2,1)
9582         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9583 #ifdef MOMENT
9584         if (swap) then
9585           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9586         else
9587           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9588         endif
9589 #endif
9590         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9591 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9592       endif
9593 C Derivatives in gamma(l-1) or gamma(j-1)
9594       if (l.gt.1) then
9595 #ifdef MOMENT
9596         s1=dip(1,jj,i)*dipderg(3,kk,k)
9597 #endif
9598         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9599         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9600         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9601         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9602         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9603         vv(1)=pizda(1,1)-pizda(2,2)
9604         vv(2)=pizda(1,2)+pizda(2,1)
9605         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9606 #ifdef MOMENT
9607         if (swap) then
9608           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9609         else
9610           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9611         endif
9612 #endif
9613         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9614 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9615       endif
9616 C Cartesian derivatives.
9617       if (lprn) then
9618         write (2,*) 'In eello6_graph2'
9619         do iii=1,2
9620           write (2,*) 'iii=',iii
9621           do kkk=1,5
9622             write (2,*) 'kkk=',kkk
9623             do jjj=1,2
9624               write (2,'(3(2f10.5),5x)')
9625      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9626             enddo
9627           enddo
9628         enddo
9629       endif
9630       do iii=1,2
9631         do kkk=1,5
9632           do lll=1,3
9633 #ifdef MOMENT
9634             if (iii.eq.1) then
9635               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9636             else
9637               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9638             endif
9639 #endif
9640             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9641      &        auxvec(1))
9642             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9643             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9644      &        auxvec(1))
9645             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9646             call transpose2(EUg(1,1,k),auxmat(1,1))
9647             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9648      &        pizda(1,1))
9649             vv(1)=pizda(1,1)-pizda(2,2)
9650             vv(2)=pizda(1,2)+pizda(2,1)
9651             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9652 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9653 #ifdef MOMENT
9654             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9655 #else
9656             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9657 #endif
9658             if (swap) then
9659               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9660             else
9661               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9662             endif
9663           enddo
9664         enddo
9665       enddo
9666       endif ! calc_grad
9667       return
9668       end
9669 c----------------------------------------------------------------------------
9670       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9671       implicit real*8 (a-h,o-z)
9672       include 'DIMENSIONS'
9673       include 'DIMENSIONS.ZSCOPT'
9674       include 'COMMON.IOUNITS'
9675       include 'COMMON.CHAIN'
9676       include 'COMMON.DERIV'
9677       include 'COMMON.INTERACT'
9678       include 'COMMON.CONTACTS'
9679       include 'COMMON.TORSION'
9680       include 'COMMON.VAR'
9681       include 'COMMON.GEO'
9682       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9683       logical swap
9684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9685 C                                                                              C
9686 C      Parallel       Antiparallel                                             C
9687 C                                                                              C
9688 C          o             o                                                     C
9689 C         /l\   /   \   /j\                                                    C
9690 C        /   \ /     \ /   \                                                   C
9691 C       /| o |o       o| o |\                                                  C
9692 C       j|/k\|  /      |/k\|l /                                                C
9693 C        /   \ /       /   \ /                                                 C
9694 C       /     o       /     o                                                  C
9695 C       i             i                                                        C
9696 C                                                                              C
9697 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9698 C
9699 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9700 C           energy moment and not to the cluster cumulant.
9701       iti=itortyp(itype(i))
9702       if (j.lt.nres-1) then
9703         itj1=itype2loc(itype(j+1))
9704       else
9705         itj1=nloctyp
9706       endif
9707       itk=itype2loc(itype(k))
9708       itk1=itype2loc(itype(k+1))
9709       if (l.lt.nres-1) then
9710         itl1=itype2loc(itype(l+1))
9711       else
9712         itl1=nloctyp
9713       endif
9714 #ifdef MOMENT
9715       s1=dip(4,jj,i)*dip(4,kk,k)
9716 #endif
9717       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9718       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9719       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9720       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9721       call transpose2(EE(1,1,k),auxmat(1,1))
9722       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9723       vv(1)=pizda(1,1)+pizda(2,2)
9724       vv(2)=pizda(2,1)-pizda(1,2)
9725       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9726 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9727 cd     & "sum",-(s2+s3+s4)
9728 #ifdef MOMENT
9729       eello6_graph3=-(s1+s2+s3+s4)
9730 #else
9731       eello6_graph3=-(s2+s3+s4)
9732 #endif
9733 c      eello6_graph3=-s4
9734 C Derivatives in gamma(k-1)
9735       if (calc_grad) then
9736       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9737       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9738       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9739       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9740 C Derivatives in gamma(l-1)
9741       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9742       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9743       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9744       vv(1)=pizda(1,1)+pizda(2,2)
9745       vv(2)=pizda(2,1)-pizda(1,2)
9746       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9747       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9748 C Cartesian derivatives.
9749       do iii=1,2
9750         do kkk=1,5
9751           do lll=1,3
9752 #ifdef MOMENT
9753             if (iii.eq.1) then
9754               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9755             else
9756               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9757             endif
9758 #endif
9759             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9760      &        auxvec(1))
9761             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9762             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9763      &        auxvec(1))
9764             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9765             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9766      &        pizda(1,1))
9767             vv(1)=pizda(1,1)+pizda(2,2)
9768             vv(2)=pizda(2,1)-pizda(1,2)
9769             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9770 #ifdef MOMENT
9771             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9772 #else
9773             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9774 #endif
9775             if (swap) then
9776               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9777             else
9778               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9779             endif
9780 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9781           enddo
9782         enddo
9783       enddo
9784       endif ! calc_grad
9785       return
9786       end
9787 c----------------------------------------------------------------------------
9788       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9789       implicit real*8 (a-h,o-z)
9790       include 'DIMENSIONS'
9791       include 'DIMENSIONS.ZSCOPT'
9792       include 'COMMON.IOUNITS'
9793       include 'COMMON.CHAIN'
9794       include 'COMMON.DERIV'
9795       include 'COMMON.INTERACT'
9796       include 'COMMON.CONTACTS'
9797       include 'COMMON.TORSION'
9798       include 'COMMON.VAR'
9799       include 'COMMON.GEO'
9800       include 'COMMON.FFIELD'
9801       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9802      & auxvec1(2),auxmat1(2,2)
9803       logical swap
9804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9805 C                                                                              C
9806 C      Parallel       Antiparallel                                             C
9807 C                                                                              C
9808 C          o             o                                                     C
9809 C         /l\   /   \   /j\                                                    C
9810 C        /   \ /     \ /   \                                                   C
9811 C       /| o |o       o| o |\                                                  C
9812 C     \ j|/k\|      \  |/k\|l                                                  C
9813 C      \ /   \       \ /   \                                                   C
9814 C       o     \       o     \                                                  C
9815 C       i             i                                                        C
9816 C                                                                              C
9817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9818 C
9819 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9820 C           energy moment and not to the cluster cumulant.
9821 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9822       iti=itype2loc(itype(i))
9823       itj=itype2loc(itype(j))
9824       if (j.lt.nres-1) then
9825         itj1=itype2loc(itype(j+1))
9826       else
9827         itj1=nloctyp
9828       endif
9829       itk=itype2loc(itype(k))
9830       if (k.lt.nres-1) then
9831         itk1=itype2loc(itype(k+1))
9832       else
9833         itk1=nloctyp
9834       endif
9835       itl=itype2loc(itype(l))
9836       if (l.lt.nres-1) then
9837         itl1=itype2loc(itype(l+1))
9838       else
9839         itl1=nloctyp
9840       endif
9841 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9842 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9843 cd     & ' itl',itl,' itl1',itl1
9844 #ifdef MOMENT
9845       if (imat.eq.1) then
9846         s1=dip(3,jj,i)*dip(3,kk,k)
9847       else
9848         s1=dip(2,jj,j)*dip(2,kk,l)
9849       endif
9850 #endif
9851       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9852       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9853       if (j.eq.l+1) then
9854         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9855         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9856       else
9857         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9858         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9859       endif
9860       call transpose2(EUg(1,1,k),auxmat(1,1))
9861       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9862       vv(1)=pizda(1,1)-pizda(2,2)
9863       vv(2)=pizda(2,1)+pizda(1,2)
9864       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9865 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9866 #ifdef MOMENT
9867       eello6_graph4=-(s1+s2+s3+s4)
9868 #else
9869       eello6_graph4=-(s2+s3+s4)
9870 #endif
9871 C Derivatives in gamma(i-1)
9872       if (calc_grad) then
9873       if (i.gt.1) then
9874 #ifdef MOMENT
9875         if (imat.eq.1) then
9876           s1=dipderg(2,jj,i)*dip(3,kk,k)
9877         else
9878           s1=dipderg(4,jj,j)*dip(2,kk,l)
9879         endif
9880 #endif
9881         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9882         if (j.eq.l+1) then
9883           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9884           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9885         else
9886           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9887           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9888         endif
9889         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9890         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9891 cd          write (2,*) 'turn6 derivatives'
9892 #ifdef MOMENT
9893           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9894 #else
9895           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9896 #endif
9897         else
9898 #ifdef MOMENT
9899           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9900 #else
9901           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9902 #endif
9903         endif
9904       endif
9905 C Derivatives in gamma(k-1)
9906 #ifdef MOMENT
9907       if (imat.eq.1) then
9908         s1=dip(3,jj,i)*dipderg(2,kk,k)
9909       else
9910         s1=dip(2,jj,j)*dipderg(4,kk,l)
9911       endif
9912 #endif
9913       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9914       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9915       if (j.eq.l+1) then
9916         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9917         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9918       else
9919         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9920         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9921       endif
9922       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9923       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9924       vv(1)=pizda(1,1)-pizda(2,2)
9925       vv(2)=pizda(2,1)+pizda(1,2)
9926       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9927       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9928 #ifdef MOMENT
9929         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9930 #else
9931         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9932 #endif
9933       else
9934 #ifdef MOMENT
9935         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9936 #else
9937         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9938 #endif
9939       endif
9940 C Derivatives in gamma(j-1) or gamma(l-1)
9941       if (l.eq.j+1 .and. l.gt.1) then
9942         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9943         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9944         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9945         vv(1)=pizda(1,1)-pizda(2,2)
9946         vv(2)=pizda(2,1)+pizda(1,2)
9947         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9948         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9949       else if (j.gt.1) then
9950         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9951         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9952         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9953         vv(1)=pizda(1,1)-pizda(2,2)
9954         vv(2)=pizda(2,1)+pizda(1,2)
9955         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9956         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9957           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9958         else
9959           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9960         endif
9961       endif
9962 C Cartesian derivatives.
9963       do iii=1,2
9964         do kkk=1,5
9965           do lll=1,3
9966 #ifdef MOMENT
9967             if (iii.eq.1) then
9968               if (imat.eq.1) then
9969                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9970               else
9971                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9972               endif
9973             else
9974               if (imat.eq.1) then
9975                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9976               else
9977                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9978               endif
9979             endif
9980 #endif
9981             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9982      &        auxvec(1))
9983             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9984             if (j.eq.l+1) then
9985               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9986      &          b1(1,j+1),auxvec(1))
9987               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9988             else
9989               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9990      &          b1(1,l+1),auxvec(1))
9991               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9992             endif
9993             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9994      &        pizda(1,1))
9995             vv(1)=pizda(1,1)-pizda(2,2)
9996             vv(2)=pizda(2,1)+pizda(1,2)
9997             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9998             if (swap) then
9999               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10000 #ifdef MOMENT
10001                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10002      &             -(s1+s2+s4)
10003 #else
10004                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10005      &             -(s2+s4)
10006 #endif
10007                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10008               else
10009 #ifdef MOMENT
10010                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10011 #else
10012                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10013 #endif
10014                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10015               endif
10016             else
10017 #ifdef MOMENT
10018               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10019 #else
10020               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10021 #endif
10022               if (l.eq.j+1) then
10023                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10024               else
10025                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10026               endif
10027             endif
10028           enddo
10029         enddo
10030       enddo
10031       endif ! calc_grad
10032       return
10033       end
10034 c----------------------------------------------------------------------------
10035       double precision function eello_turn6(i,jj,kk)
10036       implicit real*8 (a-h,o-z)
10037       include 'DIMENSIONS'
10038       include 'DIMENSIONS.ZSCOPT'
10039       include 'COMMON.IOUNITS'
10040       include 'COMMON.CHAIN'
10041       include 'COMMON.DERIV'
10042       include 'COMMON.INTERACT'
10043       include 'COMMON.CONTACTS'
10044       include 'COMMON.TORSION'
10045       include 'COMMON.VAR'
10046       include 'COMMON.GEO'
10047       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10048      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10049      &  ggg1(3),ggg2(3)
10050       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10051      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10052 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10053 C           the respective energy moment and not to the cluster cumulant.
10054       s1=0.0d0
10055       s8=0.0d0
10056       s13=0.0d0
10057 c
10058       eello_turn6=0.0d0
10059       j=i+4
10060       k=i+1
10061       l=i+3
10062       iti=itype2loc(itype(i))
10063       itk=itype2loc(itype(k))
10064       itk1=itype2loc(itype(k+1))
10065       itl=itype2loc(itype(l))
10066       itj=itype2loc(itype(j))
10067 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10068 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10069 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10070 cd        eello6=0.0d0
10071 cd        return
10072 cd      endif
10073 cd      write (iout,*)
10074 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10075 cd     &   ' and',k,l
10076 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10077       do iii=1,2
10078         do kkk=1,5
10079           do lll=1,3
10080             derx_turn(lll,kkk,iii)=0.0d0
10081           enddo
10082         enddo
10083       enddo
10084 cd      eij=1.0d0
10085 cd      ekl=1.0d0
10086 cd      ekont=1.0d0
10087       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10088 cd      eello6_5=0.0d0
10089 cd      write (2,*) 'eello6_5',eello6_5
10090 #ifdef MOMENT
10091       call transpose2(AEA(1,1,1),auxmat(1,1))
10092       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10093       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10094       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10095 #endif
10096       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10097       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10098       s2 = scalar2(b1(1,k),vtemp1(1))
10099 #ifdef MOMENT
10100       call transpose2(AEA(1,1,2),atemp(1,1))
10101       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10102       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10103       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10104 #endif
10105       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10106       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10107       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10108 #ifdef MOMENT
10109       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10110       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10111       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10112       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10113       ss13 = scalar2(b1(1,k),vtemp4(1))
10114       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10115 #endif
10116 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10117 c      s1=0.0d0
10118 c      s2=0.0d0
10119 c      s8=0.0d0
10120 c      s12=0.0d0
10121 c      s13=0.0d0
10122       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10123 C Derivatives in gamma(i+2)
10124       if (calc_grad) then
10125       s1d =0.0d0
10126       s8d =0.0d0
10127 #ifdef MOMENT
10128       call transpose2(AEA(1,1,1),auxmatd(1,1))
10129       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10130       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10131       call transpose2(AEAderg(1,1,2),atempd(1,1))
10132       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10133       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10134 #endif
10135       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10136       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10137       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10138 c      s1d=0.0d0
10139 c      s2d=0.0d0
10140 c      s8d=0.0d0
10141 c      s12d=0.0d0
10142 c      s13d=0.0d0
10143       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10144 C Derivatives in gamma(i+3)
10145 #ifdef MOMENT
10146       call transpose2(AEA(1,1,1),auxmatd(1,1))
10147       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10148       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10149       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10150 #endif
10151       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10152       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10153       s2d = scalar2(b1(1,k),vtemp1d(1))
10154 #ifdef MOMENT
10155       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10156       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10157 #endif
10158       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10159 #ifdef MOMENT
10160       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10161       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10162       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10163 #endif
10164 c      s1d=0.0d0
10165 c      s2d=0.0d0
10166 c      s8d=0.0d0
10167 c      s12d=0.0d0
10168 c      s13d=0.0d0
10169 #ifdef MOMENT
10170       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10171      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10172 #else
10173       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10174      &               -0.5d0*ekont*(s2d+s12d)
10175 #endif
10176 C Derivatives in gamma(i+4)
10177       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10178       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10179       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10180 #ifdef MOMENT
10181       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10182       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10183       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10184 #endif
10185 c      s1d=0.0d0
10186 c      s2d=0.0d0
10187 c      s8d=0.0d0
10188 C      s12d=0.0d0
10189 c      s13d=0.0d0
10190 #ifdef MOMENT
10191       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10192 #else
10193       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10194 #endif
10195 C Derivatives in gamma(i+5)
10196 #ifdef MOMENT
10197       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10198       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10199       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10200 #endif
10201       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10202       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10203       s2d = scalar2(b1(1,k),vtemp1d(1))
10204 #ifdef MOMENT
10205       call transpose2(AEA(1,1,2),atempd(1,1))
10206       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10207       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10208 #endif
10209       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10210       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10211 #ifdef MOMENT
10212       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10213       ss13d = scalar2(b1(1,k),vtemp4d(1))
10214       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10215 #endif
10216 c      s1d=0.0d0
10217 c      s2d=0.0d0
10218 c      s8d=0.0d0
10219 c      s12d=0.0d0
10220 c      s13d=0.0d0
10221 #ifdef MOMENT
10222       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10223      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10224 #else
10225       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10226      &               -0.5d0*ekont*(s2d+s12d)
10227 #endif
10228 C Cartesian derivatives
10229       do iii=1,2
10230         do kkk=1,5
10231           do lll=1,3
10232 #ifdef MOMENT
10233             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10234             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10235             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10236 #endif
10237             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10238             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10239      &          vtemp1d(1))
10240             s2d = scalar2(b1(1,k),vtemp1d(1))
10241 #ifdef MOMENT
10242             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10243             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10244             s8d = -(atempd(1,1)+atempd(2,2))*
10245      &           scalar2(cc(1,1,l),vtemp2(1))
10246 #endif
10247             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10248      &           auxmatd(1,1))
10249             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10250             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10251 c      s1d=0.0d0
10252 c      s2d=0.0d0
10253 c      s8d=0.0d0
10254 c      s12d=0.0d0
10255 c      s13d=0.0d0
10256 #ifdef MOMENT
10257             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10258      &        - 0.5d0*(s1d+s2d)
10259 #else
10260             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10261      &        - 0.5d0*s2d
10262 #endif
10263 #ifdef MOMENT
10264             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10265      &        - 0.5d0*(s8d+s12d)
10266 #else
10267             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10268      &        - 0.5d0*s12d
10269 #endif
10270           enddo
10271         enddo
10272       enddo
10273 #ifdef MOMENT
10274       do kkk=1,5
10275         do lll=1,3
10276           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10277      &      achuj_tempd(1,1))
10278           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10279           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10280           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10281           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10282           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10283      &      vtemp4d(1))
10284           ss13d = scalar2(b1(1,k),vtemp4d(1))
10285           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10286           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10287         enddo
10288       enddo
10289 #endif
10290 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10291 cd     &  16*eel_turn6_num
10292 cd      goto 1112
10293       if (j.lt.nres-1) then
10294         j1=j+1
10295         j2=j-1
10296       else
10297         j1=j-1
10298         j2=j-2
10299       endif
10300       if (l.lt.nres-1) then
10301         l1=l+1
10302         l2=l-1
10303       else
10304         l1=l-1
10305         l2=l-2
10306       endif
10307       do ll=1,3
10308 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10309 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10310 cgrad        ghalf=0.5d0*ggg1(ll)
10311 cd        ghalf=0.0d0
10312         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10313         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10314         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10315      &    +ekont*derx_turn(ll,2,1)
10316         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10317         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10318      &    +ekont*derx_turn(ll,4,1)
10319         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10320         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10321         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10322 cgrad        ghalf=0.5d0*ggg2(ll)
10323 cd        ghalf=0.0d0
10324         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10325      &    +ekont*derx_turn(ll,2,2)
10326         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10327         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10328      &    +ekont*derx_turn(ll,4,2)
10329         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10330         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10331         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10332       enddo
10333 cd      goto 1112
10334 cgrad      do m=i+1,j-1
10335 cgrad        do ll=1,3
10336 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10337 cgrad        enddo
10338 cgrad      enddo
10339 cgrad      do m=k+1,l-1
10340 cgrad        do ll=1,3
10341 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10342 cgrad        enddo
10343 cgrad      enddo
10344 cgrad1112  continue
10345 cgrad      do m=i+2,j2
10346 cgrad        do ll=1,3
10347 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10348 cgrad        enddo
10349 cgrad      enddo
10350 cgrad      do m=k+2,l2
10351 cgrad        do ll=1,3
10352 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10353 cgrad        enddo
10354 cgrad      enddo
10355 cd      do iii=1,nres-3
10356 cd        write (2,*) iii,g_corr6_loc(iii)
10357 cd      enddo
10358       endif ! calc_grad
10359       eello_turn6=ekont*eel_turn6
10360 cd      write (2,*) 'ekont',ekont
10361 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10362       return
10363       end
10364
10365 crc-------------------------------------------------
10366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10367       subroutine Eliptransfer(eliptran)
10368       implicit real*8 (a-h,o-z)
10369       include 'DIMENSIONS'
10370       include 'DIMENSIONS.ZSCOPT'
10371       include 'COMMON.GEO'
10372       include 'COMMON.VAR'
10373       include 'COMMON.LOCAL'
10374       include 'COMMON.CHAIN'
10375       include 'COMMON.DERIV'
10376       include 'COMMON.INTERACT'
10377       include 'COMMON.IOUNITS'
10378       include 'COMMON.CALC'
10379       include 'COMMON.CONTROL'
10380       include 'COMMON.SPLITELE'
10381       include 'COMMON.SBRIDGE'
10382 C this is done by Adasko
10383 C      print *,"wchodze"
10384 C structure of box:
10385 C      water
10386 C--bordliptop-- buffore starts
10387 C--bufliptop--- here true lipid starts
10388 C      lipid
10389 C--buflipbot--- lipid ends buffore starts
10390 C--bordlipbot--buffore ends
10391       eliptran=0.0
10392       do i=1,nres
10393 C       do i=1,1
10394         if (itype(i).eq.ntyp1) cycle
10395
10396         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10397         if (positi.le.0) positi=positi+boxzsize
10398 C        print *,i
10399 C first for peptide groups
10400 c for each residue check if it is in lipid or lipid water border area
10401        if ((positi.gt.bordlipbot)
10402      &.and.(positi.lt.bordliptop)) then
10403 C the energy transfer exist
10404         if (positi.lt.buflipbot) then
10405 C what fraction I am in
10406          fracinbuf=1.0d0-
10407      &        ((positi-bordlipbot)/lipbufthick)
10408 C lipbufthick is thickenes of lipid buffore
10409          sslip=sscalelip(fracinbuf)
10410          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10411          eliptran=eliptran+sslip*pepliptran
10412          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10413          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10414 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10415         elseif (positi.gt.bufliptop) then
10416          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10417          sslip=sscalelip(fracinbuf)
10418          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10419          eliptran=eliptran+sslip*pepliptran
10420          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10421          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10422 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10423 C          print *, "doing sscalefor top part"
10424 C         print *,i,sslip,fracinbuf,ssgradlip
10425         else
10426          eliptran=eliptran+pepliptran
10427 C         print *,"I am in true lipid"
10428         endif
10429 C       else
10430 C       eliptran=elpitran+0.0 ! I am in water
10431        endif
10432        enddo
10433 C       print *, "nic nie bylo w lipidzie?"
10434 C now multiply all by the peptide group transfer factor
10435 C       eliptran=eliptran*pepliptran
10436 C now the same for side chains
10437 CV       do i=1,1
10438        do i=1,nres
10439         if (itype(i).eq.ntyp1) cycle
10440         positi=(mod(c(3,i+nres),boxzsize))
10441         if (positi.le.0) positi=positi+boxzsize
10442 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10443 c for each residue check if it is in lipid or lipid water border area
10444 C       respos=mod(c(3,i+nres),boxzsize)
10445 C       print *,positi,bordlipbot,buflipbot
10446        if ((positi.gt.bordlipbot)
10447      & .and.(positi.lt.bordliptop)) then
10448 C the energy transfer exist
10449         if (positi.lt.buflipbot) then
10450          fracinbuf=1.0d0-
10451      &     ((positi-bordlipbot)/lipbufthick)
10452 C lipbufthick is thickenes of lipid buffore
10453          sslip=sscalelip(fracinbuf)
10454          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10455          eliptran=eliptran+sslip*liptranene(itype(i))
10456          gliptranx(3,i)=gliptranx(3,i)
10457      &+ssgradlip*liptranene(itype(i))
10458          gliptranc(3,i-1)= gliptranc(3,i-1)
10459      &+ssgradlip*liptranene(itype(i))
10460 C         print *,"doing sccale for lower part"
10461         elseif (positi.gt.bufliptop) then
10462          fracinbuf=1.0d0-
10463      &((bordliptop-positi)/lipbufthick)
10464          sslip=sscalelip(fracinbuf)
10465          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10466          eliptran=eliptran+sslip*liptranene(itype(i))
10467          gliptranx(3,i)=gliptranx(3,i)
10468      &+ssgradlip*liptranene(itype(i))
10469          gliptranc(3,i-1)= gliptranc(3,i-1)
10470      &+ssgradlip*liptranene(itype(i))
10471 C          print *, "doing sscalefor top part",sslip,fracinbuf
10472         else
10473          eliptran=eliptran+liptranene(itype(i))
10474 C         print *,"I am in true lipid"
10475         endif
10476         endif ! if in lipid or buffor
10477 C       else
10478 C       eliptran=elpitran+0.0 ! I am in water
10479        enddo
10480        return
10481        end
10482
10483
10484 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10485
10486       SUBROUTINE MATVEC2(A1,V1,V2)
10487       implicit real*8 (a-h,o-z)
10488       include 'DIMENSIONS'
10489       DIMENSION A1(2,2),V1(2),V2(2)
10490 c      DO 1 I=1,2
10491 c        VI=0.0
10492 c        DO 3 K=1,2
10493 c    3     VI=VI+A1(I,K)*V1(K)
10494 c        Vaux(I)=VI
10495 c    1 CONTINUE
10496
10497       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10498       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10499
10500       v2(1)=vaux1
10501       v2(2)=vaux2
10502       END
10503 C---------------------------------------
10504       SUBROUTINE MATMAT2(A1,A2,A3)
10505       implicit real*8 (a-h,o-z)
10506       include 'DIMENSIONS'
10507       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10508 c      DIMENSION AI3(2,2)
10509 c        DO  J=1,2
10510 c          A3IJ=0.0
10511 c          DO K=1,2
10512 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10513 c          enddo
10514 c          A3(I,J)=A3IJ
10515 c       enddo
10516 c      enddo
10517
10518       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10519       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10520       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10521       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10522
10523       A3(1,1)=AI3_11
10524       A3(2,1)=AI3_21
10525       A3(1,2)=AI3_12
10526       A3(2,2)=AI3_22
10527       END
10528
10529 c-------------------------------------------------------------------------
10530       double precision function scalar2(u,v)
10531       implicit none
10532       double precision u(2),v(2)
10533       double precision sc
10534       integer i
10535       scalar2=u(1)*v(1)+u(2)*v(2)
10536       return
10537       end
10538
10539 C-----------------------------------------------------------------------------
10540
10541       subroutine transpose2(a,at)
10542       implicit none
10543       double precision a(2,2),at(2,2)
10544       at(1,1)=a(1,1)
10545       at(1,2)=a(2,1)
10546       at(2,1)=a(1,2)
10547       at(2,2)=a(2,2)
10548       return
10549       end
10550 c--------------------------------------------------------------------------
10551       subroutine transpose(n,a,at)
10552       implicit none
10553       integer n,i,j
10554       double precision a(n,n),at(n,n)
10555       do i=1,n
10556         do j=1,n
10557           at(j,i)=a(i,j)
10558         enddo
10559       enddo
10560       return
10561       end
10562 C---------------------------------------------------------------------------
10563       subroutine prodmat3(a1,a2,kk,transp,prod)
10564       implicit none
10565       integer i,j
10566       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10567       logical transp
10568 crc      double precision auxmat(2,2),prod_(2,2)
10569
10570       if (transp) then
10571 crc        call transpose2(kk(1,1),auxmat(1,1))
10572 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10573 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10574
10575            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10576      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10577            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10578      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10579            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10580      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10581            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10582      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10583
10584       else
10585 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10586 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10587
10588            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10589      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10590            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10591      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10592            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10593      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10594            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10595      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10596
10597       endif
10598 c      call transpose2(a2(1,1),a2t(1,1))
10599
10600 crc      print *,transp
10601 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10602 crc      print *,((prod(i,j),i=1,2),j=1,2)
10603
10604       return
10605       end
10606 C-----------------------------------------------------------------------------
10607       double precision function scalar(u,v)
10608       implicit none
10609       double precision u(3),v(3)
10610       double precision sc
10611       integer i
10612       sc=0.0d0
10613       do i=1,3
10614         sc=sc+u(i)*v(i)
10615       enddo
10616       scalar=sc
10617       return
10618       end
10619 C-----------------------------------------------------------------------
10620       double precision function sscale(r)
10621       double precision r,gamm
10622       include "COMMON.SPLITELE"
10623       if(r.lt.r_cut-rlamb) then
10624         sscale=1.0d0
10625       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10626         gamm=(r-(r_cut-rlamb))/rlamb
10627         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10628       else
10629         sscale=0d0
10630       endif
10631       return
10632       end
10633 C-----------------------------------------------------------------------
10634 C-----------------------------------------------------------------------
10635       double precision function sscagrad(r)
10636       double precision r,gamm
10637       include "COMMON.SPLITELE"
10638       if(r.lt.r_cut-rlamb) then
10639         sscagrad=0.0d0
10640       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10641         gamm=(r-(r_cut-rlamb))/rlamb
10642         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10643       else
10644         sscagrad=0.0d0
10645       endif
10646       return
10647       end
10648 C-----------------------------------------------------------------------
10649 C-----------------------------------------------------------------------
10650       double precision function sscalelip(r)
10651       double precision r,gamm
10652       include "COMMON.SPLITELE"
10653 C      if(r.lt.r_cut-rlamb) then
10654 C        sscale=1.0d0
10655 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10656 C        gamm=(r-(r_cut-rlamb))/rlamb
10657         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10658 C      else
10659 C        sscale=0d0
10660 C      endif
10661       return
10662       end
10663 C-----------------------------------------------------------------------
10664       double precision function sscagradlip(r)
10665       double precision r,gamm
10666       include "COMMON.SPLITELE"
10667 C     if(r.lt.r_cut-rlamb) then
10668 C        sscagrad=0.0d0
10669 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10670 C        gamm=(r-(r_cut-rlamb))/rlamb
10671         sscagradlip=r*(6*r-6.0d0)
10672 C      else
10673 C        sscagrad=0.0d0
10674 C      endif
10675       return
10676       end
10677
10678 C-----------------------------------------------------------------------
10679        subroutine set_shield_fac
10680       implicit real*8 (a-h,o-z)
10681       include 'DIMENSIONS'
10682       include 'DIMENSIONS.ZSCOPT'
10683       include 'COMMON.CHAIN'
10684       include 'COMMON.DERIV'
10685       include 'COMMON.IOUNITS'
10686       include 'COMMON.SHIELD'
10687       include 'COMMON.INTERACT'
10688 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10689       double precision div77_81/0.974996043d0/,
10690      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10691
10692 C the vector between center of side_chain and peptide group
10693        double precision pep_side(3),long,side_calf(3),
10694      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10695      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10696 C the line belowe needs to be changed for FGPROC>1
10697       do i=1,nres-1
10698       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10699       ishield_list(i)=0
10700 Cif there two consequtive dummy atoms there is no peptide group between them
10701 C the line below has to be changed for FGPROC>1
10702       VolumeTotal=0.0
10703       do k=1,nres
10704        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10705        dist_pep_side=0.0
10706        dist_side_calf=0.0
10707        do j=1,3
10708 C first lets set vector conecting the ithe side-chain with kth side-chain
10709       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10710 C      pep_side(j)=2.0d0
10711 C and vector conecting the side-chain with its proper calfa
10712       side_calf(j)=c(j,k+nres)-c(j,k)
10713 C      side_calf(j)=2.0d0
10714       pept_group(j)=c(j,i)-c(j,i+1)
10715 C lets have their lenght
10716       dist_pep_side=pep_side(j)**2+dist_pep_side
10717       dist_side_calf=dist_side_calf+side_calf(j)**2
10718       dist_pept_group=dist_pept_group+pept_group(j)**2
10719       enddo
10720        dist_pep_side=dsqrt(dist_pep_side)
10721        dist_pept_group=dsqrt(dist_pept_group)
10722        dist_side_calf=dsqrt(dist_side_calf)
10723       do j=1,3
10724         pep_side_norm(j)=pep_side(j)/dist_pep_side
10725         side_calf_norm(j)=dist_side_calf
10726       enddo
10727 C now sscale fraction
10728        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10729 C       print *,buff_shield,"buff"
10730 C now sscale
10731         if (sh_frac_dist.le.0.0) cycle
10732 C If we reach here it means that this side chain reaches the shielding sphere
10733 C Lets add him to the list for gradient
10734         ishield_list(i)=ishield_list(i)+1
10735 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10736 C this list is essential otherwise problem would be O3
10737         shield_list(ishield_list(i),i)=k
10738 C Lets have the sscale value
10739         if (sh_frac_dist.gt.1.0) then
10740          scale_fac_dist=1.0d0
10741          do j=1,3
10742          sh_frac_dist_grad(j)=0.0d0
10743          enddo
10744         else
10745          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10746      &                   *(2.0*sh_frac_dist-3.0d0)
10747          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10748      &                  /dist_pep_side/buff_shield*0.5
10749 C remember for the final gradient multiply sh_frac_dist_grad(j)
10750 C for side_chain by factor -2 !
10751          do j=1,3
10752          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10753 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10754 C     &                    sh_frac_dist_grad(j)
10755          enddo
10756         endif
10757 C        if ((i.eq.3).and.(k.eq.2)) then
10758 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10759 C     & ,"TU"
10760 C        endif
10761
10762 C this is what is now we have the distance scaling now volume...
10763       short=short_r_sidechain(itype(k))
10764       long=long_r_sidechain(itype(k))
10765       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10766 C now costhet_grad
10767 C       costhet=0.0d0
10768        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10769 C       costhet_fac=0.0d0
10770        do j=1,3
10771          costhet_grad(j)=costhet_fac*pep_side(j)
10772        enddo
10773 C remember for the final gradient multiply costhet_grad(j)
10774 C for side_chain by factor -2 !
10775 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10776 C pep_side0pept_group is vector multiplication
10777       pep_side0pept_group=0.0
10778       do j=1,3
10779       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10780       enddo
10781       cosalfa=(pep_side0pept_group/
10782      & (dist_pep_side*dist_side_calf))
10783       fac_alfa_sin=1.0-cosalfa**2
10784       fac_alfa_sin=dsqrt(fac_alfa_sin)
10785       rkprim=fac_alfa_sin*(long-short)+short
10786 C now costhet_grad
10787        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10788        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10789
10790        do j=1,3
10791          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10792      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10793      &*(long-short)/fac_alfa_sin*cosalfa/
10794      &((dist_pep_side*dist_side_calf))*
10795      &((side_calf(j))-cosalfa*
10796      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10797
10798         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10799      &*(long-short)/fac_alfa_sin*cosalfa
10800      &/((dist_pep_side*dist_side_calf))*
10801      &(pep_side(j)-
10802      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10803        enddo
10804
10805       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10806      &                    /VSolvSphere_div
10807      &                    *wshield
10808 C now the gradient...
10809 C grad_shield is gradient of Calfa for peptide groups
10810 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10811 C     &               costhet,cosphi
10812 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10813 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10814       do j=1,3
10815       grad_shield(j,i)=grad_shield(j,i)
10816 C gradient po skalowaniu
10817      &                +(sh_frac_dist_grad(j)
10818 C  gradient po costhet
10819      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10820      &-scale_fac_dist*(cosphi_grad_long(j))
10821      &/(1.0-cosphi) )*div77_81
10822      &*VofOverlap
10823 C grad_shield_side is Cbeta sidechain gradient
10824       grad_shield_side(j,ishield_list(i),i)=
10825      &        (sh_frac_dist_grad(j)*-2.0d0
10826      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10827      &       +scale_fac_dist*(cosphi_grad_long(j))
10828      &        *2.0d0/(1.0-cosphi))
10829      &        *div77_81*VofOverlap
10830
10831        grad_shield_loc(j,ishield_list(i),i)=
10832      &   scale_fac_dist*cosphi_grad_loc(j)
10833      &        *2.0d0/(1.0-cosphi)
10834      &        *div77_81*VofOverlap
10835       enddo
10836       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10837       enddo
10838       fac_shield(i)=VolumeTotal*div77_81+div4_81
10839 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10840       enddo
10841       return
10842       end
10843 C--------------------------------------------------------------------------
10844 C first for shielding is setting of function of side-chains
10845        subroutine set_shield_fac2
10846       implicit real*8 (a-h,o-z)
10847       include 'DIMENSIONS'
10848       include 'DIMENSIONS.ZSCOPT'
10849       include 'COMMON.CHAIN'
10850       include 'COMMON.DERIV'
10851       include 'COMMON.IOUNITS'
10852       include 'COMMON.SHIELD'
10853       include 'COMMON.INTERACT'
10854 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10855       double precision div77_81/0.974996043d0/,
10856      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10857
10858 C the vector between center of side_chain and peptide group
10859        double precision pep_side(3),long,side_calf(3),
10860      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10861      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10862 C the line belowe needs to be changed for FGPROC>1
10863       do i=1,nres-1
10864       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10865       ishield_list(i)=0
10866 Cif there two consequtive dummy atoms there is no peptide group between them
10867 C the line below has to be changed for FGPROC>1
10868       VolumeTotal=0.0
10869       do k=1,nres
10870        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10871        dist_pep_side=0.0
10872        dist_side_calf=0.0
10873        do j=1,3
10874 C first lets set vector conecting the ithe side-chain with kth side-chain
10875       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10876 C      pep_side(j)=2.0d0
10877 C and vector conecting the side-chain with its proper calfa
10878       side_calf(j)=c(j,k+nres)-c(j,k)
10879 C      side_calf(j)=2.0d0
10880       pept_group(j)=c(j,i)-c(j,i+1)
10881 C lets have their lenght
10882       dist_pep_side=pep_side(j)**2+dist_pep_side
10883       dist_side_calf=dist_side_calf+side_calf(j)**2
10884       dist_pept_group=dist_pept_group+pept_group(j)**2
10885       enddo
10886        dist_pep_side=dsqrt(dist_pep_side)
10887        dist_pept_group=dsqrt(dist_pept_group)
10888        dist_side_calf=dsqrt(dist_side_calf)
10889       do j=1,3
10890         pep_side_norm(j)=pep_side(j)/dist_pep_side
10891         side_calf_norm(j)=dist_side_calf
10892       enddo
10893 C now sscale fraction
10894        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10895 C       print *,buff_shield,"buff"
10896 C now sscale
10897         if (sh_frac_dist.le.0.0) cycle
10898 C If we reach here it means that this side chain reaches the shielding sphere
10899 C Lets add him to the list for gradient
10900         ishield_list(i)=ishield_list(i)+1
10901 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10902 C this list is essential otherwise problem would be O3
10903         shield_list(ishield_list(i),i)=k
10904 C Lets have the sscale value
10905         if (sh_frac_dist.gt.1.0) then
10906          scale_fac_dist=1.0d0
10907          do j=1,3
10908          sh_frac_dist_grad(j)=0.0d0
10909          enddo
10910         else
10911          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10912      &                   *(2.0d0*sh_frac_dist-3.0d0)
10913          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10914      &                  /dist_pep_side/buff_shield*0.5d0
10915 C remember for the final gradient multiply sh_frac_dist_grad(j)
10916 C for side_chain by factor -2 !
10917          do j=1,3
10918          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10919 C         sh_frac_dist_grad(j)=0.0d0
10920 C         scale_fac_dist=1.0d0
10921 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10922 C     &                    sh_frac_dist_grad(j)
10923          enddo
10924         endif
10925 C this is what is now we have the distance scaling now volume...
10926       short=short_r_sidechain(itype(k))
10927       long=long_r_sidechain(itype(k))
10928       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10929       sinthet=short/dist_pep_side*costhet
10930 C now costhet_grad
10931 C       costhet=0.6d0
10932 C       sinthet=0.8
10933        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10934 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10935 C     &             -short/dist_pep_side**2/costhet)
10936 C       costhet_fac=0.0d0
10937        do j=1,3
10938          costhet_grad(j)=costhet_fac*pep_side(j)
10939        enddo
10940 C remember for the final gradient multiply costhet_grad(j)
10941 C for side_chain by factor -2 !
10942 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10943 C pep_side0pept_group is vector multiplication
10944       pep_side0pept_group=0.0d0
10945       do j=1,3
10946       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10947       enddo
10948       cosalfa=(pep_side0pept_group/
10949      & (dist_pep_side*dist_side_calf))
10950       fac_alfa_sin=1.0d0-cosalfa**2
10951       fac_alfa_sin=dsqrt(fac_alfa_sin)
10952       rkprim=fac_alfa_sin*(long-short)+short
10953 C      rkprim=short
10954
10955 C now costhet_grad
10956        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10957 C       cosphi=0.6
10958        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10959        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10960      &      dist_pep_side**2)
10961 C       sinphi=0.8
10962        do j=1,3
10963          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10964      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10965      &*(long-short)/fac_alfa_sin*cosalfa/
10966      &((dist_pep_side*dist_side_calf))*
10967      &((side_calf(j))-cosalfa*
10968      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10969 C       cosphi_grad_long(j)=0.0d0
10970         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10971      &*(long-short)/fac_alfa_sin*cosalfa
10972      &/((dist_pep_side*dist_side_calf))*
10973      &(pep_side(j)-
10974      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10975 C       cosphi_grad_loc(j)=0.0d0
10976        enddo
10977 C      print *,sinphi,sinthet
10978       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10979      &                    /VSolvSphere_div
10980 C     &                    *wshield
10981 C now the gradient...
10982       do j=1,3
10983       grad_shield(j,i)=grad_shield(j,i)
10984 C gradient po skalowaniu
10985      &                +(sh_frac_dist_grad(j)*VofOverlap
10986 C  gradient po costhet
10987      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10988      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10989      &       sinphi/sinthet*costhet*costhet_grad(j)
10990      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10991      & )*wshield
10992 C grad_shield_side is Cbeta sidechain gradient
10993       grad_shield_side(j,ishield_list(i),i)=
10994      &        (sh_frac_dist_grad(j)*-2.0d0
10995      &        *VofOverlap
10996      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10997      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10998      &       sinphi/sinthet*costhet*costhet_grad(j)
10999      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11000      &       )*wshield
11001
11002        grad_shield_loc(j,ishield_list(i),i)=
11003      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11004      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11005      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11006      &        ))
11007      &        *wshield
11008       enddo
11009       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11010       enddo
11011       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11012 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11013 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11014       enddo
11015       return
11016       end
11017 C--------------------------------------------------------------------------
11018       double precision function tschebyshev(m,n,x,y)
11019       implicit none
11020       include "DIMENSIONS"
11021       integer i,m,n
11022       double precision x(n),y,yy(0:maxvar),aux
11023 c Tschebyshev polynomial. Note that the first term is omitted
11024 c m=0: the constant term is included
11025 c m=1: the constant term is not included
11026       yy(0)=1.0d0
11027       yy(1)=y
11028       do i=2,n
11029         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11030       enddo
11031       aux=0.0d0
11032       do i=m,n
11033         aux=aux+x(i)*yy(i)
11034       enddo
11035       tschebyshev=aux
11036       return
11037       end
11038 C--------------------------------------------------------------------------
11039       double precision function gradtschebyshev(m,n,x,y)
11040       implicit none
11041       include "DIMENSIONS"
11042       integer i,m,n
11043       double precision x(n+1),y,yy(0:maxvar),aux
11044 c Tschebyshev polynomial. Note that the first term is omitted
11045 c m=0: the constant term is included
11046 c m=1: the constant term is not included
11047       yy(0)=1.0d0
11048       yy(1)=2.0d0*y
11049       do i=2,n
11050         yy(i)=2*y*yy(i-1)-yy(i-2)
11051       enddo
11052       aux=0.0d0
11053       do i=m,n
11054         aux=aux+x(i+1)*yy(i)*(i+1)
11055 C        print *, x(i+1),yy(i),i
11056       enddo
11057       gradtschebyshev=aux
11058       return
11059       end
11060