source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       else
 104          ecorr=0.0d0
 105          ecorr5=0.0d0
 106          ecorr6=0.0d0
 107          eturn6=0.0d0
 108       endif
 109       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 110          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 111       endif
 112
 113       write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 114       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 115         call e_saxs(Esaxs_constr)
 116         write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 117       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 118         call e_saxsC(Esaxs_constr)
 119 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 120       else
 121         Esaxs_constr = 0.0d0
 122       endif
 123
 124 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 125       if (constr_homology.ge.1) then
 126         call e_modeller(ehomology_constr)
 127       else
 128         ehomology_constr=0.0d0
 129       endif
 130
 131 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 132 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 133 #ifdef SPLITELE
 134       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 135      & +wvdwpp*evdw1
 136      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 137      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 138      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 139      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 140      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 141      & +wbond*estr+wsccor*fact(1)*esccor+wsaxs*esaxs_constr
 142 #else
 143       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 144      & +welec*fact(1)*(ees+evdw1)
 145      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 146      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 147      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 148      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 149      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 150      & +wbond*estr+wsccor*fact(1)*esccor+wsaxs*esaxs_constr
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(26)=esaxs_constr
 186 c detecting NaNQ
 187 #ifdef ISNAN
 188 #ifdef AIX
 189       if (isnan(etot).ne.0) energia(0)=1.0d+99
 190 #else
 191       if (isnan(etot)) energia(0)=1.0d+99
 192 #endif
 193 #else
 194       i=0
 195 #ifdef WINPGI
 196       idumm=proc_proc(etot,i)
 197 #else
 198       call proc_proc(etot,i)
 199 #endif
 200       if(i.eq.1)energia(0)=1.0d+99
 201 #endif
 202 #ifdef MPL
 203 c     endif
 204 #endif
 205 #define DEBUG
 206 #ifdef DEBUG
 207       call enerprint(energia,fact)
 208 #endif
 209 #undef DEBUG
 210       if (calc_grad) then
 211 C
 212 C Sum up the components of the Cartesian gradient.
 213 C
 214 #ifdef SPLITELE
 215       do i=1,nct
 216         do j=1,3
 217           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 218      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 219      &                wbond*gradb(j,i)+
 220      &                wstrain*ghpbc(j,i)+
 221      &                wcorr*fact(3)*gradcorr(j,i)+
 222      &                wel_loc*fact(2)*gel_loc(j,i)+
 223      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 224      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 225      &                wcorr5*fact(4)*gradcorr5(j,i)+
 226      &                wcorr6*fact(5)*gradcorr6(j,i)+
 227      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 228      &                wsccor*fact(2)*gsccorc(j,i)
 229      &               +wliptran*gliptranc(j,i)
 230           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 231      &                  wbond*gradbx(j,i)+
 232      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 233      &                  wsccor*fact(2)*gsccorx(j,i)
 234         enddo
 235 #else
 236       do i=1,nct
 237         do j=1,3
 238           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 239      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 240      &                wbond*gradb(j,i)+
 241      &                wcorr*fact(3)*gradcorr(j,i)+
 242      &                wel_loc*fact(2)*gel_loc(j,i)+
 243      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 244      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 245      &                wcorr5*fact(4)*gradcorr5(j,i)+
 246      &                wcorr6*fact(5)*gradcorr6(j,i)+
 247      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 248      &                wsccor*fact(2)*gsccorc(j,i)
 249      &               +wliptran*gliptranc(j,i)
 250           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 251      &                  wbond*gradbx(j,i)+
 252      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 253      &                  wsccor*fact(1)*gsccorx(j,i)
 254      &                 +wliptran*gliptranx(j,i)
 255         enddo
 256 #endif
 257       enddo
 258
 259
 260       do i=1,nres-3
 261         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 262      &   +wcorr5*fact(4)*g_corr5_loc(i)
 263      &   +wcorr6*fact(5)*g_corr6_loc(i)
 264      &   +wturn4*fact(3)*gel_loc_turn4(i)
 265      &   +wturn3*fact(2)*gel_loc_turn3(i)
 266      &   +wturn6*fact(5)*gel_loc_turn6(i)
 267      &   +wel_loc*fact(2)*gel_loc_loc(i)
 268 c     &   +wsccor*fact(1)*gsccor_loc(i)
 269 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 270       enddo
 271       endif
 272       if (dyn_ss) call dyn_set_nss
 273       return
 274       end
 275 C------------------------------------------------------------------------
 276       subroutine enerprint(energia,fact)
 277       implicit real*8 (a-h,o-z)
 278       include 'DIMENSIONS'
 279       include 'DIMENSIONS.ZSCOPT'
 280       include 'COMMON.IOUNITS'
 281       include 'COMMON.FFIELD'
 282       include 'COMMON.SBRIDGE'
 283       double precision energia(0:max_ene),fact(6)
 284       etot=energia(0)
 285       evdw=energia(1)+fact(6)*energia(21)
 286 #ifdef SCP14
 287       evdw2=energia(2)+energia(17)
 288 #else
 289       evdw2=energia(2)
 290 #endif
 291       ees=energia(3)
 292 #ifdef SPLITELE
 293       evdw1=energia(16)
 294 #endif
 295       ecorr=energia(4)
 296       ecorr5=energia(5)
 297       ecorr6=energia(6)
 298       eel_loc=energia(7)
 299       eello_turn3=energia(8)
 300       eello_turn4=energia(9)
 301       eello_turn6=energia(10)
 302       ebe=energia(11)
 303       escloc=energia(12)
 304       etors=energia(13)
 305       etors_d=energia(14)
 306       ehpb=energia(15)
 307       esccor=energia(19)
 308       edihcnstr=energia(20)
 309       estr=energia(18)
 310       ehomology_constr=energia(22)
 311       esaxs_constr=energia(26)
 312 #ifdef SPLITELE
 313       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 314      &  wvdwpp,
 315      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 316      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 317      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 318      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 319      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 320      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,
 321      &  esaxs_constr*wsaxs,ebr*nss,
 322      &  etot
 323    10 format (/'Virtual-chain energies:'//
 324      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 325      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 326      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 327      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 328      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 329      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 330      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 331      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 332      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 333      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 334      & ' (SS bridges & dist. cnstr.)'/
 335      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 337      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 338      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 339      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 340      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 341      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 342      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 343      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 344      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 345      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 346      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 347      & 'ETOT=  ',1pE16.6,' (total)')
 348 #else
 349       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 350      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 351      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 352      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 353      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 354      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 355      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs,ebr*nss,
 356      &  etot
 357    10 format (/'Virtual-chain energies:'//
 358      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 359      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 360      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 361      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 362      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 363      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 364      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 365      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 366      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 367      & ' (SS bridges & dist. cnstr.)'/
 368      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 369      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 370      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 372      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 373      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 374      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 375      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 376      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 377      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 378      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 379      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 380      & 'ETOT=  ',1pE16.6,' (total)')
 381 #endif
 382       return
 383       end
 384 C-----------------------------------------------------------------------
 385       subroutine elj(evdw,evdw_t)
 386 C
 387 C This subroutine calculates the interaction energy of nonbonded side chains
 388 C assuming the LJ potential of interaction.
 389 C
 390       implicit real*8 (a-h,o-z)
 391       include 'DIMENSIONS'
 392       include 'DIMENSIONS.ZSCOPT'
 393       include "DIMENSIONS.COMPAR"
 394       parameter (accur=1.0d-10)
 395       include 'COMMON.GEO'
 396       include 'COMMON.VAR'
 397       include 'COMMON.LOCAL'
 398       include 'COMMON.CHAIN'
 399       include 'COMMON.DERIV'
 400       include 'COMMON.INTERACT'
 401       include 'COMMON.TORSION'
 402       include 'COMMON.ENEPS'
 403       include 'COMMON.SBRIDGE'
 404       include 'COMMON.NAMES'
 405       include 'COMMON.IOUNITS'
 406       include 'COMMON.CONTACTS'
 407       dimension gg(3)
 408       integer icant
 409       external icant
 410 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 411       do i=1,210
 412         do j=1,2
 413           eneps_temp(j,i)=0.0d0
 414         enddo
 415       enddo
 416       evdw=0.0D0
 417       evdw_t=0.0d0
 418       do i=iatsc_s,iatsc_e
 419         itypi=iabs(itype(i))
 420         if (itypi.eq.ntyp1) cycle
 421         itypi1=iabs(itype(i+1))
 422         xi=c(1,nres+i)
 423         yi=c(2,nres+i)
 424         zi=c(3,nres+i)
 425 C Change 12/1/95
 426         num_conti=0
 427 C
 428 C Calculate SC interaction energy.
 429 C
 430         do iint=1,nint_gr(i)
 431 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 432 cd   &                  'iend=',iend(i,iint)
 433           do j=istart(i,iint),iend(i,iint)
 434             itypj=iabs(itype(j))
 435             if (itypj.eq.ntyp1) cycle
 436             xj=c(1,nres+j)-xi
 437             yj=c(2,nres+j)-yi
 438             zj=c(3,nres+j)-zi
 439 C Change 12/1/95 to calculate four-body interactions
 440             rij=xj*xj+yj*yj+zj*zj
 441             rrij=1.0D0/rij
 442 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 443             eps0ij=eps(itypi,itypj)
 444             fac=rrij**expon2
 445             e1=fac*fac*aa
 446             e2=fac*bb
 447             evdwij=e1+e2
 448             ij=icant(itypi,itypj)
 449             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 450             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 451 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 452 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 453 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 454 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 455 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 456 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 457             if (bb.gt.0.0d0) then
 458               evdw=evdw+evdwij
 459             else
 460               evdw_t=evdw_t+evdwij
 461             endif
 462             if (calc_grad) then
 463 C
 464 C Calculate the components of the gradient in DC and X
 465 C
 466             fac=-rrij*(e1+evdwij)
 467             gg(1)=xj*fac
 468             gg(2)=yj*fac
 469             gg(3)=zj*fac
 470             do k=1,3
 471               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 472               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 473             enddo
 474             do k=i,j-1
 475               do l=1,3
 476                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 477               enddo
 478             enddo
 479             endif
 480 C
 481 C 12/1/95, revised on 5/20/97
 482 C
 483 C Calculate the contact function. The ith column of the array JCONT will
 484 C contain the numbers of atoms that make contacts with the atom I (of numbers
 485 C greater than I). The arrays FACONT and GACONT will contain the values of
 486 C the contact function and its derivative.
 487 C
 488 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 489 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 490 C Uncomment next line, if the correlation interactions are contact function only
 491             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 492               rij=dsqrt(rij)
 493               sigij=sigma(itypi,itypj)
 494               r0ij=rs0(itypi,itypj)
 495 C
 496 C Check whether the SC's are not too far to make a contact.
 497 C
 498               rcut=1.5d0*r0ij
 499               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 500 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 501 C
 502               if (fcont.gt.0.0D0) then
 503 C If the SC-SC distance if close to sigma, apply spline.
 504 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 505 cAdam &             fcont1,fprimcont1)
 506 cAdam           fcont1=1.0d0-fcont1
 507 cAdam           if (fcont1.gt.0.0d0) then
 508 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 509 cAdam             fcont=fcont*fcont1
 510 cAdam           endif
 511 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 512 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 513 cga             do k=1,3
 514 cga               gg(k)=gg(k)*eps0ij
 515 cga             enddo
 516 cga             eps0ij=-evdwij*eps0ij
 517 C Uncomment for AL's type of SC correlation interactions.
 518 cadam           eps0ij=-evdwij
 519                 num_conti=num_conti+1
 520                 jcont(num_conti,i)=j
 521                 facont(num_conti,i)=fcont*eps0ij
 522                 fprimcont=eps0ij*fprimcont/rij
 523                 fcont=expon*fcont
 524 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 525 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 526 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 527 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 528                 gacont(1,num_conti,i)=-fprimcont*xj
 529                 gacont(2,num_conti,i)=-fprimcont*yj
 530                 gacont(3,num_conti,i)=-fprimcont*zj
 531 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 532 cd              write (iout,'(2i3,3f10.5)')
 533 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 534               endif
 535             endif
 536           enddo      ! j
 537         enddo        ! iint
 538 C Change 12/1/95
 539         num_cont(i)=num_conti
 540       enddo          ! i
 541       if (calc_grad) then
 542       do i=1,nct
 543         do j=1,3
 544           gvdwc(j,i)=expon*gvdwc(j,i)
 545           gvdwx(j,i)=expon*gvdwx(j,i)
 546         enddo
 547       enddo
 548       endif
 549 C******************************************************************************
 550 C
 551 C                              N O T E !!!
 552 C
 553 C To save time, the factor of EXPON has been extracted from ALL components
 554 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 555 C use!
 556 C
 557 C******************************************************************************
 558       return
 559       end
 560 C-----------------------------------------------------------------------------
 561       subroutine eljk(evdw,evdw_t)
 562 C
 563 C This subroutine calculates the interaction energy of nonbonded side chains
 564 C assuming the LJK potential of interaction.
 565 C
 566       implicit real*8 (a-h,o-z)
 567       include 'DIMENSIONS'
 568       include 'DIMENSIONS.ZSCOPT'
 569       include "DIMENSIONS.COMPAR"
 570       include 'COMMON.GEO'
 571       include 'COMMON.VAR'
 572       include 'COMMON.LOCAL'
 573       include 'COMMON.CHAIN'
 574       include 'COMMON.DERIV'
 575       include 'COMMON.INTERACT'
 576       include 'COMMON.ENEPS'
 577       include 'COMMON.IOUNITS'
 578       include 'COMMON.NAMES'
 579       dimension gg(3)
 580       logical scheck
 581       integer icant
 582       external icant
 583 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 584       do i=1,210
 585         do j=1,2
 586           eneps_temp(j,i)=0.0d0
 587         enddo
 588       enddo
 589       evdw=0.0D0
 590       evdw_t=0.0d0
 591       do i=iatsc_s,iatsc_e
 592         itypi=iabs(itype(i))
 593         if (itypi.eq.ntyp1) cycle
 594         itypi1=iabs(itype(i+1))
 595         xi=c(1,nres+i)
 596         yi=c(2,nres+i)
 597         zi=c(3,nres+i)
 598 C
 599 C Calculate SC interaction energy.
 600 C
 601         do iint=1,nint_gr(i)
 602           do j=istart(i,iint),iend(i,iint)
 603             itypj=iabs(itype(j))
 604             if (itypj.eq.ntyp1) cycle
 605             xj=c(1,nres+j)-xi
 606             yj=c(2,nres+j)-yi
 607             zj=c(3,nres+j)-zi
 608             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 609             fac_augm=rrij**expon
 610             e_augm=augm(itypi,itypj)*fac_augm
 611             r_inv_ij=dsqrt(rrij)
 612             rij=1.0D0/r_inv_ij
 613             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 614             fac=r_shift_inv**expon
 615             e1=fac*fac*aa
 616             e2=fac*bb
 617             evdwij=e_augm+e1+e2
 618             ij=icant(itypi,itypj)
 619             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 620      &        /dabs(eps(itypi,itypj))
 621             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 622 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 623 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 624 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 625 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 626 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 627 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 628 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 629             if (bb.gt.0.0d0) then
 630               evdw=evdw+evdwij
 631             else
 632               evdw_t=evdw_t+evdwij
 633             endif
 634             if (calc_grad) then
 635 C
 636 C Calculate the components of the gradient in DC and X
 637 C
 638             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 639             gg(1)=xj*fac
 640             gg(2)=yj*fac
 641             gg(3)=zj*fac
 642             do k=1,3
 643               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 644               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 645             enddo
 646             do k=i,j-1
 647               do l=1,3
 648                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 649               enddo
 650             enddo
 651             endif
 652           enddo      ! j
 653         enddo        ! iint
 654       enddo          ! i
 655       if (calc_grad) then
 656       do i=1,nct
 657         do j=1,3
 658           gvdwc(j,i)=expon*gvdwc(j,i)
 659           gvdwx(j,i)=expon*gvdwx(j,i)
 660         enddo
 661       enddo
 662       endif
 663       return
 664       end
 665 C-----------------------------------------------------------------------------
 666       subroutine ebp(evdw,evdw_t)
 667 C
 668 C This subroutine calculates the interaction energy of nonbonded side chains
 669 C assuming the Berne-Pechukas potential of interaction.
 670 C
 671       implicit real*8 (a-h,o-z)
 672       include 'DIMENSIONS'
 673       include 'DIMENSIONS.ZSCOPT'
 674       include "DIMENSIONS.COMPAR"
 675       include 'COMMON.GEO'
 676       include 'COMMON.VAR'
 677       include 'COMMON.LOCAL'
 678       include 'COMMON.CHAIN'
 679       include 'COMMON.DERIV'
 680       include 'COMMON.NAMES'
 681       include 'COMMON.INTERACT'
 682       include 'COMMON.ENEPS'
 683       include 'COMMON.IOUNITS'
 684       include 'COMMON.CALC'
 685       common /srutu/ icall
 686 c     double precision rrsave(maxdim)
 687       logical lprn
 688       integer icant
 689       external icant
 690       do i=1,210
 691         do j=1,2
 692           eneps_temp(j,i)=0.0d0
 693         enddo
 694       enddo
 695       evdw=0.0D0
 696       evdw_t=0.0d0
 697 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 698 c     if (icall.eq.0) then
 699 c       lprn=.true.
 700 c     else
 701         lprn=.false.
 702 c     endif
 703       ind=0
 704       do i=iatsc_s,iatsc_e
 705         itypi=iabs(itype(i))
 706         if (itypi.eq.ntyp1) cycle
 707         itypi1=iabs(itype(i+1))
 708         xi=c(1,nres+i)
 709         yi=c(2,nres+i)
 710         zi=c(3,nres+i)
 711         dxi=dc_norm(1,nres+i)
 712         dyi=dc_norm(2,nres+i)
 713         dzi=dc_norm(3,nres+i)
 714         dsci_inv=vbld_inv(i+nres)
 715 C
 716 C Calculate SC interaction energy.
 717 C
 718         do iint=1,nint_gr(i)
 719           do j=istart(i,iint),iend(i,iint)
 720             ind=ind+1
 721             itypj=iabs(itype(j))
 722             if (itypj.eq.ntyp1) cycle
 723             dscj_inv=vbld_inv(j+nres)
 724             chi1=chi(itypi,itypj)
 725             chi2=chi(itypj,itypi)
 726             chi12=chi1*chi2
 727             chip1=chip(itypi)
 728             chip2=chip(itypj)
 729             chip12=chip1*chip2
 730             alf1=alp(itypi)
 731             alf2=alp(itypj)
 732             alf12=0.5D0*(alf1+alf2)
 733 C For diagnostics only!!!
 734 c           chi1=0.0D0
 735 c           chi2=0.0D0
 736 c           chi12=0.0D0
 737 c           chip1=0.0D0
 738 c           chip2=0.0D0
 739 c           chip12=0.0D0
 740 c           alf1=0.0D0
 741 c           alf2=0.0D0
 742 c           alf12=0.0D0
 743             xj=c(1,nres+j)-xi
 744             yj=c(2,nres+j)-yi
 745             zj=c(3,nres+j)-zi
 746             dxj=dc_norm(1,nres+j)
 747             dyj=dc_norm(2,nres+j)
 748             dzj=dc_norm(3,nres+j)
 749             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 750 cd          if (icall.eq.0) then
 751 cd            rrsave(ind)=rrij
 752 cd          else
 753 cd            rrij=rrsave(ind)
 754 cd          endif
 755             rij=dsqrt(rrij)
 756 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 757             call sc_angular
 758 C Calculate whole angle-dependent part of epsilon and contributions
 759 C to its derivatives
 760             fac=(rrij*sigsq)**expon2
 761             e1=fac*fac*aa
 762             e2=fac*bb
 763             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 764             eps2der=evdwij*eps3rt
 765             eps3der=evdwij*eps2rt
 766             evdwij=evdwij*eps2rt*eps3rt
 767             ij=icant(itypi,itypj)
 768             aux=eps1*eps2rt**2*eps3rt**2
 769             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 770      &        /dabs(eps(itypi,itypj))
 771             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 772             if (bb.gt.0.0d0) then
 773               evdw=evdw+evdwij
 774             else
 775               evdw_t=evdw_t+evdwij
 776             endif
 777             if (calc_grad) then
 778             if (lprn) then
 779             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 780             epsi=bb**2/aa
 781             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 782      &        restyp(itypi),i,restyp(itypj),j,
 783      &        epsi,sigm,chi1,chi2,chip1,chip2,
 784      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 785      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 786      &        evdwij
 787             endif
 788 C Calculate gradient components.
 789             e1=e1*eps1*eps2rt**2*eps3rt**2
 790             fac=-expon*(e1+evdwij)
 791             sigder=fac/sigsq
 792             fac=rrij*fac
 793 C Calculate radial part of the gradient
 794             gg(1)=xj*fac
 795             gg(2)=yj*fac
 796             gg(3)=zj*fac
 797 C Calculate the angular part of the gradient and sum add the contributions
 798 C to the appropriate components of the Cartesian gradient.
 799             call sc_grad
 800             endif
 801           enddo      ! j
 802         enddo        ! iint
 803       enddo          ! i
 804 c     stop
 805       return
 806       end
 807 C-----------------------------------------------------------------------------
 808       subroutine egb(evdw,evdw_t)
 809 C
 810 C This subroutine calculates the interaction energy of nonbonded side chains
 811 C assuming the Gay-Berne potential of interaction.
 812 C
 813       implicit real*8 (a-h,o-z)
 814       include 'DIMENSIONS'
 815       include 'DIMENSIONS.ZSCOPT'
 816       include "DIMENSIONS.COMPAR"
 817       include 'COMMON.GEO'
 818       include 'COMMON.VAR'
 819       include 'COMMON.LOCAL'
 820       include 'COMMON.CHAIN'
 821       include 'COMMON.DERIV'
 822       include 'COMMON.NAMES'
 823       include 'COMMON.INTERACT'
 824       include 'COMMON.ENEPS'
 825       include 'COMMON.IOUNITS'
 826       include 'COMMON.CALC'
 827       include 'COMMON.SBRIDGE'
 828       logical lprn
 829       common /srutu/icall
 830       integer icant,xshift,yshift,zshift
 831       external icant
 832       do i=1,210
 833         do j=1,2
 834           eneps_temp(j,i)=0.0d0
 835         enddo
 836       enddo
 837 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 838       evdw=0.0D0
 839       evdw_t=0.0d0
 840       lprn=.false.
 841 c      if (icall.gt.0) lprn=.true.
 842       ind=0
 843       do i=iatsc_s,iatsc_e
 844         itypi=iabs(itype(i))
 845         if (itypi.eq.ntyp1) cycle
 846         itypi1=iabs(itype(i+1))
 847         xi=c(1,nres+i)
 848         yi=c(2,nres+i)
 849         zi=c(3,nres+i)
 850 C returning the ith atom to box
 851           xi=mod(xi,boxxsize)
 852           if (xi.lt.0) xi=xi+boxxsize
 853           yi=mod(yi,boxysize)
 854           if (yi.lt.0) yi=yi+boxysize
 855           zi=mod(zi,boxzsize)
 856           if (zi.lt.0) zi=zi+boxzsize
 857        if ((zi.gt.bordlipbot)
 858      &.and.(zi.lt.bordliptop)) then
 859 C the energy transfer exist
 860         if (zi.lt.buflipbot) then
 861 C what fraction I am in
 862          fracinbuf=1.0d0-
 863      &        ((zi-bordlipbot)/lipbufthick)
 864 C lipbufthick is thickenes of lipid buffore
 865          sslipi=sscalelip(fracinbuf)
 866          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 867         elseif (zi.gt.bufliptop) then
 868          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 869          sslipi=sscalelip(fracinbuf)
 870          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 871         else
 872          sslipi=1.0d0
 873          ssgradlipi=0.0
 874         endif
 875        else
 876          sslipi=0.0d0
 877          ssgradlipi=0.0
 878        endif
 879
 880         dxi=dc_norm(1,nres+i)
 881         dyi=dc_norm(2,nres+i)
 882         dzi=dc_norm(3,nres+i)
 883         dsci_inv=vbld_inv(i+nres)
 884 C
 885 C Calculate SC interaction energy.
 886 C
 887         do iint=1,nint_gr(i)
 888           do j=istart(i,iint),iend(i,iint)
 889             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 890               call dyn_ssbond_ene(i,j,evdwij)
 891               evdw=evdw+evdwij
 892 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 893 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 894 C triple bond artifac removal
 895              do k=j+1,iend(i,iint)
 896 C search over all next residues
 897               if (dyn_ss_mask(k)) then
 898 C check if they are cysteins
 899 C              write(iout,*) 'k=',k
 900               call triple_ssbond_ene(i,j,k,evdwij)
 901 C call the energy function that removes the artifical triple disulfide
 902 C bond the soubroutine is located in ssMD.F
 903               evdw=evdw+evdwij
 904 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 905 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 906               endif!dyn_ss_mask(k)
 907              enddo! k
 908             ELSE
 909             ind=ind+1
 910             itypj=iabs(itype(j))
 911             if (itypj.eq.ntyp1) cycle
 912             dscj_inv=vbld_inv(j+nres)
 913             sig0ij=sigma(itypi,itypj)
 914             chi1=chi(itypi,itypj)
 915             chi2=chi(itypj,itypi)
 916             chi12=chi1*chi2
 917             chip1=chip(itypi)
 918             chip2=chip(itypj)
 919             chip12=chip1*chip2
 920             alf1=alp(itypi)
 921             alf2=alp(itypj)
 922             alf12=0.5D0*(alf1+alf2)
 923 C For diagnostics only!!!
 924 c           chi1=0.0D0
 925 c           chi2=0.0D0
 926 c           chi12=0.0D0
 927 c           chip1=0.0D0
 928 c           chip2=0.0D0
 929 c           chip12=0.0D0
 930 c           alf1=0.0D0
 931 c           alf2=0.0D0
 932 c           alf12=0.0D0
 933             xj=c(1,nres+j)
 934             yj=c(2,nres+j)
 935             zj=c(3,nres+j)
 936 C returning jth atom to box
 937           xj=mod(xj,boxxsize)
 938           if (xj.lt.0) xj=xj+boxxsize
 939           yj=mod(yj,boxysize)
 940           if (yj.lt.0) yj=yj+boxysize
 941           zj=mod(zj,boxzsize)
 942           if (zj.lt.0) zj=zj+boxzsize
 943        if ((zj.gt.bordlipbot)
 944      &.and.(zj.lt.bordliptop)) then
 945 C the energy transfer exist
 946         if (zj.lt.buflipbot) then
 947 C what fraction I am in
 948          fracinbuf=1.0d0-
 949      &        ((zj-bordlipbot)/lipbufthick)
 950 C lipbufthick is thickenes of lipid buffore
 951          sslipj=sscalelip(fracinbuf)
 952          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 953         elseif (zj.gt.bufliptop) then
 954          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 955          sslipj=sscalelip(fracinbuf)
 956          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 957         else
 958          sslipj=1.0d0
 959          ssgradlipj=0.0
 960         endif
 961        else
 962          sslipj=0.0d0
 963          ssgradlipj=0.0
 964        endif
 965       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 966      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 967       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 968      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 969 C       if (aa.ne.aa_aq(itypi,itypj)) then
 970
 971 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
 972 C     & bb_aq(itypi,itypj)-bb,
 973 C     & sslipi,sslipj
 974 C         endif
 975
 976 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 977 C checking the distance
 978       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 979       xj_safe=xj
 980       yj_safe=yj
 981       zj_safe=zj
 982       subchap=0
 983 C finding the closest
 984       do xshift=-1,1
 985       do yshift=-1,1
 986       do zshift=-1,1
 987           xj=xj_safe+xshift*boxxsize
 988           yj=yj_safe+yshift*boxysize
 989           zj=zj_safe+zshift*boxzsize
 990           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 991           if(dist_temp.lt.dist_init) then
 992             dist_init=dist_temp
 993             xj_temp=xj
 994             yj_temp=yj
 995             zj_temp=zj
 996             subchap=1
 997           endif
 998        enddo
 999        enddo
1000        enddo
1001        if (subchap.eq.1) then
1002           xj=xj_temp-xi
1003           yj=yj_temp-yi
1004           zj=zj_temp-zi
1005        else
1006           xj=xj_safe-xi
1007           yj=yj_safe-yi
1008           zj=zj_safe-zi
1009        endif
1010
1011             dxj=dc_norm(1,nres+j)
1012             dyj=dc_norm(2,nres+j)
1013             dzj=dc_norm(3,nres+j)
1014 c            write (iout,*) i,j,xj,yj,zj
1015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1016             rij=dsqrt(rrij)
1017             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1018             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1019             if (sss.le.0.0) cycle
1020 C Calculate angle-dependent terms of energy and contributions to their
1021 C derivatives.
1022
1023             call sc_angular
1024             sigsq=1.0D0/sigsq
1025             sig=sig0ij*dsqrt(sigsq)
1026             rij_shift=1.0D0/rij-sig+sig0ij
1027 C I hate to put IF's in the loops, but here don't have another choice!!!!
1028             if (rij_shift.le.0.0D0) then
1029               evdw=1.0D20
1030               return
1031             endif
1032             sigder=-sig*sigsq
1033 c---------------------------------------------------------------
1034             rij_shift=1.0D0/rij_shift
1035             fac=rij_shift**expon
1036             e1=fac*fac*aa
1037             e2=fac*bb
1038             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1039             eps2der=evdwij*eps3rt
1040             eps3der=evdwij*eps2rt
1041             evdwij=evdwij*eps2rt*eps3rt
1042             if (bb.gt.0) then
1043               evdw=evdw+evdwij*sss
1044             else
1045               evdw_t=evdw_t+evdwij*sss
1046             endif
1047             ij=icant(itypi,itypj)
1048             aux=eps1*eps2rt**2*eps3rt**2
1049             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1050      &        /dabs(eps(itypi,itypj))
1051             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1052 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1053 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1054 c     &         aux*e2/eps(itypi,itypj)
1055 c            if (lprn) then
1056             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1057             epsi=bb**2/aa
1058 C#define DEBUG
1059 #ifdef DEBUG
1060             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1061      &        restyp(itypi),i,restyp(itypj),j,
1062      &        epsi,sigm,chi1,chi2,chip1,chip2,
1063      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1064      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1065      &        evdwij
1066              write (iout,*) "partial sum", evdw, evdw_t
1067 #endif
1068 C#undef DEBUG
1069 c            endif
1070             if (calc_grad) then
1071 C Calculate gradient components.
1072             e1=e1*eps1*eps2rt**2*eps3rt**2
1073             fac=-expon*(e1+evdwij)*rij_shift
1074             sigder=fac*sigder
1075             fac=rij*fac
1076             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1077 C Calculate the radial part of the gradient
1078             gg(1)=xj*fac
1079             gg(2)=yj*fac
1080             gg(3)=zj*fac
1081 C Calculate angular part of the gradient.
1082             call sc_grad
1083             endif
1084 C            write(iout,*)  "partial sum", evdw, evdw_t
1085             ENDIF    ! dyn_ss
1086           enddo      ! j
1087         enddo        ! iint
1088       enddo          ! i
1089       return
1090       end
1091 C-----------------------------------------------------------------------------
1092       subroutine egbv(evdw,evdw_t)
1093 C
1094 C This subroutine calculates the interaction energy of nonbonded side chains
1095 C assuming the Gay-Berne-Vorobjev potential of interaction.
1096 C
1097       implicit real*8 (a-h,o-z)
1098       include 'DIMENSIONS'
1099       include 'DIMENSIONS.ZSCOPT'
1100       include "DIMENSIONS.COMPAR"
1101       include 'COMMON.GEO'
1102       include 'COMMON.VAR'
1103       include 'COMMON.LOCAL'
1104       include 'COMMON.CHAIN'
1105       include 'COMMON.DERIV'
1106       include 'COMMON.NAMES'
1107       include 'COMMON.INTERACT'
1108       include 'COMMON.ENEPS'
1109       include 'COMMON.IOUNITS'
1110       include 'COMMON.CALC'
1111       common /srutu/ icall
1112       logical lprn
1113       integer icant
1114       external icant
1115       do i=1,210
1116         do j=1,2
1117           eneps_temp(j,i)=0.0d0
1118         enddo
1119       enddo
1120       evdw=0.0D0
1121       evdw_t=0.0d0
1122 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1123       evdw=0.0D0
1124       lprn=.false.
1125 c      if (icall.gt.0) lprn=.true.
1126       ind=0
1127       do i=iatsc_s,iatsc_e
1128         itypi=iabs(itype(i))
1129         if (itypi.eq.ntyp1) cycle
1130         itypi1=iabs(itype(i+1))
1131         xi=c(1,nres+i)
1132         yi=c(2,nres+i)
1133         zi=c(3,nres+i)
1134         dxi=dc_norm(1,nres+i)
1135         dyi=dc_norm(2,nres+i)
1136         dzi=dc_norm(3,nres+i)
1137         dsci_inv=vbld_inv(i+nres)
1138 C
1139 C Calculate SC interaction energy.
1140 C
1141         do iint=1,nint_gr(i)
1142           do j=istart(i,iint),iend(i,iint)
1143             ind=ind+1
1144             itypj=iabs(itype(j))
1145             if (itypj.eq.ntyp1) cycle
1146             dscj_inv=vbld_inv(j+nres)
1147             sig0ij=sigma(itypi,itypj)
1148             r0ij=r0(itypi,itypj)
1149             chi1=chi(itypi,itypj)
1150             chi2=chi(itypj,itypi)
1151             chi12=chi1*chi2
1152             chip1=chip(itypi)
1153             chip2=chip(itypj)
1154             chip12=chip1*chip2
1155             alf1=alp(itypi)
1156             alf2=alp(itypj)
1157             alf12=0.5D0*(alf1+alf2)
1158 C For diagnostics only!!!
1159 c           chi1=0.0D0
1160 c           chi2=0.0D0
1161 c           chi12=0.0D0
1162 c           chip1=0.0D0
1163 c           chip2=0.0D0
1164 c           chip12=0.0D0
1165 c           alf1=0.0D0
1166 c           alf2=0.0D0
1167 c           alf12=0.0D0
1168             xj=c(1,nres+j)-xi
1169             yj=c(2,nres+j)-yi
1170             zj=c(3,nres+j)-zi
1171             dxj=dc_norm(1,nres+j)
1172             dyj=dc_norm(2,nres+j)
1173             dzj=dc_norm(3,nres+j)
1174             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1175             rij=dsqrt(rrij)
1176 C Calculate angle-dependent terms of energy and contributions to their
1177 C derivatives.
1178             call sc_angular
1179             sigsq=1.0D0/sigsq
1180             sig=sig0ij*dsqrt(sigsq)
1181             rij_shift=1.0D0/rij-sig+r0ij
1182 C I hate to put IF's in the loops, but here don't have another choice!!!!
1183             if (rij_shift.le.0.0D0) then
1184               evdw=1.0D20
1185               return
1186             endif
1187             sigder=-sig*sigsq
1188 c---------------------------------------------------------------
1189             rij_shift=1.0D0/rij_shift
1190             fac=rij_shift**expon
1191             e1=fac*fac*aa
1192             e2=fac*bb
1193             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1194             eps2der=evdwij*eps3rt
1195             eps3der=evdwij*eps2rt
1196             fac_augm=rrij**expon
1197             e_augm=augm(itypi,itypj)*fac_augm
1198             evdwij=evdwij*eps2rt*eps3rt
1199             if (bb.gt.0.0d0) then
1200               evdw=evdw+evdwij+e_augm
1201             else
1202               evdw_t=evdw_t+evdwij+e_augm
1203             endif
1204             ij=icant(itypi,itypj)
1205             aux=eps1*eps2rt**2*eps3rt**2
1206             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1207      &        /dabs(eps(itypi,itypj))
1208             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1209 c            eneps_temp(ij)=eneps_temp(ij)
1210 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1211 c            if (lprn) then
1212 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1213 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1214 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1215 c     &        restyp(itypi),i,restyp(itypj),j,
1216 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1217 c     &        chi1,chi2,chip1,chip2,
1218 c     &        eps1,eps2rt**2,eps3rt**2,
1219 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1220 c     &        evdwij+e_augm
1221 c            endif
1222             if (calc_grad) then
1223 C Calculate gradient components.
1224             e1=e1*eps1*eps2rt**2*eps3rt**2
1225             fac=-expon*(e1+evdwij)*rij_shift
1226             sigder=fac*sigder
1227             fac=rij*fac-2*expon*rrij*e_augm
1228 C Calculate the radial part of the gradient
1229             gg(1)=xj*fac
1230             gg(2)=yj*fac
1231             gg(3)=zj*fac
1232 C Calculate angular part of the gradient.
1233             call sc_grad
1234             endif
1235           enddo      ! j
1236         enddo        ! iint
1237       enddo          ! i
1238       return
1239       end
1240 C-----------------------------------------------------------------------------
1241       subroutine sc_angular
1242 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1243 C om12. Called by ebp, egb, and egbv.
1244       implicit none
1245       include 'COMMON.CALC'
1246       erij(1)=xj*rij
1247       erij(2)=yj*rij
1248       erij(3)=zj*rij
1249       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1250       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1251       om12=dxi*dxj+dyi*dyj+dzi*dzj
1252       chiom12=chi12*om12
1253 C Calculate eps1(om12) and its derivative in om12
1254       faceps1=1.0D0-om12*chiom12
1255       faceps1_inv=1.0D0/faceps1
1256       eps1=dsqrt(faceps1_inv)
1257 C Following variable is eps1*deps1/dom12
1258       eps1_om12=faceps1_inv*chiom12
1259 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1260 C and om12.
1261       om1om2=om1*om2
1262       chiom1=chi1*om1
1263       chiom2=chi2*om2
1264       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1265       sigsq=1.0D0-facsig*faceps1_inv
1266       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1267       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1268       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1269 C Calculate eps2 and its derivatives in om1, om2, and om12.
1270       chipom1=chip1*om1
1271       chipom2=chip2*om2
1272       chipom12=chip12*om12
1273       facp=1.0D0-om12*chipom12
1274       facp_inv=1.0D0/facp
1275       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1276 C Following variable is the square root of eps2
1277       eps2rt=1.0D0-facp1*facp_inv
1278 C Following three variables are the derivatives of the square root of eps
1279 C in om1, om2, and om12.
1280       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1281       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1282       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1283 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1284       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1285 C Calculate whole angle-dependent part of epsilon and contributions
1286 C to its derivatives
1287       return
1288       end
1289 C----------------------------------------------------------------------------
1290       subroutine sc_grad
1291       implicit real*8 (a-h,o-z)
1292       include 'DIMENSIONS'
1293       include 'DIMENSIONS.ZSCOPT'
1294       include 'COMMON.CHAIN'
1295       include 'COMMON.DERIV'
1296       include 'COMMON.CALC'
1297       double precision dcosom1(3),dcosom2(3)
1298       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1299       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1300       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1301      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1302       do k=1,3
1303         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1304         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1305       enddo
1306       do k=1,3
1307         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1308       enddo
1309       do k=1,3
1310         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1311      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1312      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1313         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1314      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1315      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1316       enddo
1317 C
1318 C Calculate the components of the gradient in DC and X
1319 C
1320       do k=i,j-1
1321         do l=1,3
1322           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1323         enddo
1324       enddo
1325       return
1326       end
1327 c------------------------------------------------------------------------------
1328       subroutine vec_and_deriv
1329       implicit real*8 (a-h,o-z)
1330       include 'DIMENSIONS'
1331       include 'DIMENSIONS.ZSCOPT'
1332       include 'COMMON.IOUNITS'
1333       include 'COMMON.GEO'
1334       include 'COMMON.VAR'
1335       include 'COMMON.LOCAL'
1336       include 'COMMON.CHAIN'
1337       include 'COMMON.VECTORS'
1338       include 'COMMON.DERIV'
1339       include 'COMMON.INTERACT'
1340       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1341 C Compute the local reference systems. For reference system (i), the
1342 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1343 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1344       do i=1,nres-1
1345 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1346           if (i.eq.nres-1) then
1347 C Case of the last full residue
1348 C Compute the Z-axis
1349             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1350             costh=dcos(pi-theta(nres))
1351             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1352             do k=1,3
1353               uz(k,i)=fac*uz(k,i)
1354             enddo
1355             if (calc_grad) then
1356 C Compute the derivatives of uz
1357             uzder(1,1,1)= 0.0d0
1358             uzder(2,1,1)=-dc_norm(3,i-1)
1359             uzder(3,1,1)= dc_norm(2,i-1)
1360             uzder(1,2,1)= dc_norm(3,i-1)
1361             uzder(2,2,1)= 0.0d0
1362             uzder(3,2,1)=-dc_norm(1,i-1)
1363             uzder(1,3,1)=-dc_norm(2,i-1)
1364             uzder(2,3,1)= dc_norm(1,i-1)
1365             uzder(3,3,1)= 0.0d0
1366             uzder(1,1,2)= 0.0d0
1367             uzder(2,1,2)= dc_norm(3,i)
1368             uzder(3,1,2)=-dc_norm(2,i)
1369             uzder(1,2,2)=-dc_norm(3,i)
1370             uzder(2,2,2)= 0.0d0
1371             uzder(3,2,2)= dc_norm(1,i)
1372             uzder(1,3,2)= dc_norm(2,i)
1373             uzder(2,3,2)=-dc_norm(1,i)
1374             uzder(3,3,2)= 0.0d0
1375             endif
1376 C Compute the Y-axis
1377             facy=fac
1378             do k=1,3
1379               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1380             enddo
1381             if (calc_grad) then
1382 C Compute the derivatives of uy
1383             do j=1,3
1384               do k=1,3
1385                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1386      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1387                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1388               enddo
1389               uyder(j,j,1)=uyder(j,j,1)-costh
1390               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1391             enddo
1392             do j=1,2
1393               do k=1,3
1394                 do l=1,3
1395                   uygrad(l,k,j,i)=uyder(l,k,j)
1396                   uzgrad(l,k,j,i)=uzder(l,k,j)
1397                 enddo
1398               enddo
1399             enddo
1400             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1401             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1402             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1403             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1404             endif
1405           else
1406 C Other residues
1407 C Compute the Z-axis
1408             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1409             costh=dcos(pi-theta(i+2))
1410             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1411             do k=1,3
1412               uz(k,i)=fac*uz(k,i)
1413             enddo
1414             if (calc_grad) then
1415 C Compute the derivatives of uz
1416             uzder(1,1,1)= 0.0d0
1417             uzder(2,1,1)=-dc_norm(3,i+1)
1418             uzder(3,1,1)= dc_norm(2,i+1)
1419             uzder(1,2,1)= dc_norm(3,i+1)
1420             uzder(2,2,1)= 0.0d0
1421             uzder(3,2,1)=-dc_norm(1,i+1)
1422             uzder(1,3,1)=-dc_norm(2,i+1)
1423             uzder(2,3,1)= dc_norm(1,i+1)
1424             uzder(3,3,1)= 0.0d0
1425             uzder(1,1,2)= 0.0d0
1426             uzder(2,1,2)= dc_norm(3,i)
1427             uzder(3,1,2)=-dc_norm(2,i)
1428             uzder(1,2,2)=-dc_norm(3,i)
1429             uzder(2,2,2)= 0.0d0
1430             uzder(3,2,2)= dc_norm(1,i)
1431             uzder(1,3,2)= dc_norm(2,i)
1432             uzder(2,3,2)=-dc_norm(1,i)
1433             uzder(3,3,2)= 0.0d0
1434             endif
1435 C Compute the Y-axis
1436             facy=fac
1437             do k=1,3
1438               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1439             enddo
1440             if (calc_grad) then
1441 C Compute the derivatives of uy
1442             do j=1,3
1443               do k=1,3
1444                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1445      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1446                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1447               enddo
1448               uyder(j,j,1)=uyder(j,j,1)-costh
1449               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           endif
1464           endif
1465       enddo
1466       if (calc_grad) then
1467       do i=1,nres-1
1468         vbld_inv_temp(1)=vbld_inv(i+1)
1469         if (i.lt.nres-1) then
1470           vbld_inv_temp(2)=vbld_inv(i+2)
1471         else
1472           vbld_inv_temp(2)=vbld_inv(i)
1473         endif
1474         do j=1,2
1475           do k=1,3
1476             do l=1,3
1477               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1478               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1479             enddo
1480           enddo
1481         enddo
1482       enddo
1483       endif
1484       return
1485       end
1486 C-----------------------------------------------------------------------------
1487       subroutine vec_and_deriv_test
1488       implicit real*8 (a-h,o-z)
1489       include 'DIMENSIONS'
1490       include 'DIMENSIONS.ZSCOPT'
1491       include 'COMMON.IOUNITS'
1492       include 'COMMON.GEO'
1493       include 'COMMON.VAR'
1494       include 'COMMON.LOCAL'
1495       include 'COMMON.CHAIN'
1496       include 'COMMON.VECTORS'
1497       dimension uyder(3,3,2),uzder(3,3,2)
1498 C Compute the local reference systems. For reference system (i), the
1499 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1500 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1501       do i=1,nres-1
1502           if (i.eq.nres-1) then
1503 C Case of the last full residue
1504 C Compute the Z-axis
1505             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1506             costh=dcos(pi-theta(nres))
1507             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1508 c            write (iout,*) 'fac',fac,
1509 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1510             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1511             do k=1,3
1512               uz(k,i)=fac*uz(k,i)
1513             enddo
1514 C Compute the derivatives of uz
1515             uzder(1,1,1)= 0.0d0
1516             uzder(2,1,1)=-dc_norm(3,i-1)
1517             uzder(3,1,1)= dc_norm(2,i-1)
1518             uzder(1,2,1)= dc_norm(3,i-1)
1519             uzder(2,2,1)= 0.0d0
1520             uzder(3,2,1)=-dc_norm(1,i-1)
1521             uzder(1,3,1)=-dc_norm(2,i-1)
1522             uzder(2,3,1)= dc_norm(1,i-1)
1523             uzder(3,3,1)= 0.0d0
1524             uzder(1,1,2)= 0.0d0
1525             uzder(2,1,2)= dc_norm(3,i)
1526             uzder(3,1,2)=-dc_norm(2,i)
1527             uzder(1,2,2)=-dc_norm(3,i)
1528             uzder(2,2,2)= 0.0d0
1529             uzder(3,2,2)= dc_norm(1,i)
1530             uzder(1,3,2)= dc_norm(2,i)
1531             uzder(2,3,2)=-dc_norm(1,i)
1532             uzder(3,3,2)= 0.0d0
1533 C Compute the Y-axis
1534             do k=1,3
1535               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1536             enddo
1537             facy=fac
1538             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1539      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1540      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1541             do k=1,3
1542 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1543               uy(k,i)=
1544 c     &        facy*(
1545      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1546      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1547 c     &        )
1548             enddo
1549 c            write (iout,*) 'facy',facy,
1550 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1551             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1552             do k=1,3
1553               uy(k,i)=facy*uy(k,i)
1554             enddo
1555 C Compute the derivatives of uy
1556             do j=1,3
1557               do k=1,3
1558                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1559      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1560                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1561               enddo
1562 c              uyder(j,j,1)=uyder(j,j,1)-costh
1563 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1564               uyder(j,j,1)=uyder(j,j,1)
1565      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1566               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1567      &          +uyder(j,j,2)
1568             enddo
1569             do j=1,2
1570               do k=1,3
1571                 do l=1,3
1572                   uygrad(l,k,j,i)=uyder(l,k,j)
1573                   uzgrad(l,k,j,i)=uzder(l,k,j)
1574                 enddo
1575               enddo
1576             enddo
1577             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1578             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1579             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1580             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1581           else
1582 C Other residues
1583 C Compute the Z-axis
1584             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1585             costh=dcos(pi-theta(i+2))
1586             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1587             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1588             do k=1,3
1589               uz(k,i)=fac*uz(k,i)
1590             enddo
1591 C Compute the derivatives of uz
1592             uzder(1,1,1)= 0.0d0
1593             uzder(2,1,1)=-dc_norm(3,i+1)
1594             uzder(3,1,1)= dc_norm(2,i+1)
1595             uzder(1,2,1)= dc_norm(3,i+1)
1596             uzder(2,2,1)= 0.0d0
1597             uzder(3,2,1)=-dc_norm(1,i+1)
1598             uzder(1,3,1)=-dc_norm(2,i+1)
1599             uzder(2,3,1)= dc_norm(1,i+1)
1600             uzder(3,3,1)= 0.0d0
1601             uzder(1,1,2)= 0.0d0
1602             uzder(2,1,2)= dc_norm(3,i)
1603             uzder(3,1,2)=-dc_norm(2,i)
1604             uzder(1,2,2)=-dc_norm(3,i)
1605             uzder(2,2,2)= 0.0d0
1606             uzder(3,2,2)= dc_norm(1,i)
1607             uzder(1,3,2)= dc_norm(2,i)
1608             uzder(2,3,2)=-dc_norm(1,i)
1609             uzder(3,3,2)= 0.0d0
1610 C Compute the Y-axis
1611             facy=fac
1612             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1613      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1614      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1615             do k=1,3
1616 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1617               uy(k,i)=
1618 c     &        facy*(
1619      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1620      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1621 c     &        )
1622             enddo
1623 c            write (iout,*) 'facy',facy,
1624 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1625             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1626             do k=1,3
1627               uy(k,i)=facy*uy(k,i)
1628             enddo
1629 C Compute the derivatives of uy
1630             do j=1,3
1631               do k=1,3
1632                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1633      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1634                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1635               enddo
1636 c              uyder(j,j,1)=uyder(j,j,1)-costh
1637 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1638               uyder(j,j,1)=uyder(j,j,1)
1639      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1640               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1641      &          +uyder(j,j,2)
1642             enddo
1643             do j=1,2
1644               do k=1,3
1645                 do l=1,3
1646                   uygrad(l,k,j,i)=uyder(l,k,j)
1647                   uzgrad(l,k,j,i)=uzder(l,k,j)
1648                 enddo
1649               enddo
1650             enddo
1651             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1652             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1653             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1654             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1655           endif
1656       enddo
1657       do i=1,nres-1
1658         do j=1,2
1659           do k=1,3
1660             do l=1,3
1661               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1662               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1663             enddo
1664           enddo
1665         enddo
1666       enddo
1667       return
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine check_vecgrad
1671       implicit real*8 (a-h,o-z)
1672       include 'DIMENSIONS'
1673       include 'DIMENSIONS.ZSCOPT'
1674       include 'COMMON.IOUNITS'
1675       include 'COMMON.GEO'
1676       include 'COMMON.VAR'
1677       include 'COMMON.LOCAL'
1678       include 'COMMON.CHAIN'
1679       include 'COMMON.VECTORS'
1680       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1681       dimension uyt(3,maxres),uzt(3,maxres)
1682       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1683       double precision delta /1.0d-7/
1684       call vec_and_deriv
1685 cd      do i=1,nres
1686 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1687 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1688 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1689 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1690 cd     &     (dc_norm(if90,i),if90=1,3)
1691 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1692 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1693 cd          write(iout,'(a)')
1694 cd      enddo
1695       do i=1,nres
1696         do j=1,2
1697           do k=1,3
1698             do l=1,3
1699               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1700               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1701             enddo
1702           enddo
1703         enddo
1704       enddo
1705       call vec_and_deriv
1706       do i=1,nres
1707         do j=1,3
1708           uyt(j,i)=uy(j,i)
1709           uzt(j,i)=uz(j,i)
1710         enddo
1711       enddo
1712       do i=1,nres
1713 cd        write (iout,*) 'i=',i
1714         do k=1,3
1715           erij(k)=dc_norm(k,i)
1716         enddo
1717         do j=1,3
1718           do k=1,3
1719             dc_norm(k,i)=erij(k)
1720           enddo
1721           dc_norm(j,i)=dc_norm(j,i)+delta
1722 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1723 c          do k=1,3
1724 c            dc_norm(k,i)=dc_norm(k,i)/fac
1725 c          enddo
1726 c          write (iout,*) (dc_norm(k,i),k=1,3)
1727 c          write (iout,*) (erij(k),k=1,3)
1728           call vec_and_deriv
1729           do k=1,3
1730             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1731             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1732             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1733             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1734           enddo
1735 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1736 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1737 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1738         enddo
1739         do k=1,3
1740           dc_norm(k,i)=erij(k)
1741         enddo
1742 cd        do k=1,3
1743 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1744 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1745 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1746 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1747 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1748 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1749 cd          write (iout,'(a)')
1750 cd        enddo
1751       enddo
1752       return
1753       end
1754 C--------------------------------------------------------------------------
1755       subroutine set_matrices
1756       implicit real*8 (a-h,o-z)
1757       include 'DIMENSIONS'
1758       include 'DIMENSIONS.ZSCOPT'
1759       include 'COMMON.IOUNITS'
1760       include 'COMMON.GEO'
1761       include 'COMMON.VAR'
1762       include 'COMMON.LOCAL'
1763       include 'COMMON.CHAIN'
1764       include 'COMMON.DERIV'
1765       include 'COMMON.INTERACT'
1766       include 'COMMON.CONTACTS'
1767       include 'COMMON.TORSION'
1768       include 'COMMON.VECTORS'
1769       include 'COMMON.FFIELD'
1770       double precision auxvec(2),auxmat(2,2)
1771 C
1772 C Compute the virtual-bond-torsional-angle dependent quantities needed
1773 C to calculate the el-loc multibody terms of various order.
1774 C
1775       do i=3,nres+1
1776         if (i .lt. nres+1) then
1777           sin1=dsin(phi(i))
1778           cos1=dcos(phi(i))
1779           sintab(i-2)=sin1
1780           costab(i-2)=cos1
1781           obrot(1,i-2)=cos1
1782           obrot(2,i-2)=sin1
1783           sin2=dsin(2*phi(i))
1784           cos2=dcos(2*phi(i))
1785           sintab2(i-2)=sin2
1786           costab2(i-2)=cos2
1787           obrot2(1,i-2)=cos2
1788           obrot2(2,i-2)=sin2
1789           Ug(1,1,i-2)=-cos1
1790           Ug(1,2,i-2)=-sin1
1791           Ug(2,1,i-2)=-sin1
1792           Ug(2,2,i-2)= cos1
1793           Ug2(1,1,i-2)=-cos2
1794           Ug2(1,2,i-2)=-sin2
1795           Ug2(2,1,i-2)=-sin2
1796           Ug2(2,2,i-2)= cos2
1797         else
1798           costab(i-2)=1.0d0
1799           sintab(i-2)=0.0d0
1800           obrot(1,i-2)=1.0d0
1801           obrot(2,i-2)=0.0d0
1802           obrot2(1,i-2)=0.0d0
1803           obrot2(2,i-2)=0.0d0
1804           Ug(1,1,i-2)=1.0d0
1805           Ug(1,2,i-2)=0.0d0
1806           Ug(2,1,i-2)=0.0d0
1807           Ug(2,2,i-2)=1.0d0
1808           Ug2(1,1,i-2)=0.0d0
1809           Ug2(1,2,i-2)=0.0d0
1810           Ug2(2,1,i-2)=0.0d0
1811           Ug2(2,2,i-2)=0.0d0
1812         endif
1813         if (i .gt. 3 .and. i .lt. nres+1) then
1814           obrot_der(1,i-2)=-sin1
1815           obrot_der(2,i-2)= cos1
1816           Ugder(1,1,i-2)= sin1
1817           Ugder(1,2,i-2)=-cos1
1818           Ugder(2,1,i-2)=-cos1
1819           Ugder(2,2,i-2)=-sin1
1820           dwacos2=cos2+cos2
1821           dwasin2=sin2+sin2
1822           obrot2_der(1,i-2)=-dwasin2
1823           obrot2_der(2,i-2)= dwacos2
1824           Ug2der(1,1,i-2)= dwasin2
1825           Ug2der(1,2,i-2)=-dwacos2
1826           Ug2der(2,1,i-2)=-dwacos2
1827           Ug2der(2,2,i-2)=-dwasin2
1828         else
1829           obrot_der(1,i-2)=0.0d0
1830           obrot_der(2,i-2)=0.0d0
1831           Ugder(1,1,i-2)=0.0d0
1832           Ugder(1,2,i-2)=0.0d0
1833           Ugder(2,1,i-2)=0.0d0
1834           Ugder(2,2,i-2)=0.0d0
1835           obrot2_der(1,i-2)=0.0d0
1836           obrot2_der(2,i-2)=0.0d0
1837           Ug2der(1,1,i-2)=0.0d0
1838           Ug2der(1,2,i-2)=0.0d0
1839           Ug2der(2,1,i-2)=0.0d0
1840           Ug2der(2,2,i-2)=0.0d0
1841         endif
1842         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1843           if (itype(i-2).le.ntyp) then
1844             iti = itortyp(itype(i-2))
1845           else
1846             iti=ntortyp+1
1847           endif
1848         else
1849           iti=ntortyp+1
1850         endif
1851         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1852           if (itype(i-1).le.ntyp) then
1853             iti1 = itortyp(itype(i-1))
1854           else
1855             iti1=ntortyp+1
1856           endif
1857         else
1858           iti1=ntortyp+1
1859         endif
1860 cd        write (iout,*) '*******i',i,' iti1',iti
1861 cd        write (iout,*) 'b1',b1(:,iti)
1862 cd        write (iout,*) 'b2',b2(:,iti)
1863 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1864 c        print *,"itilde1 i iti iti1",i,iti,iti1
1865         if (i .gt. iatel_s+2) then
1866           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1867           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1868           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1869           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1870           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1871           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1872           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1873         else
1874           do k=1,2
1875             Ub2(k,i-2)=0.0d0
1876             Ctobr(k,i-2)=0.0d0
1877             Dtobr2(k,i-2)=0.0d0
1878             do l=1,2
1879               EUg(l,k,i-2)=0.0d0
1880               CUg(l,k,i-2)=0.0d0
1881               DUg(l,k,i-2)=0.0d0
1882               DtUg2(l,k,i-2)=0.0d0
1883             enddo
1884           enddo
1885         endif
1886 c        print *,"itilde2 i iti iti1",i,iti,iti1
1887         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1888         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1889         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1890         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1891         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1892         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1893         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1894 c        print *,"itilde3 i iti iti1",i,iti,iti1
1895         do k=1,2
1896           muder(k,i-2)=Ub2der(k,i-2)
1897         enddo
1898         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1899           if (itype(i-1).le.ntyp) then
1900             iti1 = itortyp(itype(i-1))
1901           else
1902             iti1=ntortyp+1
1903           endif
1904         else
1905           iti1=ntortyp+1
1906         endif
1907         do k=1,2
1908           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1909         enddo
1910 C Vectors and matrices dependent on a single virtual-bond dihedral.
1911         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1912         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1913         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1914         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1915         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1916         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1917         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1918         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1919         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1920 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1921 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1922       enddo
1923 C Matrices dependent on two consecutive virtual-bond dihedrals.
1924 C The order of matrices is from left to right.
1925       do i=2,nres-1
1926         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1927         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1928         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1929         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1930         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1931         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1932         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1933         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1934       enddo
1935 cd      do i=1,nres
1936 cd        iti = itortyp(itype(i))
1937 cd        write (iout,*) i
1938 cd        do j=1,2
1939 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1940 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1941 cd        enddo
1942 cd      enddo
1943       return
1944       end
1945 C--------------------------------------------------------------------------
1946       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1947 C
1948 C This subroutine calculates the average interaction energy and its gradient
1949 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1950 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1951 C The potential depends both on the distance of peptide-group centers and on
1952 C the orientation of the CA-CA virtual bonds.
1953 C
1954       implicit real*8 (a-h,o-z)
1955       include 'DIMENSIONS'
1956       include 'DIMENSIONS.ZSCOPT'
1957       include 'DIMENSIONS.FREE'
1958       include 'COMMON.CONTROL'
1959       include 'COMMON.IOUNITS'
1960       include 'COMMON.GEO'
1961       include 'COMMON.VAR'
1962       include 'COMMON.LOCAL'
1963       include 'COMMON.CHAIN'
1964       include 'COMMON.DERIV'
1965       include 'COMMON.INTERACT'
1966       include 'COMMON.CONTACTS'
1967       include 'COMMON.TORSION'
1968       include 'COMMON.VECTORS'
1969       include 'COMMON.FFIELD'
1970       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1971      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1972       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1973      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1974       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1975 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1976       double precision scal_el /0.5d0/
1977 C 12/13/98
1978 C 13-go grudnia roku pamietnego...
1979       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1980      &                   0.0d0,1.0d0,0.0d0,
1981      &                   0.0d0,0.0d0,1.0d0/
1982 cd      write(iout,*) 'In EELEC'
1983 cd      do i=1,nloctyp
1984 cd        write(iout,*) 'Type',i
1985 cd        write(iout,*) 'B1',B1(:,i)
1986 cd        write(iout,*) 'B2',B2(:,i)
1987 cd        write(iout,*) 'CC',CC(:,:,i)
1988 cd        write(iout,*) 'DD',DD(:,:,i)
1989 cd        write(iout,*) 'EE',EE(:,:,i)
1990 cd      enddo
1991 cd      call check_vecgrad
1992 cd      stop
1993       if (icheckgrad.eq.1) then
1994         do i=1,nres-1
1995           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1996           do k=1,3
1997             dc_norm(k,i)=dc(k,i)*fac
1998           enddo
1999 c          write (iout,*) 'i',i,' fac',fac
2000         enddo
2001       endif
2002       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2003      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2004      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2005 cd      if (wel_loc.gt.0.0d0) then
2006         if (icheckgrad.eq.1) then
2007         call vec_and_deriv_test
2008         else
2009         call vec_and_deriv
2010         endif
2011         call set_matrices
2012       endif
2013 cd      do i=1,nres-1
2014 cd        write (iout,*) 'i=',i
2015 cd        do k=1,3
2016 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2017 cd        enddo
2018 cd        do k=1,3
2019 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2020 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2021 cd        enddo
2022 cd      enddo
2023       num_conti_hb=0
2024       ees=0.0D0
2025       evdw1=0.0D0
2026       eel_loc=0.0d0
2027       eello_turn3=0.0d0
2028       eello_turn4=0.0d0
2029       ind=0
2030       do i=1,nres
2031         num_cont_hb(i)=0
2032       enddo
2033 cd      print '(a)','Enter EELEC'
2034 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2035       do i=1,nres
2036         gel_loc_loc(i)=0.0d0
2037         gcorr_loc(i)=0.0d0
2038       enddo
2039       do i=iatel_s,iatel_e
2040 cAna           if (i.le.1) cycle
2041            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2042 cAna     &  .or. ((i+2).gt.nres)
2043 cAna     &  .or. ((i-1).le.0)
2044 cAna     &  .or. itype(i+2).eq.ntyp1
2045 cAna     &  .or. itype(i-1).eq.ntyp1
2046      &) cycle
2047 C         endif
2048         if (itel(i).eq.0) goto 1215
2049         dxi=dc(1,i)
2050         dyi=dc(2,i)
2051         dzi=dc(3,i)
2052         dx_normi=dc_norm(1,i)
2053         dy_normi=dc_norm(2,i)
2054         dz_normi=dc_norm(3,i)
2055         xmedi=c(1,i)+0.5d0*dxi
2056         ymedi=c(2,i)+0.5d0*dyi
2057         zmedi=c(3,i)+0.5d0*dzi
2058           xmedi=mod(xmedi,boxxsize)
2059           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2060           ymedi=mod(ymedi,boxysize)
2061           if (ymedi.lt.0) ymedi=ymedi+boxysize
2062           zmedi=mod(zmedi,boxzsize)
2063           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2064         num_conti=0
2065 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2066         do j=ielstart(i),ielend(i)
2067 cAna          if (j.le.1) cycle
2068           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2069 cAna     & .or.((j+2).gt.nres)
2070 cAna     & .or.((j-1).le.0)
2071 cAna     & .or.itype(j+2).eq.ntyp1
2072 cAna     & .or.itype(j-1).eq.ntyp1
2073      &) cycle
2074           if (itel(j).eq.0) goto 1216
2075           ind=ind+1
2076           iteli=itel(i)
2077           itelj=itel(j)
2078           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2079           aaa=app(iteli,itelj)
2080           bbb=bpp(iteli,itelj)
2081 C Diagnostics only!!!
2082 c         aaa=0.0D0
2083 c         bbb=0.0D0
2084 c         ael6i=0.0D0
2085 c         ael3i=0.0D0
2086 C End diagnostics
2087           ael6i=ael6(iteli,itelj)
2088           ael3i=ael3(iteli,itelj)
2089           dxj=dc(1,j)
2090           dyj=dc(2,j)
2091           dzj=dc(3,j)
2092           dx_normj=dc_norm(1,j)
2093           dy_normj=dc_norm(2,j)
2094           dz_normj=dc_norm(3,j)
2095           xj=c(1,j)+0.5D0*dxj
2096           yj=c(2,j)+0.5D0*dyj
2097           zj=c(3,j)+0.5D0*dzj
2098          xj=mod(xj,boxxsize)
2099           if (xj.lt.0) xj=xj+boxxsize
2100           yj=mod(yj,boxysize)
2101           if (yj.lt.0) yj=yj+boxysize
2102           zj=mod(zj,boxzsize)
2103           if (zj.lt.0) zj=zj+boxzsize
2104       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2105       xj_safe=xj
2106       yj_safe=yj
2107       zj_safe=zj
2108       isubchap=0
2109       do xshift=-1,1
2110       do yshift=-1,1
2111       do zshift=-1,1
2112           xj=xj_safe+xshift*boxxsize
2113           yj=yj_safe+yshift*boxysize
2114           zj=zj_safe+zshift*boxzsize
2115           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2116           if(dist_temp.lt.dist_init) then
2117             dist_init=dist_temp
2118             xj_temp=xj
2119             yj_temp=yj
2120             zj_temp=zj
2121             isubchap=1
2122           endif
2123        enddo
2124        enddo
2125        enddo
2126        if (isubchap.eq.1) then
2127           xj=xj_temp-xmedi
2128           yj=yj_temp-ymedi
2129           zj=zj_temp-zmedi
2130        else
2131           xj=xj_safe-xmedi
2132           yj=yj_safe-ymedi
2133           zj=zj_safe-zmedi
2134        endif
2135           rij=xj*xj+yj*yj+zj*zj
2136             sss=sscale(sqrt(rij))
2137             sssgrad=sscagrad(sqrt(rij))
2138           rrmij=1.0D0/rij
2139           rij=dsqrt(rij)
2140           rmij=1.0D0/rij
2141           r3ij=rrmij*rmij
2142           r6ij=r3ij*r3ij
2143           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2144           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2145           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2146           fac=cosa-3.0D0*cosb*cosg
2147           ev1=aaa*r6ij*r6ij
2148 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2149           if (j.eq.i+2) ev1=scal_el*ev1
2150           ev2=bbb*r6ij
2151           fac3=ael6i*r6ij
2152           fac4=ael3i*r3ij
2153           evdwij=ev1+ev2
2154           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2155           el2=fac4*fac
2156           eesij=el1+el2
2157 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2158 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2159           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2160           ees=ees+eesij
2161           evdw1=evdw1+evdwij*sss
2162 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2163 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2164 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2165 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2166 C
2167 C Calculate contributions to the Cartesian gradient.
2168 C
2169 #ifdef SPLITELE
2170           facvdw=-6*rrmij*(ev1+evdwij)*sss
2171           facel=-3*rrmij*(el1+eesij)
2172           fac1=fac
2173           erij(1)=xj*rmij
2174           erij(2)=yj*rmij
2175           erij(3)=zj*rmij
2176           if (calc_grad) then
2177 *
2178 * Radial derivatives. First process both termini of the fragment (i,j)
2179 *
2180           ggg(1)=facel*xj
2181           ggg(2)=facel*yj
2182           ggg(3)=facel*zj
2183           do k=1,3
2184             ghalf=0.5D0*ggg(k)
2185             gelc(k,i)=gelc(k,i)+ghalf
2186             gelc(k,j)=gelc(k,j)+ghalf
2187           enddo
2188 *
2189 * Loop over residues i+1 thru j-1.
2190 *
2191           do k=i+1,j-1
2192             do l=1,3
2193               gelc(l,k)=gelc(l,k)+ggg(l)
2194             enddo
2195           enddo
2196           ggg(1)=facvdw*xj
2197           ggg(2)=facvdw*yj
2198           ggg(3)=facvdw*zj
2199           do k=1,3
2200             ghalf=0.5D0*ggg(k)
2201             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2202             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2203           enddo
2204 *
2205 * Loop over residues i+1 thru j-1.
2206 *
2207           do k=i+1,j-1
2208             do l=1,3
2209               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2210             enddo
2211           enddo
2212 #else
2213           facvdw=ev1+evdwij
2214           facel=el1+eesij
2215           fac1=fac
2216           fac=-3*rrmij*(facvdw+facvdw+facel)
2217           erij(1)=xj*rmij
2218           erij(2)=yj*rmij
2219           erij(3)=zj*rmij
2220           if (calc_grad) then
2221 *
2222 * Radial derivatives. First process both termini of the fragment (i,j)
2223 *
2224           ggg(1)=fac*xj
2225           ggg(2)=fac*yj
2226           ggg(3)=fac*zj
2227           do k=1,3
2228             ghalf=0.5D0*ggg(k)
2229             gelc(k,i)=gelc(k,i)+ghalf
2230             gelc(k,j)=gelc(k,j)+ghalf
2231           enddo
2232 *
2233 * Loop over residues i+1 thru j-1.
2234 *
2235           do k=i+1,j-1
2236             do l=1,3
2237               gelc(l,k)=gelc(l,k)+ggg(l)
2238             enddo
2239           enddo
2240 #endif
2241 *
2242 * Angular part
2243 *
2244           ecosa=2.0D0*fac3*fac1+fac4
2245           fac4=-3.0D0*fac4
2246           fac3=-6.0D0*fac3
2247           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2248           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2249           do k=1,3
2250             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2251             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2252           enddo
2253 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2254 cd   &          (dcosg(k),k=1,3)
2255           do k=1,3
2256             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2257           enddo
2258           do k=1,3
2259             ghalf=0.5D0*ggg(k)
2260             gelc(k,i)=gelc(k,i)+ghalf
2261      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2262      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2263             gelc(k,j)=gelc(k,j)+ghalf
2264      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2265      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2266           enddo
2267           do k=i+1,j-1
2268             do l=1,3
2269               gelc(l,k)=gelc(l,k)+ggg(l)
2270             enddo
2271           enddo
2272           endif
2273
2274           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2275      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2276      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2277 C
2278 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2279 C   energy of a peptide unit is assumed in the form of a second-order
2280 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2281 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2282 C   are computed for EVERY pair of non-contiguous peptide groups.
2283 C
2284           if (j.lt.nres-1) then
2285             j1=j+1
2286             j2=j-1
2287           else
2288             j1=j-1
2289             j2=j-2
2290           endif
2291           kkk=0
2292           do k=1,2
2293             do l=1,2
2294               kkk=kkk+1
2295               muij(kkk)=mu(k,i)*mu(l,j)
2296             enddo
2297           enddo
2298 cd         write (iout,*) 'EELEC: i',i,' j',j
2299 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2300 cd          write(iout,*) 'muij',muij
2301           ury=scalar(uy(1,i),erij)
2302           urz=scalar(uz(1,i),erij)
2303           vry=scalar(uy(1,j),erij)
2304           vrz=scalar(uz(1,j),erij)
2305           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2306           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2307           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2308           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2309 C For diagnostics only
2310 cd          a22=1.0d0
2311 cd          a23=1.0d0
2312 cd          a32=1.0d0
2313 cd          a33=1.0d0
2314           fac=dsqrt(-ael6i)*r3ij
2315 cd          write (2,*) 'fac=',fac
2316 C For diagnostics only
2317 cd          fac=1.0d0
2318           a22=a22*fac
2319           a23=a23*fac
2320           a32=a32*fac
2321           a33=a33*fac
2322 cd          write (iout,'(4i5,4f10.5)')
2323 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2324 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2325 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2326 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2327 cd          write (iout,'(4f10.5)')
2328 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2329 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2330 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2331 cd           write (iout,'(2i3,9f10.5/)') i,j,
2332 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2333           if (calc_grad) then
2334 C Derivatives of the elements of A in virtual-bond vectors
2335           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2336 cd          do k=1,3
2337 cd            do l=1,3
2338 cd              erder(k,l)=0.0d0
2339 cd            enddo
2340 cd          enddo
2341           do k=1,3
2342             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2343             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2344             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2345             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2346             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2347             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2348             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2349             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2350             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2351             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2352             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2353             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2354           enddo
2355 cd          do k=1,3
2356 cd            do l=1,3
2357 cd              uryg(k,l)=0.0d0
2358 cd              urzg(k,l)=0.0d0
2359 cd              vryg(k,l)=0.0d0
2360 cd              vrzg(k,l)=0.0d0
2361 cd            enddo
2362 cd          enddo
2363 C Compute radial contributions to the gradient
2364           facr=-3.0d0*rrmij
2365           a22der=a22*facr
2366           a23der=a23*facr
2367           a32der=a32*facr
2368           a33der=a33*facr
2369 cd          a22der=0.0d0
2370 cd          a23der=0.0d0
2371 cd          a32der=0.0d0
2372 cd          a33der=0.0d0
2373           agg(1,1)=a22der*xj
2374           agg(2,1)=a22der*yj
2375           agg(3,1)=a22der*zj
2376           agg(1,2)=a23der*xj
2377           agg(2,2)=a23der*yj
2378           agg(3,2)=a23der*zj
2379           agg(1,3)=a32der*xj
2380           agg(2,3)=a32der*yj
2381           agg(3,3)=a32der*zj
2382           agg(1,4)=a33der*xj
2383           agg(2,4)=a33der*yj
2384           agg(3,4)=a33der*zj
2385 C Add the contributions coming from er
2386           fac3=-3.0d0*fac
2387           do k=1,3
2388             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2389             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2390             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2391             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2392           enddo
2393           do k=1,3
2394 C Derivatives in DC(i)
2395             ghalf1=0.5d0*agg(k,1)
2396             ghalf2=0.5d0*agg(k,2)
2397             ghalf3=0.5d0*agg(k,3)
2398             ghalf4=0.5d0*agg(k,4)
2399             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2400      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2401             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2402      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2403             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2404      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2405             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2406      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2407 C Derivatives in DC(i+1)
2408             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2409      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2410             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2411      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2412             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2413      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2414             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2415      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2416 C Derivatives in DC(j)
2417             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2418      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2419             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2420      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2421             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2422      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2423             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2424      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2425 C Derivatives in DC(j+1) or DC(nres-1)
2426             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2427      &      -3.0d0*vryg(k,3)*ury)
2428             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2429      &      -3.0d0*vrzg(k,3)*ury)
2430             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2431      &      -3.0d0*vryg(k,3)*urz)
2432             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2433      &      -3.0d0*vrzg(k,3)*urz)
2434 cd            aggi(k,1)=ghalf1
2435 cd            aggi(k,2)=ghalf2
2436 cd            aggi(k,3)=ghalf3
2437 cd            aggi(k,4)=ghalf4
2438 C Derivatives in DC(i+1)
2439 cd            aggi1(k,1)=agg(k,1)
2440 cd            aggi1(k,2)=agg(k,2)
2441 cd            aggi1(k,3)=agg(k,3)
2442 cd            aggi1(k,4)=agg(k,4)
2443 C Derivatives in DC(j)
2444 cd            aggj(k,1)=ghalf1
2445 cd            aggj(k,2)=ghalf2
2446 cd            aggj(k,3)=ghalf3
2447 cd            aggj(k,4)=ghalf4
2448 C Derivatives in DC(j+1)
2449 cd            aggj1(k,1)=0.0d0
2450 cd            aggj1(k,2)=0.0d0
2451 cd            aggj1(k,3)=0.0d0
2452 cd            aggj1(k,4)=0.0d0
2453             if (j.eq.nres-1 .and. i.lt.j-2) then
2454               do l=1,4
2455                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2456 cd                aggj1(k,l)=agg(k,l)
2457               enddo
2458             endif
2459           enddo
2460           endif
2461 c          goto 11111
2462 C Check the loc-el terms by numerical integration
2463           acipa(1,1)=a22
2464           acipa(1,2)=a23
2465           acipa(2,1)=a32
2466           acipa(2,2)=a33
2467           a22=-a22
2468           a23=-a23
2469           do l=1,2
2470             do k=1,3
2471               agg(k,l)=-agg(k,l)
2472               aggi(k,l)=-aggi(k,l)
2473               aggi1(k,l)=-aggi1(k,l)
2474               aggj(k,l)=-aggj(k,l)
2475               aggj1(k,l)=-aggj1(k,l)
2476             enddo
2477           enddo
2478           if (j.lt.nres-1) then
2479             a22=-a22
2480             a32=-a32
2481             do l=1,3,2
2482               do k=1,3
2483                 agg(k,l)=-agg(k,l)
2484                 aggi(k,l)=-aggi(k,l)
2485                 aggi1(k,l)=-aggi1(k,l)
2486                 aggj(k,l)=-aggj(k,l)
2487                 aggj1(k,l)=-aggj1(k,l)
2488               enddo
2489             enddo
2490           else
2491             a22=-a22
2492             a23=-a23
2493             a32=-a32
2494             a33=-a33
2495             do l=1,4
2496               do k=1,3
2497                 agg(k,l)=-agg(k,l)
2498                 aggi(k,l)=-aggi(k,l)
2499                 aggi1(k,l)=-aggi1(k,l)
2500                 aggj(k,l)=-aggj(k,l)
2501                 aggj1(k,l)=-aggj1(k,l)
2502               enddo
2503             enddo
2504           endif
2505           ENDIF ! WCORR
2506 11111     continue
2507           IF (wel_loc.gt.0.0d0) THEN
2508 C Contribution to the local-electrostatic energy coming from the i-j pair
2509           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2510      &     +a33*muij(4)
2511 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2512 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2513           eel_loc=eel_loc+eel_loc_ij
2514 C Partial derivatives in virtual-bond dihedral angles gamma
2515           if (calc_grad) then
2516           if (i.gt.1)
2517      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2518      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2519      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2520           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2521      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2522      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2523 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2524 cd          write(iout,*) 'agg  ',agg
2525 cd          write(iout,*) 'aggi ',aggi
2526 cd          write(iout,*) 'aggi1',aggi1
2527 cd          write(iout,*) 'aggj ',aggj
2528 cd          write(iout,*) 'aggj1',aggj1
2529
2530 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2531           do l=1,3
2532             ggg(l)=agg(l,1)*muij(1)+
2533      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2534           enddo
2535           do k=i+2,j2
2536             do l=1,3
2537               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2538             enddo
2539           enddo
2540 C Remaining derivatives of eello
2541           do l=1,3
2542             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2543      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2544             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2545      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2546             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2547      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2548             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2549      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2550           enddo
2551           endif
2552           ENDIF
2553           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2554 C Contributions from turns
2555             a_temp(1,1)=a22
2556             a_temp(1,2)=a23
2557             a_temp(2,1)=a32
2558             a_temp(2,2)=a33
2559             call eturn34(i,j,eello_turn3,eello_turn4)
2560           endif
2561 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2562           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2563 C
2564 C Calculate the contact function. The ith column of the array JCONT will
2565 C contain the numbers of atoms that make contacts with the atom I (of numbers
2566 C greater than I). The arrays FACONT and GACONT will contain the values of
2567 C the contact function and its derivative.
2568 c           r0ij=1.02D0*rpp(iteli,itelj)
2569 c           r0ij=1.11D0*rpp(iteli,itelj)
2570             r0ij=2.20D0*rpp(iteli,itelj)
2571 c           r0ij=1.55D0*rpp(iteli,itelj)
2572             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2573             if (fcont.gt.0.0D0) then
2574               num_conti=num_conti+1
2575               if (num_conti.gt.maxconts) then
2576                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2577      &                         ' will skip next contacts for this conf.'
2578               else
2579                 jcont_hb(num_conti,i)=j
2580                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2581      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2582 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2583 C  terms.
2584                 d_cont(num_conti,i)=rij
2585 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2586 C     --- Electrostatic-interaction matrix ---
2587                 a_chuj(1,1,num_conti,i)=a22
2588                 a_chuj(1,2,num_conti,i)=a23
2589                 a_chuj(2,1,num_conti,i)=a32
2590                 a_chuj(2,2,num_conti,i)=a33
2591 C     --- Gradient of rij
2592                 do kkk=1,3
2593                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2594                 enddo
2595 c             if (i.eq.1) then
2596 c                a_chuj(1,1,num_conti,i)=-0.61d0
2597 c                a_chuj(1,2,num_conti,i)= 0.4d0
2598 c                a_chuj(2,1,num_conti,i)= 0.65d0
2599 c                a_chuj(2,2,num_conti,i)= 0.50d0
2600 c             else if (i.eq.2) then
2601 c                a_chuj(1,1,num_conti,i)= 0.0d0
2602 c                a_chuj(1,2,num_conti,i)= 0.0d0
2603 c                a_chuj(2,1,num_conti,i)= 0.0d0
2604 c                a_chuj(2,2,num_conti,i)= 0.0d0
2605 c             endif
2606 C     --- and its gradients
2607 cd                write (iout,*) 'i',i,' j',j
2608 cd                do kkk=1,3
2609 cd                write (iout,*) 'iii 1 kkk',kkk
2610 cd                write (iout,*) agg(kkk,:)
2611 cd                enddo
2612 cd                do kkk=1,3
2613 cd                write (iout,*) 'iii 2 kkk',kkk
2614 cd                write (iout,*) aggi(kkk,:)
2615 cd                enddo
2616 cd                do kkk=1,3
2617 cd                write (iout,*) 'iii 3 kkk',kkk
2618 cd                write (iout,*) aggi1(kkk,:)
2619 cd                enddo
2620 cd                do kkk=1,3
2621 cd                write (iout,*) 'iii 4 kkk',kkk
2622 cd                write (iout,*) aggj(kkk,:)
2623 cd                enddo
2624 cd                do kkk=1,3
2625 cd                write (iout,*) 'iii 5 kkk',kkk
2626 cd                write (iout,*) aggj1(kkk,:)
2627 cd                enddo
2628                 kkll=0
2629                 do k=1,2
2630                   do l=1,2
2631                     kkll=kkll+1
2632                     do m=1,3
2633                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2634                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2635                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2636                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2637                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2638 c                      do mm=1,5
2639 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2640 c                      enddo
2641                     enddo
2642                   enddo
2643                 enddo
2644                 ENDIF
2645                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2646 C Calculate contact energies
2647                 cosa4=4.0D0*cosa
2648                 wij=cosa-3.0D0*cosb*cosg
2649                 cosbg1=cosb+cosg
2650                 cosbg2=cosb-cosg
2651 c               fac3=dsqrt(-ael6i)/r0ij**3
2652                 fac3=dsqrt(-ael6i)*r3ij
2653                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2654                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2655 c               ees0mij=0.0D0
2656                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2657                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2658 C Diagnostics. Comment out or remove after debugging!
2659 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2660 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2661 c               ees0m(num_conti,i)=0.0D0
2662 C End diagnostics.
2663 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2664 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2665                 facont_hb(num_conti,i)=fcont
2666                 if (calc_grad) then
2667 C Angular derivatives of the contact function
2668                 ees0pij1=fac3/ees0pij
2669                 ees0mij1=fac3/ees0mij
2670                 fac3p=-3.0D0*fac3*rrmij
2671                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2672                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2673 c               ees0mij1=0.0D0
2674                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2675                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2676                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2677                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2678                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2679                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2680                 ecosap=ecosa1+ecosa2
2681                 ecosbp=ecosb1+ecosb2
2682                 ecosgp=ecosg1+ecosg2
2683                 ecosam=ecosa1-ecosa2
2684                 ecosbm=ecosb1-ecosb2
2685                 ecosgm=ecosg1-ecosg2
2686 C Diagnostics
2687 c               ecosap=ecosa1
2688 c               ecosbp=ecosb1
2689 c               ecosgp=ecosg1
2690 c               ecosam=0.0D0
2691 c               ecosbm=0.0D0
2692 c               ecosgm=0.0D0
2693 C End diagnostics
2694                 fprimcont=fprimcont/rij
2695 cd              facont_hb(num_conti,i)=1.0D0
2696 C Following line is for diagnostics.
2697 cd              fprimcont=0.0D0
2698                 do k=1,3
2699                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2700                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2701                 enddo
2702                 do k=1,3
2703                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2704                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2705                 enddo
2706                 gggp(1)=gggp(1)+ees0pijp*xj
2707                 gggp(2)=gggp(2)+ees0pijp*yj
2708                 gggp(3)=gggp(3)+ees0pijp*zj
2709                 gggm(1)=gggm(1)+ees0mijp*xj
2710                 gggm(2)=gggm(2)+ees0mijp*yj
2711                 gggm(3)=gggm(3)+ees0mijp*zj
2712 C Derivatives due to the contact function
2713                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2714                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2715                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2716                 do k=1,3
2717                   ghalfp=0.5D0*gggp(k)
2718                   ghalfm=0.5D0*gggm(k)
2719                   gacontp_hb1(k,num_conti,i)=ghalfp
2720      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2721      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2722                   gacontp_hb2(k,num_conti,i)=ghalfp
2723      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2724      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2725                   gacontp_hb3(k,num_conti,i)=gggp(k)
2726                   gacontm_hb1(k,num_conti,i)=ghalfm
2727      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2728      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2729                   gacontm_hb2(k,num_conti,i)=ghalfm
2730      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2731      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2732                   gacontm_hb3(k,num_conti,i)=gggm(k)
2733                 enddo
2734                 endif
2735 C Diagnostics. Comment out or remove after debugging!
2736 cdiag           do k=1,3
2737 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2738 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2739 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2740 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2741 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2742 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2743 cdiag           enddo
2744               ENDIF ! wcorr
2745               endif  ! num_conti.le.maxconts
2746             endif  ! fcont.gt.0
2747           endif    ! j.gt.i+1
2748  1216     continue
2749         enddo ! j
2750         num_cont_hb(i)=num_conti
2751  1215   continue
2752       enddo   ! i
2753 cd      do i=1,nres
2754 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2755 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2756 cd      enddo
2757 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2758 ccc      eel_loc=eel_loc+eello_turn3
2759       return
2760       end
2761 C-----------------------------------------------------------------------------
2762       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2763 C Third- and fourth-order contributions from turns
2764       implicit real*8 (a-h,o-z)
2765       include 'DIMENSIONS'
2766       include 'DIMENSIONS.ZSCOPT'
2767       include 'COMMON.IOUNITS'
2768       include 'COMMON.GEO'
2769       include 'COMMON.VAR'
2770       include 'COMMON.LOCAL'
2771       include 'COMMON.CHAIN'
2772       include 'COMMON.DERIV'
2773       include 'COMMON.INTERACT'
2774       include 'COMMON.CONTACTS'
2775       include 'COMMON.TORSION'
2776       include 'COMMON.VECTORS'
2777       include 'COMMON.FFIELD'
2778       dimension ggg(3)
2779       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2780      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2781      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2782       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2783      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2784       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2785       if (j.eq.i+2) then
2786       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2787 C changes suggested by Ana to avoid out of bounds
2788 C     & .or.((i+5).gt.nres)
2789 C     & .or.((i-1).le.0)
2790 C end of changes suggested by Ana
2791      &    .or. itype(i+2).eq.ntyp1
2792      &    .or. itype(i+3).eq.ntyp1
2793 C     &    .or. itype(i+5).eq.ntyp1
2794 C     &    .or. itype(i).eq.ntyp1
2795 C     &    .or. itype(i-1).eq.ntyp1
2796      &    ) goto 179
2797
2798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2799 C
2800 C               Third-order contributions
2801 C
2802 C                 (i+2)o----(i+3)
2803 C                      | |
2804 C                      | |
2805 C                 (i+1)o----i
2806 C
2807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2808 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2809         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2810         call transpose2(auxmat(1,1),auxmat1(1,1))
2811         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2812         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2813 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2814 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2815 cd     &    ' eello_turn3_num',4*eello_turn3_num
2816         if (calc_grad) then
2817 C Derivatives in gamma(i)
2818         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2819         call transpose2(auxmat2(1,1),pizda(1,1))
2820         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2821         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2822 C Derivatives in gamma(i+1)
2823         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2824         call transpose2(auxmat2(1,1),pizda(1,1))
2825         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2826         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2827      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2828 C Cartesian derivatives
2829         do l=1,3
2830           a_temp(1,1)=aggi(l,1)
2831           a_temp(1,2)=aggi(l,2)
2832           a_temp(2,1)=aggi(l,3)
2833           a_temp(2,2)=aggi(l,4)
2834           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2835           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2836      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2837           a_temp(1,1)=aggi1(l,1)
2838           a_temp(1,2)=aggi1(l,2)
2839           a_temp(2,1)=aggi1(l,3)
2840           a_temp(2,2)=aggi1(l,4)
2841           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2842           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2843      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2844           a_temp(1,1)=aggj(l,1)
2845           a_temp(1,2)=aggj(l,2)
2846           a_temp(2,1)=aggj(l,3)
2847           a_temp(2,2)=aggj(l,4)
2848           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2849           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2850      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2851           a_temp(1,1)=aggj1(l,1)
2852           a_temp(1,2)=aggj1(l,2)
2853           a_temp(2,1)=aggj1(l,3)
2854           a_temp(2,2)=aggj1(l,4)
2855           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2856           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2857      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2858         enddo
2859         endif
2860   179 continue
2861       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2862       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2863 C changes suggested by Ana to avoid out of bounds
2864 C     & .or.((i+5).gt.nres)
2865 C     & .or.((i-1).le.0)
2866 C end of changes suggested by Ana
2867      &    .or. itype(i+3).eq.ntyp1
2868      &    .or. itype(i+4).eq.ntyp1
2869 C     &    .or. itype(i+5).eq.ntyp1
2870      &    .or. itype(i).eq.ntyp1
2871 C     &    .or. itype(i-1).eq.ntyp1
2872      &    ) goto 178
2873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2874 C
2875 C               Fourth-order contributions
2876 C
2877 C                 (i+3)o----(i+4)
2878 C                     /  |
2879 C               (i+2)o   |
2880 C                     \  |
2881 C                 (i+1)o----i
2882 C
2883 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2884 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2885         iti1=itortyp(itype(i+1))
2886         iti2=itortyp(itype(i+2))
2887         iti3=itortyp(itype(i+3))
2888         call transpose2(EUg(1,1,i+1),e1t(1,1))
2889         call transpose2(Eug(1,1,i+2),e2t(1,1))
2890         call transpose2(Eug(1,1,i+3),e3t(1,1))
2891         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2892         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2893         s1=scalar2(b1(1,iti2),auxvec(1))
2894         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2895         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2896         s2=scalar2(b1(1,iti1),auxvec(1))
2897         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2898         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2900         eello_turn4=eello_turn4-(s1+s2+s3)
2901 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2902 cd     &    ' eello_turn4_num',8*eello_turn4_num
2903 C Derivatives in gamma(i)
2904         if (calc_grad) then
2905         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2906         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2907         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2908         s1=scalar2(b1(1,iti2),auxvec(1))
2909         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2911         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2912 C Derivatives in gamma(i+1)
2913         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2914         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2915         s2=scalar2(b1(1,iti1),auxvec(1))
2916         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2917         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2919         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2920 C Derivatives in gamma(i+2)
2921         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2922         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2923         s1=scalar2(b1(1,iti2),auxvec(1))
2924         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2925         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2926         s2=scalar2(b1(1,iti1),auxvec(1))
2927         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2928         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2929         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2930         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2931 C Cartesian derivatives
2932 C Derivatives of this turn contributions in DC(i+2)
2933         if (j.lt.nres-1) then
2934           do l=1,3
2935             a_temp(1,1)=agg(l,1)
2936             a_temp(1,2)=agg(l,2)
2937             a_temp(2,1)=agg(l,3)
2938             a_temp(2,2)=agg(l,4)
2939             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2940             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2941             s1=scalar2(b1(1,iti2),auxvec(1))
2942             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2943             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2944             s2=scalar2(b1(1,iti1),auxvec(1))
2945             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2946             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2947             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2948             ggg(l)=-(s1+s2+s3)
2949             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2950           enddo
2951         endif
2952 C Remaining derivatives of this turn contribution
2953         do l=1,3
2954           a_temp(1,1)=aggi(l,1)
2955           a_temp(1,2)=aggi(l,2)
2956           a_temp(2,1)=aggi(l,3)
2957           a_temp(2,2)=aggi(l,4)
2958           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2959           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2960           s1=scalar2(b1(1,iti2),auxvec(1))
2961           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2962           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2963           s2=scalar2(b1(1,iti1),auxvec(1))
2964           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2965           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2966           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2967           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2968           a_temp(1,1)=aggi1(l,1)
2969           a_temp(1,2)=aggi1(l,2)
2970           a_temp(2,1)=aggi1(l,3)
2971           a_temp(2,2)=aggi1(l,4)
2972           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2973           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2974           s1=scalar2(b1(1,iti2),auxvec(1))
2975           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2976           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2977           s2=scalar2(b1(1,iti1),auxvec(1))
2978           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2979           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2980           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2981           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2982           a_temp(1,1)=aggj(l,1)
2983           a_temp(1,2)=aggj(l,2)
2984           a_temp(2,1)=aggj(l,3)
2985           a_temp(2,2)=aggj(l,4)
2986           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2987           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2988           s1=scalar2(b1(1,iti2),auxvec(1))
2989           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2990           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2991           s2=scalar2(b1(1,iti1),auxvec(1))
2992           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2993           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2994           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2995           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2996           a_temp(1,1)=aggj1(l,1)
2997           a_temp(1,2)=aggj1(l,2)
2998           a_temp(2,1)=aggj1(l,3)
2999           a_temp(2,2)=aggj1(l,4)
3000           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3001           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3002           s1=scalar2(b1(1,iti2),auxvec(1))
3003           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3004           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3005           s2=scalar2(b1(1,iti1),auxvec(1))
3006           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3007           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3008           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3009           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3010         enddo
3011         endif
3012  178  continue
3013       endif
3014       return
3015       end
3016 C-----------------------------------------------------------------------------
3017       subroutine vecpr(u,v,w)
3018       implicit real*8(a-h,o-z)
3019       dimension u(3),v(3),w(3)
3020       w(1)=u(2)*v(3)-u(3)*v(2)
3021       w(2)=-u(1)*v(3)+u(3)*v(1)
3022       w(3)=u(1)*v(2)-u(2)*v(1)
3023       return
3024       end
3025 C-----------------------------------------------------------------------------
3026       subroutine unormderiv(u,ugrad,unorm,ungrad)
3027 C This subroutine computes the derivatives of a normalized vector u, given
3028 C the derivatives computed without normalization conditions, ugrad. Returns
3029 C ungrad.
3030       implicit none
3031       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3032       double precision vec(3)
3033       double precision scalar
3034       integer i,j
3035 c      write (2,*) 'ugrad',ugrad
3036 c      write (2,*) 'u',u
3037       do i=1,3
3038         vec(i)=scalar(ugrad(1,i),u(1))
3039       enddo
3040 c      write (2,*) 'vec',vec
3041       do i=1,3
3042         do j=1,3
3043           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3044         enddo
3045       enddo
3046 c      write (2,*) 'ungrad',ungrad
3047       return
3048       end
3049 C-----------------------------------------------------------------------------
3050       subroutine escp(evdw2,evdw2_14)
3051 C
3052 C This subroutine calculates the excluded-volume interaction energy between
3053 C peptide-group centers and side chains and its gradient in virtual-bond and
3054 C side-chain vectors.
3055 C
3056       implicit real*8 (a-h,o-z)
3057       include 'DIMENSIONS'
3058       include 'DIMENSIONS.ZSCOPT'
3059       include 'COMMON.GEO'
3060       include 'COMMON.VAR'
3061       include 'COMMON.LOCAL'
3062       include 'COMMON.CHAIN'
3063       include 'COMMON.DERIV'
3064       include 'COMMON.INTERACT'
3065       include 'COMMON.FFIELD'
3066       include 'COMMON.IOUNITS'
3067       dimension ggg(3)
3068       evdw2=0.0D0
3069       evdw2_14=0.0d0
3070 cd    print '(a)','Enter ESCP'
3071 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3072 c     &  ' scal14',scal14
3073       do i=iatscp_s,iatscp_e
3074         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3075         iteli=itel(i)
3076 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3077 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3078         if (iteli.eq.0) goto 1225
3079         xi=0.5D0*(c(1,i)+c(1,i+1))
3080         yi=0.5D0*(c(2,i)+c(2,i+1))
3081         zi=0.5D0*(c(3,i)+c(3,i+1))
3082 C Returning the ith atom to box
3083           xi=mod(xi,boxxsize)
3084           if (xi.lt.0) xi=xi+boxxsize
3085           yi=mod(yi,boxysize)
3086           if (yi.lt.0) yi=yi+boxysize
3087           zi=mod(zi,boxzsize)
3088           if (zi.lt.0) zi=zi+boxzsize
3089         do iint=1,nscp_gr(i)
3090
3091         do j=iscpstart(i,iint),iscpend(i,iint)
3092           itypj=iabs(itype(j))
3093           if (itypj.eq.ntyp1) cycle
3094 C Uncomment following three lines for SC-p interactions
3095 c         xj=c(1,nres+j)-xi
3096 c         yj=c(2,nres+j)-yi
3097 c         zj=c(3,nres+j)-zi
3098 C Uncomment following three lines for Ca-p interactions
3099           xj=c(1,j)
3100           yj=c(2,j)
3101           zj=c(3,j)
3102 C returning the jth atom to box
3103           xj=mod(xj,boxxsize)
3104           if (xj.lt.0) xj=xj+boxxsize
3105           yj=mod(yj,boxysize)
3106           if (yj.lt.0) yj=yj+boxysize
3107           zj=mod(zj,boxzsize)
3108           if (zj.lt.0) zj=zj+boxzsize
3109       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3110       xj_safe=xj
3111       yj_safe=yj
3112       zj_safe=zj
3113       subchap=0
3114 C Finding the closest jth atom
3115       do xshift=-1,1
3116       do yshift=-1,1
3117       do zshift=-1,1
3118           xj=xj_safe+xshift*boxxsize
3119           yj=yj_safe+yshift*boxysize
3120           zj=zj_safe+zshift*boxzsize
3121           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3122           if(dist_temp.lt.dist_init) then
3123             dist_init=dist_temp
3124             xj_temp=xj
3125             yj_temp=yj
3126             zj_temp=zj
3127             subchap=1
3128           endif
3129        enddo
3130        enddo
3131        enddo
3132        if (subchap.eq.1) then
3133           xj=xj_temp-xi
3134           yj=yj_temp-yi
3135           zj=zj_temp-zi
3136        else
3137           xj=xj_safe-xi
3138           yj=yj_safe-yi
3139           zj=zj_safe-zi
3140        endif
3141           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3142 C sss is scaling function for smoothing the cutoff gradient otherwise
3143 C the gradient would not be continuouse
3144           sss=sscale(1.0d0/(dsqrt(rrij)))
3145           if (sss.le.0.0d0) cycle
3146           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3147           fac=rrij**expon2
3148           e1=fac*fac*aad(itypj,iteli)
3149           e2=fac*bad(itypj,iteli)
3150           if (iabs(j-i) .le. 2) then
3151             e1=scal14*e1
3152             e2=scal14*e2
3153             evdw2_14=evdw2_14+(e1+e2)*sss
3154           endif
3155           evdwij=e1+e2
3156 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3157 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3158 c     &       bad(itypj,iteli)
3159           evdw2=evdw2+evdwij*sss
3160           if (calc_grad) then
3161 C
3162 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3163 C
3164           fac=-(evdwij+e1)*rrij*sss
3165           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3166           ggg(1)=xj*fac
3167           ggg(2)=yj*fac
3168           ggg(3)=zj*fac
3169           if (j.lt.i) then
3170 cd          write (iout,*) 'j<i'
3171 C Uncomment following three lines for SC-p interactions
3172 c           do k=1,3
3173 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3174 c           enddo
3175           else
3176 cd          write (iout,*) 'j>i'
3177             do k=1,3
3178               ggg(k)=-ggg(k)
3179 C Uncomment following line for SC-p interactions
3180 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3181             enddo
3182           endif
3183           do k=1,3
3184             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3185           enddo
3186           kstart=min0(i+1,j)
3187           kend=max0(i-1,j-1)
3188 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3189 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3190           do k=kstart,kend
3191             do l=1,3
3192               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3193             enddo
3194           enddo
3195           endif
3196         enddo
3197         enddo ! iint
3198  1225   continue
3199       enddo ! i
3200       do i=1,nct
3201         do j=1,3
3202           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3203           gradx_scp(j,i)=expon*gradx_scp(j,i)
3204         enddo
3205       enddo
3206 C******************************************************************************
3207 C
3208 C                              N O T E !!!
3209 C
3210 C To save time the factor EXPON has been extracted from ALL components
3211 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3212 C use!
3213 C
3214 C******************************************************************************
3215       return
3216       end
3217 C--------------------------------------------------------------------------
3218       subroutine edis(ehpb)
3219 C
3220 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3221 C
3222       implicit real*8 (a-h,o-z)
3223       include 'DIMENSIONS'
3224       include 'DIMENSIONS.FREE'
3225       include 'COMMON.SBRIDGE'
3226       include 'COMMON.CHAIN'
3227       include 'COMMON.DERIV'
3228       include 'COMMON.VAR'
3229       include 'COMMON.INTERACT'
3230       include 'COMMON.CONTROL'
3231       include 'COMMON.IOUNITS'
3232       dimension ggg(3)
3233       ehpb=0.0D0
3234       do i=1,3
3235        ggg(i)=0.0d0
3236       enddo
3237 C      write (iout,*) ,"link_end",link_end,constr_dist
3238 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3239 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
3240 c     &  " constr_dist",constr_dist
3241       if (link_end.eq.0) return
3242       do i=link_start,link_end
3243 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3244 C CA-CA distance used in regularization of structure.
3245         ii=ihpb(i)
3246         jj=jhpb(i)
3247 C iii and jjj point to the residues for which the distance is assigned.
3248         if (ii.gt.nres) then
3249           iii=ii-nres
3250           jjj=jj-nres
3251         else
3252           iii=ii
3253           jjj=jj
3254         endif
3255 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3256 c     &    dhpb(i),dhpb1(i),forcon(i)
3257 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3258 C    distance and angle dependent SS bond potential.
3259 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3260 C     & iabs(itype(jjj)).eq.1) then
3261 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3262 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3263         if (.not.dyn_ss .and. i.le.nss) then
3264 C 15/02/13 CC dynamic SSbond - additional check
3265           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3266      &        iabs(itype(jjj)).eq.1) then
3267            call ssbond_ene(iii,jjj,eij)
3268            ehpb=ehpb+2*eij
3269          endif
3270 cd          write (iout,*) "eij",eij
3271 cd   &   ' waga=',waga,' fac=',fac
3272 !        else if (ii.gt.nres .and. jj.gt.nres) then
3273         else
3274 C Calculate the distance between the two points and its difference from the
3275 C target distance.
3276           dd=dist(ii,jj)
3277           if (irestr_type(i).eq.11) then
3278             ehpb=ehpb+fordepth(i)!**4.0d0
3279      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3280             fac=fordepth(i)!**4.0d0
3281      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3282 c            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
3283 c     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3284 c     &        ehpb,irestr_type(i)
3285           else if (irestr_type(i).eq.10) then
3286 c AL 6//19/2018 cross-link restraints
3287             xdis = 0.5d0*(dd/forcon(i))**2
3288             expdis = dexp(-xdis)
3289 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
3290             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
3291 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
3292 c     &          " wboltzd",wboltzd
3293             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
3294 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
3295             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
3296      &           *expdis/(aux*forcon(i)**2)
3297 c            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
3298 c     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3299 c     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
3300           else if (irestr_type(i).eq.2) then
3301 c Quartic restraints
3302             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3303 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3304 c     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3305 c     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
3306             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3307           else
3308 c Quadratic restraints
3309             rdis=dd-dhpb(i)
3310 C Get the force constant corresponding to this distance.
3311             waga=forcon(i)
3312 C Calculate the contribution to energy.
3313             ehpb=ehpb+0.5d0*waga*rdis*rdis
3314 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3315 c     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3316 c     &       0.5d0*waga*rdis*rdis,irestr_type(i)
3317 C
3318 C Evaluate gradient.
3319 C
3320             fac=waga*rdis/dd
3321           endif
3322 c Calculate Cartesian gradient
3323           do j=1,3
3324             ggg(j)=fac*(c(j,jj)-c(j,ii))
3325           enddo
3326 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3327 C If this is a SC-SC distance, we need to calculate the contributions to the
3328 C Cartesian gradient in the SC vectors (ghpbx).
3329           if (iii.lt.ii) then
3330             do j=1,3
3331               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3332               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3333             enddo
3334           endif
3335           do k=1,3
3336             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3337             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3338           enddo
3339         endif
3340       enddo
3341       return
3342       end
3343 C--------------------------------------------------------------------------
3344       subroutine ssbond_ene(i,j,eij)
3345 C
3346 C Calculate the distance and angle dependent SS-bond potential energy
3347 C using a free-energy function derived based on RHF/6-31G** ab initio
3348 C calculations of diethyl disulfide.
3349 C
3350 C A. Liwo and U. Kozlowska, 11/24/03
3351 C
3352       implicit real*8 (a-h,o-z)
3353       include 'DIMENSIONS'
3354       include 'DIMENSIONS.ZSCOPT'
3355       include 'COMMON.SBRIDGE'
3356       include 'COMMON.CHAIN'
3357       include 'COMMON.DERIV'
3358       include 'COMMON.LOCAL'
3359       include 'COMMON.INTERACT'
3360       include 'COMMON.VAR'
3361       include 'COMMON.IOUNITS'
3362       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3363       itypi=iabs(itype(i))
3364       xi=c(1,nres+i)
3365       yi=c(2,nres+i)
3366       zi=c(3,nres+i)
3367       dxi=dc_norm(1,nres+i)
3368       dyi=dc_norm(2,nres+i)
3369       dzi=dc_norm(3,nres+i)
3370       dsci_inv=dsc_inv(itypi)
3371       itypj=iabs(itype(j))
3372       dscj_inv=dsc_inv(itypj)
3373       xj=c(1,nres+j)-xi
3374       yj=c(2,nres+j)-yi
3375       zj=c(3,nres+j)-zi
3376       dxj=dc_norm(1,nres+j)
3377       dyj=dc_norm(2,nres+j)
3378       dzj=dc_norm(3,nres+j)
3379       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3380       rij=dsqrt(rrij)
3381       erij(1)=xj*rij
3382       erij(2)=yj*rij
3383       erij(3)=zj*rij
3384       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3385       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3386       om12=dxi*dxj+dyi*dyj+dzi*dzj
3387       do k=1,3
3388         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3389         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3390       enddo
3391       rij=1.0d0/rij
3392       deltad=rij-d0cm
3393       deltat1=1.0d0-om1
3394       deltat2=1.0d0+om2
3395       deltat12=om2-om1+2.0d0
3396       cosphi=om12-om1*om2
3397       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3398      &  +akct*deltad*deltat12
3399      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3400 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3401 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3402 c     &  " deltat12",deltat12," eij",eij
3403       ed=2*akcm*deltad+akct*deltat12
3404       pom1=akct*deltad
3405       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3406       eom1=-2*akth*deltat1-pom1-om2*pom2
3407       eom2= 2*akth*deltat2+pom1-om1*pom2
3408       eom12=pom2
3409       do k=1,3
3410         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3411       enddo
3412       do k=1,3
3413         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3414      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3415         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3416      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3417       enddo
3418 C
3419 C Calculate the components of the gradient in DC and X
3420 C
3421       do k=i,j-1
3422         do l=1,3
3423           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3424         enddo
3425       enddo
3426       return
3427       end
3428 C--------------------------------------------------------------------------
3429 c MODELLER restraint function
3430       subroutine e_modeller(ehomology_constr)
3431       implicit real*8 (a-h,o-z)
3432       include 'DIMENSIONS'
3433       include 'DIMENSIONS.ZSCOPT'
3434       include 'DIMENSIONS.FREE'
3435       integer nnn, i, j, k, ki, irec, l
3436       integer katy, odleglosci, test7
3437       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3438       real*8 distance(max_template),distancek(max_template),
3439      &    min_odl,godl(max_template),dih_diff(max_template)
3440
3441 c
3442 c     FP - 30/10/2014 Temporary specifications for homology restraints
3443 c
3444       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3445      &                 sgtheta
3446       double precision, dimension (maxres) :: guscdiff,usc_diff
3447       double precision, dimension (max_template) ::
3448      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3449      &           theta_diff
3450
3451       include 'COMMON.SBRIDGE'
3452       include 'COMMON.CHAIN'
3453       include 'COMMON.GEO'
3454       include 'COMMON.DERIV'
3455       include 'COMMON.LOCAL'
3456       include 'COMMON.INTERACT'
3457       include 'COMMON.VAR'
3458       include 'COMMON.IOUNITS'
3459       include 'COMMON.CONTROL'
3460       include 'COMMON.HOMRESTR'
3461 c
3462       include 'COMMON.SETUP'
3463       include 'COMMON.NAMES'
3464
3465       do i=1,max_template
3466         distancek(i)=9999999.9
3467       enddo
3468
3469       odleg=0.0d0
3470
3471 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3472 c function)
3473 C AL 5/2/14 - Introduce list of restraints
3474 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3475 #ifdef DEBUG
3476       write(iout,*) "------- dist restrs start -------"
3477 #endif
3478       do ii = link_start_homo,link_end_homo
3479          i = ires_homo(ii)
3480          j = jres_homo(ii)
3481          dij=dist(i,j)
3482 c        write (iout,*) "dij(",i,j,") =",dij
3483          nexl=0
3484          do k=1,constr_homology
3485            if(.not.l_homo(k,ii)) then
3486               nexl=nexl+1
3487               cycle
3488            endif
3489            distance(k)=odl(k,ii)-dij
3490 c          write (iout,*) "distance(",k,") =",distance(k)
3491 c
3492 c          For Gaussian-type Urestr
3493 c
3494            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3495 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3496 c          write (iout,*) "distancek(",k,") =",distancek(k)
3497 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3498 c
3499 c          For Lorentzian-type Urestr
3500 c
3501            if (waga_dist.lt.0.0d0) then
3502               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3503               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3504      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3505            endif
3506          enddo
3507
3508 c         min_odl=minval(distancek)
3509          do kk=1,constr_homology
3510           if(l_homo(kk,ii)) then
3511             min_odl=distancek(kk)
3512             exit
3513           endif
3514          enddo
3515          do kk=1,constr_homology
3516           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3517      &              min_odl=distancek(kk)
3518          enddo
3519 c        write (iout,* )"min_odl",min_odl
3520 #ifdef DEBUG
3521          write (iout,*) "ij dij",i,j,dij
3522          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3523          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3524          write (iout,* )"min_odl",min_odl
3525 #endif
3526 #ifdef OLDRESTR
3527          odleg2=0.0d0
3528 #else
3529          if (waga_dist.ge.0.0d0) then
3530            odleg2=nexl
3531          else
3532            odleg2=0.0d0
3533          endif
3534 #endif
3535          do k=1,constr_homology
3536 c Nie wiem po co to liczycie jeszcze raz!
3537 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3538 c     &              (2*(sigma_odl(i,j,k))**2))
3539            if(.not.l_homo(k,ii)) cycle
3540            if (waga_dist.ge.0.0d0) then
3541 c
3542 c          For Gaussian-type Urestr
3543 c
3544             godl(k)=dexp(-distancek(k)+min_odl)
3545             odleg2=odleg2+godl(k)
3546 c
3547 c          For Lorentzian-type Urestr
3548 c
3549            else
3550             odleg2=odleg2+distancek(k)
3551            endif
3552
3553 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3554 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3555 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3556 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3557
3558          enddo
3559 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3560 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3561 #ifdef DEBUG
3562          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3563          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3564 #endif
3565            if (waga_dist.ge.0.0d0) then
3566 c
3567 c          For Gaussian-type Urestr
3568 c
3569               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3570 c
3571 c          For Lorentzian-type Urestr
3572 c
3573            else
3574               odleg=odleg+odleg2/constr_homology
3575            endif
3576 c
3577 #ifdef GRAD
3578 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3579 c Gradient
3580 c
3581 c          For Gaussian-type Urestr
3582 c
3583          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3584          sum_sgodl=0.0d0
3585          do k=1,constr_homology
3586 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3587 c     &           *waga_dist)+min_odl
3588 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3589 c
3590          if(.not.l_homo(k,ii)) cycle
3591          if (waga_dist.ge.0.0d0) then
3592 c          For Gaussian-type Urestr
3593 c
3594            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3595 c
3596 c          For Lorentzian-type Urestr
3597 c
3598          else
3599            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3600      &           sigma_odlir(k,ii)**2)**2)
3601          endif
3602            sum_sgodl=sum_sgodl+sgodl
3603
3604 c            sgodl2=sgodl2+sgodl
3605 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3606 c      write(iout,*) "constr_homology=",constr_homology
3607 c      write(iout,*) i, j, k, "TEST K"
3608          enddo
3609          if (waga_dist.ge.0.0d0) then
3610 c
3611 c          For Gaussian-type Urestr
3612 c
3613             grad_odl3=waga_homology(iset)*waga_dist
3614      &                *sum_sgodl/(sum_godl*dij)
3615 c
3616 c          For Lorentzian-type Urestr
3617 c
3618          else
3619 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3620 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3621             grad_odl3=-waga_homology(iset)*waga_dist*
3622      &                sum_sgodl/(constr_homology*dij)
3623          endif
3624 c
3625 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3626
3627
3628 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3629 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3630 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3631
3632 ccc      write(iout,*) godl, sgodl, grad_odl3
3633
3634 c          grad_odl=grad_odl+grad_odl3
3635
3636          do jik=1,3
3637             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3638 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3639 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3640 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3641             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3642             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3643 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3644 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3645 c         if (i.eq.25.and.j.eq.27) then
3646 c         write(iout,*) "jik",jik,"i",i,"j",j
3647 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3648 c         write(iout,*) "grad_odl3",grad_odl3
3649 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3650 c         write(iout,*) "ggodl",ggodl
3651 c         write(iout,*) "ghpbc(",jik,i,")",
3652 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3653 c     &                 ghpbc(jik,j)
3654 c         endif
3655          enddo
3656 #endif
3657 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3658 ccc     & dLOG(odleg2),"-odleg=", -odleg
3659
3660       enddo ! ii-loop for dist
3661 #ifdef DEBUG
3662       write(iout,*) "------- dist restrs end -------"
3663 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3664 c    &     waga_d.eq.1.0d0) call sum_gradient
3665 #endif
3666 c Pseudo-energy and gradient from dihedral-angle restraints from
3667 c homology templates
3668 c      write (iout,*) "End of distance loop"
3669 c      call flush(iout)
3670       kat=0.0d0
3671 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3672 #ifdef DEBUG
3673       write(iout,*) "------- dih restrs start -------"
3674       do i=idihconstr_start_homo,idihconstr_end_homo
3675         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3676       enddo
3677 #endif
3678       do i=idihconstr_start_homo,idihconstr_end_homo
3679         kat2=0.0d0
3680 c        betai=beta(i,i+1,i+2,i+3)
3681         betai = phi(i)
3682 c       write (iout,*) "betai =",betai
3683         do k=1,constr_homology
3684           dih_diff(k)=pinorm(dih(k,i)-betai)
3685 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3686 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3687 c     &                                   -(6.28318-dih_diff(i,k))
3688 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3689 c     &                                   6.28318+dih_diff(i,k)
3690 #ifdef OLD_DIHED
3691           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3692 #else
3693           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3694 #endif
3695 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3696           gdih(k)=dexp(kat3)
3697           kat2=kat2+gdih(k)
3698 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3699 c          write(*,*)""
3700         enddo
3701 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3702 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3703 #ifdef DEBUG
3704         write (iout,*) "i",i," betai",betai," kat2",kat2
3705         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3706 #endif
3707         if (kat2.le.1.0d-14) cycle
3708         kat=kat-dLOG(kat2/constr_homology)
3709 c       write (iout,*) "kat",kat ! sum of -ln-s
3710
3711 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3712 ccc     & dLOG(kat2), "-kat=", -kat
3713
3714 #ifdef GRAD
3715 c ----------------------------------------------------------------------
3716 c Gradient
3717 c ----------------------------------------------------------------------
3718
3719         sum_gdih=kat2
3720         sum_sgdih=0.0d0
3721         do k=1,constr_homology
3722 #ifdef OLD_DIHED
3723           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3724 #else
3725           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3726 #endif
3727 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3728           sum_sgdih=sum_sgdih+sgdih
3729         enddo
3730 c       grad_dih3=sum_sgdih/sum_gdih
3731         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3732
3733 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3734 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3735 ccc     & gloc(nphi+i-3,icg)
3736         gloc(i,icg)=gloc(i,icg)+grad_dih3
3737 c        if (i.eq.25) then
3738 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3739 c        endif
3740 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3741 ccc     & gloc(nphi+i-3,icg)
3742 #endif
3743       enddo ! i-loop for dih
3744 #ifdef DEBUG
3745       write(iout,*) "------- dih restrs end -------"
3746 #endif
3747
3748 c Pseudo-energy and gradient for theta angle restraints from
3749 c homology templates
3750 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3751 c adapted
3752
3753 c
3754 c     For constr_homology reference structures (FP)
3755 c
3756 c     Uconst_back_tot=0.0d0
3757       Eval=0.0d0
3758       Erot=0.0d0
3759 c     Econstr_back legacy
3760 #ifdef GRAD
3761       do i=1,nres
3762 c     do i=ithet_start,ithet_end
3763        dutheta(i)=0.0d0
3764 c     enddo
3765 c     do i=loc_start,loc_end
3766         do j=1,3
3767           duscdiff(j,i)=0.0d0
3768           duscdiffx(j,i)=0.0d0
3769         enddo
3770       enddo
3771 #endif
3772 c
3773 c     do iref=1,nref
3774 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3775 c     write (iout,*) "waga_theta",waga_theta
3776       if (waga_theta.gt.0.0d0) then
3777 #ifdef DEBUG
3778       write (iout,*) "usampl",usampl
3779       write(iout,*) "------- theta restrs start -------"
3780 c     do i=ithet_start,ithet_end
3781 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3782 c     enddo
3783 #endif
3784 c     write (iout,*) "maxres",maxres,"nres",nres
3785
3786       do i=ithet_start,ithet_end
3787 c
3788 c     do i=1,nfrag_back
3789 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3790 c
3791 c Deviation of theta angles wrt constr_homology ref structures
3792 c
3793         utheta_i=0.0d0 ! argument of Gaussian for single k
3794         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3795 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3796 c       over residues in a fragment
3797 c       write (iout,*) "theta(",i,")=",theta(i)
3798         do k=1,constr_homology
3799 c
3800 c         dtheta_i=theta(j)-thetaref(j,iref)
3801 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3802           theta_diff(k)=thetatpl(k,i)-theta(i)
3803 c
3804           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3805 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3806           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3807           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3808 c         Gradient for single Gaussian restraint in subr Econstr_back
3809 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3810 c
3811         enddo
3812 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3813 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3814
3815 c
3816 #ifdef GRAD
3817 c         Gradient for multiple Gaussian restraint
3818         sum_gtheta=gutheta_i
3819         sum_sgtheta=0.0d0
3820         do k=1,constr_homology
3821 c        New generalized expr for multiple Gaussian from Econstr_back
3822          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3823 c
3824 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3825           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3826         enddo
3827 c
3828 c       Final value of gradient using same var as in Econstr_back
3829         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3830      &               *waga_homology(iset)
3831 c       dutheta(i)=sum_sgtheta/sum_gtheta
3832 c
3833 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3834 #endif
3835         Eval=Eval-dLOG(gutheta_i/constr_homology)
3836 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3837 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3838 c       Uconst_back=Uconst_back+utheta(i)
3839       enddo ! (i-loop for theta)
3840 #ifdef DEBUG
3841       write(iout,*) "------- theta restrs end -------"
3842 #endif
3843       endif
3844 c
3845 c Deviation of local SC geometry
3846 c
3847 c Separation of two i-loops (instructed by AL - 11/3/2014)
3848 c
3849 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3850 c     write (iout,*) "waga_d",waga_d
3851
3852 #ifdef DEBUG
3853       write(iout,*) "------- SC restrs start -------"
3854       write (iout,*) "Initial duscdiff,duscdiffx"
3855       do i=loc_start,loc_end
3856         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3857      &                 (duscdiffx(jik,i),jik=1,3)
3858       enddo
3859 #endif
3860       do i=loc_start,loc_end
3861         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3862         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3863 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3864 c       write(iout,*) "xxtab, yytab, zztab"
3865 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3866         do k=1,constr_homology
3867 c
3868           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3869 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3870           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3871           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3872 c         write(iout,*) "dxx, dyy, dzz"
3873 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3874 c
3875           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3876 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3877 c         uscdiffk(k)=usc_diff(i)
3878           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3879           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3880 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3881 c     &      xxref(j),yyref(j),zzref(j)
3882         enddo
3883 c
3884 c       Gradient
3885 c
3886 c       Generalized expression for multiple Gaussian acc to that for a single
3887 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3888 c
3889 c       Original implementation
3890 c       sum_guscdiff=guscdiff(i)
3891 c
3892 c       sum_sguscdiff=0.0d0
3893 c       do k=1,constr_homology
3894 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3895 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3896 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3897 c       enddo
3898 c
3899 c       Implementation of new expressions for gradient (Jan. 2015)
3900 c
3901 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3902 #ifdef GRAD
3903         do k=1,constr_homology
3904 c
3905 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3906 c       before. Now the drivatives should be correct
3907 c
3908           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3909 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3910           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3911           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3912 c
3913 c         New implementation
3914 c
3915           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3916      &                 sigma_d(k,i) ! for the grad wrt r'
3917 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3918 c
3919 c
3920 c        New implementation
3921          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3922          do jik=1,3
3923             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3924      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3925      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3926             duscdiff(jik,i)=duscdiff(jik,i)+
3927      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3928      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3929             duscdiffx(jik,i)=duscdiffx(jik,i)+
3930      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3931      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3932 c
3933 #ifdef DEBUG
3934              write(iout,*) "jik",jik,"i",i
3935              write(iout,*) "dxx, dyy, dzz"
3936              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3937              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3938 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3939 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3940 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3941 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3942 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3943 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3944 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3945 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3946 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3947 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3948 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3949 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3950 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3951 c            endif
3952 #endif
3953          enddo
3954         enddo
3955 #endif
3956 c
3957 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3958 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3959 c
3960 c        write (iout,*) i," uscdiff",uscdiff(i)
3961 c
3962 c Put together deviations from local geometry
3963
3964 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3965 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3966         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3967 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3968 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3969 c       Uconst_back=Uconst_back+usc_diff(i)
3970 c
3971 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3972 c
3973 c     New implment: multiplied by sum_sguscdiff
3974 c
3975
3976       enddo ! (i-loop for dscdiff)
3977
3978 c      endif
3979
3980 #ifdef DEBUG
3981       write(iout,*) "------- SC restrs end -------"
3982         write (iout,*) "------ After SC loop in e_modeller ------"
3983         do i=loc_start,loc_end
3984          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3985          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3986         enddo
3987       if (waga_theta.eq.1.0d0) then
3988       write (iout,*) "in e_modeller after SC restr end: dutheta"
3989       do i=ithet_start,ithet_end
3990         write (iout,*) i,dutheta(i)
3991       enddo
3992       endif
3993       if (waga_d.eq.1.0d0) then
3994       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3995       do i=1,nres
3996         write (iout,*) i,(duscdiff(j,i),j=1,3)
3997         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3998       enddo
3999       endif
4000 #endif
4001
4002 c Total energy from homology restraints
4003 #ifdef DEBUG
4004       write (iout,*) "odleg",odleg," kat",kat
4005       write (iout,*) "odleg",odleg," kat",kat
4006       write (iout,*) "Eval",Eval," Erot",Erot
4007       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4008       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4009       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4010 #endif
4011 c
4012 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4013 c
4014 c     ehomology_constr=odleg+kat
4015 c
4016 c     For Lorentzian-type Urestr
4017 c
4018
4019       if (waga_dist.ge.0.0d0) then
4020 c
4021 c          For Gaussian-type Urestr
4022 c
4023 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4024 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4025         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4026      &              waga_theta*Eval+waga_d*Erot
4027 c     write (iout,*) "ehomology_constr=",ehomology_constr
4028       else
4029 c
4030 c          For Lorentzian-type Urestr
4031 c
4032 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4033 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4034         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4035      &              waga_theta*Eval+waga_d*Erot
4036 c     write (iout,*) "ehomology_constr=",ehomology_constr
4037       endif
4038 #ifdef DEBUG
4039       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4040      & "Eval",waga_theta,eval,
4041      &   "Erot",waga_d,Erot
4042       write (iout,*) "ehomology_constr",ehomology_constr
4043 #endif
4044       return
4045
4046   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4047   747 format(a12,i4,i4,i4,f8.3,f8.3)
4048   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4049   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4050   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4051      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4052       end
4053 c-----------------------------------------------------------------------
4054       subroutine ebond(estr)
4055 c
4056 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4057 c
4058       implicit real*8 (a-h,o-z)
4059       include 'DIMENSIONS'
4060       include 'DIMENSIONS.ZSCOPT'
4061       include 'DIMENSIONS.FREE'
4062       include 'COMMON.LOCAL'
4063       include 'COMMON.GEO'
4064       include 'COMMON.INTERACT'
4065       include 'COMMON.DERIV'
4066       include 'COMMON.VAR'
4067       include 'COMMON.CHAIN'
4068       include 'COMMON.IOUNITS'
4069       include 'COMMON.NAMES'
4070       include 'COMMON.FFIELD'
4071       include 'COMMON.CONTROL'
4072       logical energy_dec /.false./
4073       double precision u(3),ud(3)
4074       estr=0.0d0
4075 C      write (iout,*) "distchainmax",distchainmax
4076       estr1=0.0d0
4077 c      write (iout,*) "distchainmax",distchainmax
4078       do i=nnt+1,nct
4079         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4080 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4081 C          do j=1,3
4082 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4083 C     &      *dc(j,i-1)/vbld(i)
4084 C          enddo
4085 C          if (energy_dec) write(iout,*)
4086 C     &       "estr1",i,vbld(i),distchainmax,
4087 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4088 C        else
4089          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4090         diff = vbld(i)-vbldpDUM
4091 C         write(iout,*) i,diff
4092          else
4093           diff = vbld(i)-vbldp0
4094 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4095          endif
4096           estr=estr+diff*diff
4097           do j=1,3
4098             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4099           enddo
4100 C        endif
4101 C        write (iout,'(a7,i5,4f7.3)')
4102 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4103       enddo
4104       estr=0.5d0*AKP*estr+estr1
4105 c
4106 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4107 c
4108       do i=nnt,nct
4109         iti=iabs(itype(i))
4110         if (iti.ne.10 .and. iti.ne.ntyp1) then
4111           nbi=nbondterm(iti)
4112           if (nbi.eq.1) then
4113             diff=vbld(i+nres)-vbldsc0(1,iti)
4114 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4115 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4116             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4117             do j=1,3
4118               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4119             enddo
4120           else
4121             do j=1,nbi
4122               diff=vbld(i+nres)-vbldsc0(j,iti)
4123               ud(j)=aksc(j,iti)*diff
4124               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4125             enddo
4126             uprod=u(1)
4127             do j=2,nbi
4128               uprod=uprod*u(j)
4129             enddo
4130             usum=0.0d0
4131             usumsqder=0.0d0
4132             do j=1,nbi
4133               uprod1=1.0d0
4134               uprod2=1.0d0
4135               do k=1,nbi
4136                 if (k.ne.j) then
4137                   uprod1=uprod1*u(k)
4138                   uprod2=uprod2*u(k)*u(k)
4139                 endif
4140               enddo
4141               usum=usum+uprod1
4142               usumsqder=usumsqder+ud(j)*uprod2
4143             enddo
4144 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4145 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4146             estr=estr+uprod/usum
4147             do j=1,3
4148              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4149             enddo
4150           endif
4151         endif
4152       enddo
4153       return
4154       end
4155 #ifdef CRYST_THETA
4156 C--------------------------------------------------------------------------
4157       subroutine ebend(etheta)
4158 C
4159 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4160 C angles gamma and its derivatives in consecutive thetas and gammas.
4161 C
4162       implicit real*8 (a-h,o-z)
4163       include 'DIMENSIONS'
4164       include 'DIMENSIONS.ZSCOPT'
4165       include 'COMMON.LOCAL'
4166       include 'COMMON.GEO'
4167       include 'COMMON.INTERACT'
4168       include 'COMMON.DERIV'
4169       include 'COMMON.VAR'
4170       include 'COMMON.CHAIN'
4171       include 'COMMON.IOUNITS'
4172       include 'COMMON.NAMES'
4173       include 'COMMON.FFIELD'
4174       common /calcthet/ term1,term2,termm,diffak,ratak,
4175      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4176      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4177       double precision y(2),z(2)
4178       delta=0.02d0*pi
4179       time11=dexp(-2*time)
4180       time12=1.0d0
4181       etheta=0.0D0
4182 c      write (iout,*) "nres",nres
4183 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4184 c      write (iout,*) ithet_start,ithet_end
4185       do i=ithet_start,ithet_end
4186 C        if (itype(i-1).eq.ntyp1) cycle
4187 c        if (i.le.2) cycle
4188         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4189      &  .or.itype(i).eq.ntyp1) cycle
4190 C Zero the energy function and its derivative at 0 or pi.
4191         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4192         it=itype(i-1)
4193         ichir1=isign(1,itype(i-2))
4194         ichir2=isign(1,itype(i))
4195          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4196          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4197          if (itype(i-1).eq.10) then
4198           itype1=isign(10,itype(i-2))
4199           ichir11=isign(1,itype(i-2))
4200           ichir12=isign(1,itype(i-2))
4201           itype2=isign(10,itype(i))
4202           ichir21=isign(1,itype(i))
4203           ichir22=isign(1,itype(i))
4204          endif
4205          if (i.eq.3) then
4206           y(1)=0.0D0
4207           y(2)=0.0D0
4208           else
4209
4210         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4211 #ifdef OSF
4212           phii=phi(i)
4213 c          icrc=0
4214 c          call proc_proc(phii,icrc)
4215           if (icrc.eq.1) phii=150.0
4216 #else
4217           phii=phi(i)
4218 #endif
4219           y(1)=dcos(phii)
4220           y(2)=dsin(phii)
4221         else
4222           y(1)=0.0D0
4223           y(2)=0.0D0
4224         endif
4225         endif
4226         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4227 #ifdef OSF
4228           phii1=phi(i+1)
4229 c          icrc=0
4230 c          call proc_proc(phii1,icrc)
4231           if (icrc.eq.1) phii1=150.0
4232           phii1=pinorm(phii1)
4233           z(1)=cos(phii1)
4234 #else
4235           phii1=phi(i+1)
4236           z(1)=dcos(phii1)
4237 #endif
4238           z(2)=dsin(phii1)
4239         else
4240           z(1)=0.0D0
4241           z(2)=0.0D0
4242         endif
4243 C Calculate the "mean" value of theta from the part of the distribution
4244 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4245 C In following comments this theta will be referred to as t_c.
4246         thet_pred_mean=0.0d0
4247         do k=1,2
4248             athetk=athet(k,it,ichir1,ichir2)
4249             bthetk=bthet(k,it,ichir1,ichir2)
4250           if (it.eq.10) then
4251              athetk=athet(k,itype1,ichir11,ichir12)
4252              bthetk=bthet(k,itype2,ichir21,ichir22)
4253           endif
4254           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4255         enddo
4256 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4257         dthett=thet_pred_mean*ssd
4258         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4259 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4260 C Derivatives of the "mean" values in gamma1 and gamma2.
4261         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4262      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4263          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4264      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4265          if (it.eq.10) then
4266       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4267      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4268         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4269      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4270          endif
4271         if (theta(i).gt.pi-delta) then
4272           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4273      &         E_tc0)
4274           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4275           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4276           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4277      &        E_theta)
4278           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4279      &        E_tc)
4280         else if (theta(i).lt.delta) then
4281           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4282           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4283           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4284      &        E_theta)
4285           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4286           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4287      &        E_tc)
4288         else
4289           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4290      &        E_theta,E_tc)
4291         endif
4292         etheta=etheta+ethetai
4293 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4294 c     &      'ebend',i,ethetai,theta(i),itype(i)
4295 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4296 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4297         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4298         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4299         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4300 c 1215   continue
4301       enddo
4302       ethetacnstr=0.0d0
4303 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4304       do i=1,ntheta_constr
4305         itheta=itheta_constr(i)
4306         thetiii=theta(itheta)
4307         difi=pinorm(thetiii-theta_constr0(i))
4308         if (difi.gt.theta_drange(i)) then
4309           difi=difi-theta_drange(i)
4310           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4311           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4312      &    +for_thet_constr(i)*difi**3
4313         else if (difi.lt.-drange(i)) then
4314           difi=difi+drange(i)
4315           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4316           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4317      &    +for_thet_constr(i)*difi**3
4318         else
4319           difi=0.0
4320         endif
4321 C       if (energy_dec) then
4322 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4323 C     &    i,itheta,rad2deg*thetiii,
4324 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4325 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4326 C     &    gloc(itheta+nphi-2,icg)
4327 C        endif
4328       enddo
4329 C Ufff.... We've done all this!!!
4330       return
4331       end
4332 C---------------------------------------------------------------------------
4333       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4334      &     E_tc)
4335       implicit real*8 (a-h,o-z)
4336       include 'DIMENSIONS'
4337       include 'COMMON.LOCAL'
4338       include 'COMMON.IOUNITS'
4339       common /calcthet/ term1,term2,termm,diffak,ratak,
4340      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4341      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4342 C Calculate the contributions to both Gaussian lobes.
4343 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4344 C The "polynomial part" of the "standard deviation" of this part of
4345 C the distribution.
4346         sig=polthet(3,it)
4347         do j=2,0,-1
4348           sig=sig*thet_pred_mean+polthet(j,it)
4349         enddo
4350 C Derivative of the "interior part" of the "standard deviation of the"
4351 C gamma-dependent Gaussian lobe in t_c.
4352         sigtc=3*polthet(3,it)
4353         do j=2,1,-1
4354           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4355         enddo
4356         sigtc=sig*sigtc
4357 C Set the parameters of both Gaussian lobes of the distribution.
4358 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4359         fac=sig*sig+sigc0(it)
4360         sigcsq=fac+fac
4361         sigc=1.0D0/sigcsq
4362 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4363         sigsqtc=-4.0D0*sigcsq*sigtc
4364 c       print *,i,sig,sigtc,sigsqtc
4365 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4366         sigtc=-sigtc/(fac*fac)
4367 C Following variable is sigma(t_c)**(-2)
4368         sigcsq=sigcsq*sigcsq
4369         sig0i=sig0(it)
4370         sig0inv=1.0D0/sig0i**2
4371         delthec=thetai-thet_pred_mean
4372         delthe0=thetai-theta0i
4373         term1=-0.5D0*sigcsq*delthec*delthec
4374         term2=-0.5D0*sig0inv*delthe0*delthe0
4375 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4376 C NaNs in taking the logarithm. We extract the largest exponent which is added
4377 C to the energy (this being the log of the distribution) at the end of energy
4378 C term evaluation for this virtual-bond angle.
4379         if (term1.gt.term2) then
4380           termm=term1
4381           term2=dexp(term2-termm)
4382           term1=1.0d0
4383         else
4384           termm=term2
4385           term1=dexp(term1-termm)
4386           term2=1.0d0
4387         endif
4388 C The ratio between the gamma-independent and gamma-dependent lobes of
4389 C the distribution is a Gaussian function of thet_pred_mean too.
4390         diffak=gthet(2,it)-thet_pred_mean
4391         ratak=diffak/gthet(3,it)**2
4392         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4393 C Let's differentiate it in thet_pred_mean NOW.
4394         aktc=ak*ratak
4395 C Now put together the distribution terms to make complete distribution.
4396         termexp=term1+ak*term2
4397         termpre=sigc+ak*sig0i
4398 C Contribution of the bending energy from this theta is just the -log of
4399 C the sum of the contributions from the two lobes and the pre-exponential
4400 C factor. Simple enough, isn't it?
4401         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4402 C NOW the derivatives!!!
4403 C 6/6/97 Take into account the deformation.
4404         E_theta=(delthec*sigcsq*term1
4405      &       +ak*delthe0*sig0inv*term2)/termexp
4406         E_tc=((sigtc+aktc*sig0i)/termpre
4407      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4408      &       aktc*term2)/termexp)
4409       return
4410       end
4411 c-----------------------------------------------------------------------------
4412       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4413       implicit real*8 (a-h,o-z)
4414       include 'DIMENSIONS'
4415       include 'COMMON.LOCAL'
4416       include 'COMMON.IOUNITS'
4417       common /calcthet/ term1,term2,termm,diffak,ratak,
4418      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4419      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4420       delthec=thetai-thet_pred_mean
4421       delthe0=thetai-theta0i
4422 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4423       t3 = thetai-thet_pred_mean
4424       t6 = t3**2
4425       t9 = term1
4426       t12 = t3*sigcsq
4427       t14 = t12+t6*sigsqtc
4428       t16 = 1.0d0
4429       t21 = thetai-theta0i
4430       t23 = t21**2
4431       t26 = term2
4432       t27 = t21*t26
4433       t32 = termexp
4434       t40 = t32**2
4435       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4436      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4437      & *(-t12*t9-ak*sig0inv*t27)
4438       return
4439       end
4440 #else
4441 C--------------------------------------------------------------------------
4442       subroutine ebend(etheta)
4443 C
4444 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4445 C angles gamma and its derivatives in consecutive thetas and gammas.
4446 C ab initio-derived potentials from
4447 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4448 C
4449       implicit real*8 (a-h,o-z)
4450       include 'DIMENSIONS'
4451       include 'DIMENSIONS.ZSCOPT'
4452       include 'DIMENSIONS.FREE'
4453       include 'COMMON.LOCAL'
4454       include 'COMMON.GEO'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.DERIV'
4457       include 'COMMON.VAR'
4458       include 'COMMON.CHAIN'
4459       include 'COMMON.IOUNITS'
4460       include 'COMMON.NAMES'
4461       include 'COMMON.FFIELD'
4462       include 'COMMON.CONTROL'
4463       include 'COMMON.TORCNSTR'
4464       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4465      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4466      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4467      & sinph1ph2(maxdouble,maxdouble)
4468       logical lprn /.false./, lprn1 /.false./
4469       etheta=0.0D0
4470 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4471       do i=ithet_start,ithet_end
4472 c        if (i.eq.2) cycle
4473 c        print *,i,itype(i-1),itype(i),itype(i-2)
4474         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4475      &  .or.(itype(i).eq.ntyp1)) cycle
4476 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4477
4478         if (iabs(itype(i+1)).eq.20) iblock=2
4479         if (iabs(itype(i+1)).ne.20) iblock=1
4480         dethetai=0.0d0
4481         dephii=0.0d0
4482         dephii1=0.0d0
4483         theti2=0.5d0*theta(i)
4484         ityp2=ithetyp((itype(i-1)))
4485         do k=1,nntheterm
4486           coskt(k)=dcos(k*theti2)
4487           sinkt(k)=dsin(k*theti2)
4488         enddo
4489         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4490 #ifdef OSF
4491           phii=phi(i)
4492           if (phii.ne.phii) phii=150.0
4493 #else
4494           phii=phi(i)
4495 #endif
4496           ityp1=ithetyp((itype(i-2)))
4497           do k=1,nsingle
4498             cosph1(k)=dcos(k*phii)
4499             sinph1(k)=dsin(k*phii)
4500           enddo
4501         else
4502           phii=0.0d0
4503           ityp1=ithetyp(itype(i-2))
4504           do k=1,nsingle
4505             cosph1(k)=0.0d0
4506             sinph1(k)=0.0d0
4507           enddo
4508         endif
4509         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4510 #ifdef OSF
4511           phii1=phi(i+1)
4512           if (phii1.ne.phii1) phii1=150.0
4513           phii1=pinorm(phii1)
4514 #else
4515           phii1=phi(i+1)
4516 #endif
4517           ityp3=ithetyp((itype(i)))
4518           do k=1,nsingle
4519             cosph2(k)=dcos(k*phii1)
4520             sinph2(k)=dsin(k*phii1)
4521           enddo
4522         else
4523           phii1=0.0d0
4524           ityp3=ithetyp(itype(i))
4525           do k=1,nsingle
4526             cosph2(k)=0.0d0
4527             sinph2(k)=0.0d0
4528           enddo
4529         endif
4530 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4531 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4532 c        call flush(iout)
4533         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4534         do k=1,ndouble
4535           do l=1,k-1
4536             ccl=cosph1(l)*cosph2(k-l)
4537             ssl=sinph1(l)*sinph2(k-l)
4538             scl=sinph1(l)*cosph2(k-l)
4539             csl=cosph1(l)*sinph2(k-l)
4540             cosph1ph2(l,k)=ccl-ssl
4541             cosph1ph2(k,l)=ccl+ssl
4542             sinph1ph2(l,k)=scl+csl
4543             sinph1ph2(k,l)=scl-csl
4544           enddo
4545         enddo
4546         if (lprn) then
4547         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4548      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4549         write (iout,*) "coskt and sinkt"
4550         do k=1,nntheterm
4551           write (iout,*) k,coskt(k),sinkt(k)
4552         enddo
4553         endif
4554         do k=1,ntheterm
4555           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4556           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4557      &      *coskt(k)
4558           if (lprn)
4559      &    write (iout,*) "k",k,"
4560      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4561      &     " ethetai",ethetai
4562         enddo
4563         if (lprn) then
4564         write (iout,*) "cosph and sinph"
4565         do k=1,nsingle
4566           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4567         enddo
4568         write (iout,*) "cosph1ph2 and sinph2ph2"
4569         do k=2,ndouble
4570           do l=1,k-1
4571             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4572      &         sinph1ph2(l,k),sinph1ph2(k,l)
4573           enddo
4574         enddo
4575         write(iout,*) "ethetai",ethetai
4576         endif
4577         do m=1,ntheterm2
4578           do k=1,nsingle
4579             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4580      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4581      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4582      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4583             ethetai=ethetai+sinkt(m)*aux
4584             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4585             dephii=dephii+k*sinkt(m)*(
4586      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4587      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4588             dephii1=dephii1+k*sinkt(m)*(
4589      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4590      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4591             if (lprn)
4592      &      write (iout,*) "m",m," k",k," bbthet",
4593      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4594      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4595      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4596      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4597           enddo
4598         enddo
4599         if (lprn)
4600      &  write(iout,*) "ethetai",ethetai
4601         do m=1,ntheterm3
4602           do k=2,ndouble
4603             do l=1,k-1
4604               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4605      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4606      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4607      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4608               ethetai=ethetai+sinkt(m)*aux
4609               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4610               dephii=dephii+l*sinkt(m)*(
4611      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4612      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4613      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4614      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4615               dephii1=dephii1+(k-l)*sinkt(m)*(
4616      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4617      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4618      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4619      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4620               if (lprn) then
4621               write (iout,*) "m",m," k",k," l",l," ffthet",
4622      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4623      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4624      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4625      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4626      &            " ethetai",ethetai
4627               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4628      &            cosph1ph2(k,l)*sinkt(m),
4629      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4630               endif
4631             enddo
4632           enddo
4633         enddo
4634 10      continue
4635         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4636      &   i,theta(i)*rad2deg,phii*rad2deg,
4637      &   phii1*rad2deg,ethetai
4638         etheta=etheta+ethetai
4639         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4640         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4641 c        gloc(nphi+i-2,icg)=wang*dethetai
4642         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4643       enddo
4644 C now constrains
4645       ethetacnstr=0.0d0
4646 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4647       do i=1,ntheta_constr
4648         itheta=itheta_constr(i)
4649         thetiii=theta(itheta)
4650         difi=pinorm(thetiii-theta_constr0(i))
4651         if (difi.gt.theta_drange(i)) then
4652           difi=difi-theta_drange(i)
4653           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4654           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4655      &    +for_thet_constr(i)*difi**3
4656         else if (difi.lt.-drange(i)) then
4657           difi=difi+drange(i)
4658           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4659           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4660      &    +for_thet_constr(i)*difi**3
4661         else
4662           difi=0.0
4663         endif
4664 C       if (energy_dec) then
4665 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4666 C     &    i,itheta,rad2deg*thetiii,
4667 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4668 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4669 C     &    gloc(itheta+nphi-2,icg)
4670 C        endif
4671       enddo
4672       return
4673       end
4674
4675 #endif
4676 #ifdef CRYST_SC
4677 c-----------------------------------------------------------------------------
4678       subroutine esc(escloc)
4679 C Calculate the local energy of a side chain and its derivatives in the
4680 C corresponding virtual-bond valence angles THETA and the spherical angles
4681 C ALPHA and OMEGA.
4682       implicit real*8 (a-h,o-z)
4683       include 'DIMENSIONS'
4684       include 'DIMENSIONS.ZSCOPT'
4685       include 'COMMON.GEO'
4686       include 'COMMON.LOCAL'
4687       include 'COMMON.VAR'
4688       include 'COMMON.INTERACT'
4689       include 'COMMON.DERIV'
4690       include 'COMMON.CHAIN'
4691       include 'COMMON.IOUNITS'
4692       include 'COMMON.NAMES'
4693       include 'COMMON.FFIELD'
4694       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4695      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4696       common /sccalc/ time11,time12,time112,theti,it,nlobit
4697       delta=0.02d0*pi
4698       escloc=0.0D0
4699 C      write (iout,*) 'ESC'
4700       do i=loc_start,loc_end
4701         it=itype(i)
4702         if (it.eq.ntyp1) cycle
4703         if (it.eq.10) goto 1
4704         nlobit=nlob(iabs(it))
4705 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4706 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4707         theti=theta(i+1)-pipol
4708         x(1)=dtan(theti)
4709         x(2)=alph(i)
4710         x(3)=omeg(i)
4711 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4712
4713         if (x(2).gt.pi-delta) then
4714           xtemp(1)=x(1)
4715           xtemp(2)=pi-delta
4716           xtemp(3)=x(3)
4717           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4718           xtemp(2)=pi
4719           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4720           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4721      &        escloci,dersc(2))
4722           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4723      &        ddersc0(1),dersc(1))
4724           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4725      &        ddersc0(3),dersc(3))
4726           xtemp(2)=pi-delta
4727           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4728           xtemp(2)=pi
4729           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4730           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4731      &            dersc0(2),esclocbi,dersc02)
4732           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4733      &            dersc12,dersc01)
4734           call splinthet(x(2),0.5d0*delta,ss,ssd)
4735           dersc0(1)=dersc01
4736           dersc0(2)=dersc02
4737           dersc0(3)=0.0d0
4738           do k=1,3
4739             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4740           enddo
4741           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4742           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4743      &             esclocbi,ss,ssd
4744           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4745 c         escloci=esclocbi
4746 c         write (iout,*) escloci
4747         else if (x(2).lt.delta) then
4748           xtemp(1)=x(1)
4749           xtemp(2)=delta
4750           xtemp(3)=x(3)
4751           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4752           xtemp(2)=0.0d0
4753           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4754           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4755      &        escloci,dersc(2))
4756           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4757      &        ddersc0(1),dersc(1))
4758           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4759      &        ddersc0(3),dersc(3))
4760           xtemp(2)=delta
4761           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4762           xtemp(2)=0.0d0
4763           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4764           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4765      &            dersc0(2),esclocbi,dersc02)
4766           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4767      &            dersc12,dersc01)
4768           dersc0(1)=dersc01
4769           dersc0(2)=dersc02
4770           dersc0(3)=0.0d0
4771           call splinthet(x(2),0.5d0*delta,ss,ssd)
4772           do k=1,3
4773             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4774           enddo
4775           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4776 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4777 c     &             esclocbi,ss,ssd
4778           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4779 C         write (iout,*) 'i=',i, escloci
4780         else
4781           call enesc(x,escloci,dersc,ddummy,.false.)
4782         endif
4783
4784         escloc=escloc+escloci
4785 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4786             write (iout,'(a6,i5,0pf7.3)')
4787      &     'escloc',i,escloci
4788
4789         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4790      &   wscloc*dersc(1)
4791         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4792         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4793     1   continue
4794       enddo
4795       return
4796       end
4797 C---------------------------------------------------------------------------
4798       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4799       implicit real*8 (a-h,o-z)
4800       include 'DIMENSIONS'
4801       include 'COMMON.GEO'
4802       include 'COMMON.LOCAL'
4803       include 'COMMON.IOUNITS'
4804       common /sccalc/ time11,time12,time112,theti,it,nlobit
4805       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4806       double precision contr(maxlob,-1:1)
4807       logical mixed
4808 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4809         escloc_i=0.0D0
4810         do j=1,3
4811           dersc(j)=0.0D0
4812           if (mixed) ddersc(j)=0.0d0
4813         enddo
4814         x3=x(3)
4815
4816 C Because of periodicity of the dependence of the SC energy in omega we have
4817 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4818 C To avoid underflows, first compute & store the exponents.
4819
4820         do iii=-1,1
4821
4822           x(3)=x3+iii*dwapi
4823
4824           do j=1,nlobit
4825             do k=1,3
4826               z(k)=x(k)-censc(k,j,it)
4827             enddo
4828             do k=1,3
4829               Axk=0.0D0
4830               do l=1,3
4831                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4832               enddo
4833               Ax(k,j,iii)=Axk
4834             enddo
4835             expfac=0.0D0
4836             do k=1,3
4837               expfac=expfac+Ax(k,j,iii)*z(k)
4838             enddo
4839             contr(j,iii)=expfac
4840           enddo ! j
4841
4842         enddo ! iii
4843
4844         x(3)=x3
4845 C As in the case of ebend, we want to avoid underflows in exponentiation and
4846 C subsequent NaNs and INFs in energy calculation.
4847 C Find the largest exponent
4848         emin=contr(1,-1)
4849         do iii=-1,1
4850           do j=1,nlobit
4851             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4852           enddo
4853         enddo
4854         emin=0.5D0*emin
4855 cd      print *,'it=',it,' emin=',emin
4856
4857 C Compute the contribution to SC energy and derivatives
4858         do iii=-1,1
4859
4860           do j=1,nlobit
4861             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4862 cd          print *,'j=',j,' expfac=',expfac
4863             escloc_i=escloc_i+expfac
4864             do k=1,3
4865               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4866             enddo
4867             if (mixed) then
4868               do k=1,3,2
4869                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4870      &            +gaussc(k,2,j,it))*expfac
4871               enddo
4872             endif
4873           enddo
4874
4875         enddo ! iii
4876
4877         dersc(1)=dersc(1)/cos(theti)**2
4878         ddersc(1)=ddersc(1)/cos(theti)**2
4879         ddersc(3)=ddersc(3)
4880
4881         escloci=-(dlog(escloc_i)-emin)
4882         do j=1,3
4883           dersc(j)=dersc(j)/escloc_i
4884         enddo
4885         if (mixed) then
4886           do j=1,3,2
4887             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4888           enddo
4889         endif
4890       return
4891       end
4892 C------------------------------------------------------------------------------
4893       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4894       implicit real*8 (a-h,o-z)
4895       include 'DIMENSIONS'
4896       include 'COMMON.GEO'
4897       include 'COMMON.LOCAL'
4898       include 'COMMON.IOUNITS'
4899       common /sccalc/ time11,time12,time112,theti,it,nlobit
4900       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4901       double precision contr(maxlob)
4902       logical mixed
4903
4904       escloc_i=0.0D0
4905
4906       do j=1,3
4907         dersc(j)=0.0D0
4908       enddo
4909
4910       do j=1,nlobit
4911         do k=1,2
4912           z(k)=x(k)-censc(k,j,it)
4913         enddo
4914         z(3)=dwapi
4915         do k=1,3
4916           Axk=0.0D0
4917           do l=1,3
4918             Axk=Axk+gaussc(l,k,j,it)*z(l)
4919           enddo
4920           Ax(k,j)=Axk
4921         enddo
4922         expfac=0.0D0
4923         do k=1,3
4924           expfac=expfac+Ax(k,j)*z(k)
4925         enddo
4926         contr(j)=expfac
4927       enddo ! j
4928
4929 C As in the case of ebend, we want to avoid underflows in exponentiation and
4930 C subsequent NaNs and INFs in energy calculation.
4931 C Find the largest exponent
4932       emin=contr(1)
4933       do j=1,nlobit
4934         if (emin.gt.contr(j)) emin=contr(j)
4935       enddo
4936       emin=0.5D0*emin
4937
4938 C Compute the contribution to SC energy and derivatives
4939
4940       dersc12=0.0d0
4941       do j=1,nlobit
4942         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4943         escloc_i=escloc_i+expfac
4944         do k=1,2
4945           dersc(k)=dersc(k)+Ax(k,j)*expfac
4946         enddo
4947         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4948      &            +gaussc(1,2,j,it))*expfac
4949         dersc(3)=0.0d0
4950       enddo
4951
4952       dersc(1)=dersc(1)/cos(theti)**2
4953       dersc12=dersc12/cos(theti)**2
4954       escloci=-(dlog(escloc_i)-emin)
4955       do j=1,2
4956         dersc(j)=dersc(j)/escloc_i
4957       enddo
4958       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4959       return
4960       end
4961 #else
4962 c----------------------------------------------------------------------------------
4963       subroutine esc(escloc)
4964 C Calculate the local energy of a side chain and its derivatives in the
4965 C corresponding virtual-bond valence angles THETA and the spherical angles
4966 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4967 C added by Urszula Kozlowska. 07/11/2007
4968 C
4969       implicit real*8 (a-h,o-z)
4970       include 'DIMENSIONS'
4971       include 'DIMENSIONS.ZSCOPT'
4972       include 'DIMENSIONS.FREE'
4973       include 'COMMON.GEO'
4974       include 'COMMON.LOCAL'
4975       include 'COMMON.VAR'
4976       include 'COMMON.SCROT'
4977       include 'COMMON.INTERACT'
4978       include 'COMMON.DERIV'
4979       include 'COMMON.CHAIN'
4980       include 'COMMON.IOUNITS'
4981       include 'COMMON.NAMES'
4982       include 'COMMON.FFIELD'
4983       include 'COMMON.CONTROL'
4984       include 'COMMON.VECTORS'
4985       double precision x_prime(3),y_prime(3),z_prime(3)
4986      &    , sumene,dsc_i,dp2_i,x(65),
4987      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4988      &    de_dxx,de_dyy,de_dzz,de_dt
4989       double precision s1_t,s1_6_t,s2_t,s2_6_t
4990       double precision
4991      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4992      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4993      & dt_dCi(3),dt_dCi1(3)
4994       common /sccalc/ time11,time12,time112,theti,it,nlobit
4995       delta=0.02d0*pi
4996       escloc=0.0D0
4997       do i=loc_start,loc_end
4998         if (itype(i).eq.ntyp1) cycle
4999         costtab(i+1) =dcos(theta(i+1))
5000         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5001         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5002         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5003         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5004         cosfac=dsqrt(cosfac2)
5005         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5006         sinfac=dsqrt(sinfac2)
5007         it=iabs(itype(i))
5008         if (it.eq.10) goto 1
5009 c
5010 C  Compute the axes of tghe local cartesian coordinates system; store in
5011 c   x_prime, y_prime and z_prime
5012 c
5013         do j=1,3
5014           x_prime(j) = 0.00
5015           y_prime(j) = 0.00
5016           z_prime(j) = 0.00
5017         enddo
5018 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5019 C     &   dc_norm(3,i+nres)
5020         do j = 1,3
5021           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5022           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5023         enddo
5024         do j = 1,3
5025           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5026         enddo
5027 c       write (2,*) "i",i
5028 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5029 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5030 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5031 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5032 c      & " xy",scalar(x_prime(1),y_prime(1)),
5033 c      & " xz",scalar(x_prime(1),z_prime(1)),
5034 c      & " yy",scalar(y_prime(1),y_prime(1)),
5035 c      & " yz",scalar(y_prime(1),z_prime(1)),
5036 c      & " zz",scalar(z_prime(1),z_prime(1))
5037 c
5038 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5039 C to local coordinate system. Store in xx, yy, zz.
5040 c
5041         xx=0.0d0
5042         yy=0.0d0
5043         zz=0.0d0
5044         do j = 1,3
5045           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5046           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5047           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5048         enddo
5049
5050         xxtab(i)=xx
5051         yytab(i)=yy
5052         zztab(i)=zz
5053 C
5054 C Compute the energy of the ith side cbain
5055 C
5056 c        write (2,*) "xx",xx," yy",yy," zz",zz
5057         it=iabs(itype(i))
5058         do j = 1,65
5059           x(j) = sc_parmin(j,it)
5060         enddo
5061 #ifdef CHECK_COORD
5062 Cc diagnostics - remove later
5063         xx1 = dcos(alph(2))
5064         yy1 = dsin(alph(2))*dcos(omeg(2))
5065         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5066         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5067      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5068      &    xx1,yy1,zz1
5069 C,"  --- ", xx_w,yy_w,zz_w
5070 c end diagnostics
5071 #endif
5072         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5073      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5074      &   + x(10)*yy*zz
5075         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5076      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5077      & + x(20)*yy*zz
5078         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5079      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5080      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5081      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5082      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5083      &  +x(40)*xx*yy*zz
5084         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5085      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5086      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5087      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5088      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5089      &  +x(60)*xx*yy*zz
5090         dsc_i   = 0.743d0+x(61)
5091         dp2_i   = 1.9d0+x(62)
5092         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5093      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5094         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5095      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5096         s1=(1+x(63))/(0.1d0 + dscp1)
5097         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5098         s2=(1+x(65))/(0.1d0 + dscp2)
5099         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5100         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5101      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5102 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5103 c     &   sumene4,
5104 c     &   dscp1,dscp2,sumene
5105 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5106         escloc = escloc + sumene
5107 c        write (2,*) "escloc",escloc
5108 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5109 c     &  zz,xx,yy
5110         if (.not. calc_grad) goto 1
5111 #ifdef DEBUG
5112 C
5113 C This section to check the numerical derivatives of the energy of ith side
5114 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5115 C #define DEBUG in the code to turn it on.
5116 C
5117         write (2,*) "sumene               =",sumene
5118         aincr=1.0d-7
5119         xxsave=xx
5120         xx=xx+aincr
5121         write (2,*) xx,yy,zz
5122         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5123         de_dxx_num=(sumenep-sumene)/aincr
5124         xx=xxsave
5125         write (2,*) "xx+ sumene from enesc=",sumenep
5126         yysave=yy
5127         yy=yy+aincr
5128         write (2,*) xx,yy,zz
5129         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5130         de_dyy_num=(sumenep-sumene)/aincr
5131         yy=yysave
5132         write (2,*) "yy+ sumene from enesc=",sumenep
5133         zzsave=zz
5134         zz=zz+aincr
5135         write (2,*) xx,yy,zz
5136         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5137         de_dzz_num=(sumenep-sumene)/aincr
5138         zz=zzsave
5139         write (2,*) "zz+ sumene from enesc=",sumenep
5140         costsave=cost2tab(i+1)
5141         sintsave=sint2tab(i+1)
5142         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5143         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5144         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5145         de_dt_num=(sumenep-sumene)/aincr
5146         write (2,*) " t+ sumene from enesc=",sumenep
5147         cost2tab(i+1)=costsave
5148         sint2tab(i+1)=sintsave
5149 C End of diagnostics section.
5150 #endif
5151 C
5152 C Compute the gradient of esc
5153 C
5154         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5155         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5156         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5157         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5158         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5159         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5160         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5161         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5162         pom1=(sumene3*sint2tab(i+1)+sumene1)
5163      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5164         pom2=(sumene4*cost2tab(i+1)+sumene2)
5165      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5166         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5167         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5168      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5169      &  +x(40)*yy*zz
5170         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5171         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5172      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5173      &  +x(60)*yy*zz
5174         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5175      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5176      &        +(pom1+pom2)*pom_dx
5177 #ifdef DEBUG
5178         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5179 #endif
5180 C
5181         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5182         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5183      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5184      &  +x(40)*xx*zz
5185         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5186         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5187      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5188      &  +x(59)*zz**2 +x(60)*xx*zz
5189         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5190      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5191      &        +(pom1-pom2)*pom_dy
5192 #ifdef DEBUG
5193         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5194 #endif
5195 C
5196         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5197      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5198      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5199      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5200      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5201      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5202      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5203      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5204 #ifdef DEBUG
5205         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5206 #endif
5207 C
5208         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5209      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5210      &  +pom1*pom_dt1+pom2*pom_dt2
5211 #ifdef DEBUG
5212         write(2,*), "de_dt = ", de_dt,de_dt_num
5213 #endif
5214 c
5215 C
5216        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5217        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5218        cosfac2xx=cosfac2*xx
5219        sinfac2yy=sinfac2*yy
5220        do k = 1,3
5221          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5222      &      vbld_inv(i+1)
5223          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5224      &      vbld_inv(i)
5225          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5226          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5227 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5228 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5229 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5230 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5231          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5232          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5233          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5234          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5235          dZZ_Ci1(k)=0.0d0
5236          dZZ_Ci(k)=0.0d0
5237          do j=1,3
5238            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5239      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5240            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5241      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5242          enddo
5243
5244          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5245          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5246          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5247 c
5248          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5249          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5250        enddo
5251
5252        do k=1,3
5253          dXX_Ctab(k,i)=dXX_Ci(k)
5254          dXX_C1tab(k,i)=dXX_Ci1(k)
5255          dYY_Ctab(k,i)=dYY_Ci(k)
5256          dYY_C1tab(k,i)=dYY_Ci1(k)
5257          dZZ_Ctab(k,i)=dZZ_Ci(k)
5258          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5259          dXX_XYZtab(k,i)=dXX_XYZ(k)
5260          dYY_XYZtab(k,i)=dYY_XYZ(k)
5261          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5262        enddo
5263
5264        do k = 1,3
5265 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5266 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5267 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5268 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5269 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5270 c     &    dt_dci(k)
5271 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5272 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5273          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5274      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5275          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5276      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5277          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5278      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5279        enddo
5280 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5281 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5282
5283 C to check gradient call subroutine check_grad
5284
5285     1 continue
5286       enddo
5287       return
5288       end
5289 #endif
5290 c------------------------------------------------------------------------------
5291       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5292 C
5293 C This procedure calculates two-body contact function g(rij) and its derivative:
5294 C
5295 C           eps0ij                                     !       x < -1
5296 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5297 C            0                                         !       x > 1
5298 C
5299 C where x=(rij-r0ij)/delta
5300 C
5301 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5302 C
5303       implicit none
5304       double precision rij,r0ij,eps0ij,fcont,fprimcont
5305       double precision x,x2,x4,delta
5306 c     delta=0.02D0*r0ij
5307 c      delta=0.2D0*r0ij
5308       x=(rij-r0ij)/delta
5309       if (x.lt.-1.0D0) then
5310         fcont=eps0ij
5311         fprimcont=0.0D0
5312       else if (x.le.1.0D0) then
5313         x2=x*x
5314         x4=x2*x2
5315         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5316         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5317       else
5318         fcont=0.0D0
5319         fprimcont=0.0D0
5320       endif
5321       return
5322       end
5323 c------------------------------------------------------------------------------
5324       subroutine splinthet(theti,delta,ss,ssder)
5325       implicit real*8 (a-h,o-z)
5326       include 'DIMENSIONS'
5327       include 'DIMENSIONS.ZSCOPT'
5328       include 'COMMON.VAR'
5329       include 'COMMON.GEO'
5330       thetup=pi-delta
5331       thetlow=delta
5332       if (theti.gt.pipol) then
5333         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5334       else
5335         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5336         ssder=-ssder
5337       endif
5338       return
5339       end
5340 c------------------------------------------------------------------------------
5341       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5342       implicit none
5343       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5344       double precision ksi,ksi2,ksi3,a1,a2,a3
5345       a1=fprim0*delta/(f1-f0)
5346       a2=3.0d0-2.0d0*a1
5347       a3=a1-2.0d0
5348       ksi=(x-x0)/delta
5349       ksi2=ksi*ksi
5350       ksi3=ksi2*ksi
5351       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5352       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5353       return
5354       end
5355 c------------------------------------------------------------------------------
5356       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5357       implicit none
5358       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5359       double precision ksi,ksi2,ksi3,a1,a2,a3
5360       ksi=(x-x0)/delta
5361       ksi2=ksi*ksi
5362       ksi3=ksi2*ksi
5363       a1=fprim0x*delta
5364       a2=3*(f1x-f0x)-2*fprim0x*delta
5365       a3=fprim0x*delta-2*(f1x-f0x)
5366       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5367       return
5368       end
5369 C-----------------------------------------------------------------------------
5370 #ifdef CRYST_TOR
5371 C-----------------------------------------------------------------------------
5372       subroutine etor(etors,edihcnstr,fact)
5373       implicit real*8 (a-h,o-z)
5374       include 'DIMENSIONS'
5375       include 'DIMENSIONS.ZSCOPT'
5376       include 'COMMON.VAR'
5377       include 'COMMON.GEO'
5378       include 'COMMON.LOCAL'
5379       include 'COMMON.TORSION'
5380       include 'COMMON.INTERACT'
5381       include 'COMMON.DERIV'
5382       include 'COMMON.CHAIN'
5383       include 'COMMON.NAMES'
5384       include 'COMMON.IOUNITS'
5385       include 'COMMON.FFIELD'
5386       include 'COMMON.TORCNSTR'
5387       logical lprn
5388 C Set lprn=.true. for debugging
5389       lprn=.false.
5390 c      lprn=.true.
5391       etors=0.0D0
5392       do i=iphi_start,iphi_end
5393         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5394      &      .or. itype(i).eq.ntyp1) cycle
5395         itori=itortyp(itype(i-2))
5396         itori1=itortyp(itype(i-1))
5397         phii=phi(i)
5398         gloci=0.0D0
5399 C Proline-Proline pair is a special case...
5400         if (itori.eq.3 .and. itori1.eq.3) then
5401           if (phii.gt.-dwapi3) then
5402             cosphi=dcos(3*phii)
5403             fac=1.0D0/(1.0D0-cosphi)
5404             etorsi=v1(1,3,3)*fac
5405             etorsi=etorsi+etorsi
5406             etors=etors+etorsi-v1(1,3,3)
5407             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5408           endif
5409           do j=1,3
5410             v1ij=v1(j+1,itori,itori1)
5411             v2ij=v2(j+1,itori,itori1)
5412             cosphi=dcos(j*phii)
5413             sinphi=dsin(j*phii)
5414             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5415             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5416           enddo
5417         else
5418           do j=1,nterm_old
5419             v1ij=v1(j,itori,itori1)
5420             v2ij=v2(j,itori,itori1)
5421             cosphi=dcos(j*phii)
5422             sinphi=dsin(j*phii)
5423             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5424             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5425           enddo
5426         endif
5427         if (lprn)
5428      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5429      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5430      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5431         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5432 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5433       enddo
5434 ! 6/20/98 - dihedral angle constraints
5435       edihcnstr=0.0d0
5436       do i=1,ndih_constr
5437         itori=idih_constr(i)
5438         phii=phi(itori)
5439         difi=phii-phi0(i)
5440         if (difi.gt.drange(i)) then
5441           difi=difi-drange(i)
5442           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5443           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5444         else if (difi.lt.-drange(i)) then
5445           difi=difi+drange(i)
5446           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5447           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5448         endif
5449 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5450 C     &    i,itori,rad2deg*phii,
5451 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5452       enddo
5453 !      write (iout,*) 'edihcnstr',edihcnstr
5454       return
5455       end
5456 c------------------------------------------------------------------------------
5457 #else
5458       subroutine etor(etors,edihcnstr,fact)
5459       implicit real*8 (a-h,o-z)
5460       include 'DIMENSIONS'
5461       include 'DIMENSIONS.ZSCOPT'
5462       include 'COMMON.VAR'
5463       include 'COMMON.GEO'
5464       include 'COMMON.LOCAL'
5465       include 'COMMON.TORSION'
5466       include 'COMMON.INTERACT'
5467       include 'COMMON.DERIV'
5468       include 'COMMON.CHAIN'
5469       include 'COMMON.NAMES'
5470       include 'COMMON.IOUNITS'
5471       include 'COMMON.FFIELD'
5472       include 'COMMON.TORCNSTR'
5473       logical lprn
5474 C Set lprn=.true. for debugging
5475       lprn=.false.
5476 c      lprn=.true.
5477       etors=0.0D0
5478       do i=iphi_start,iphi_end
5479         if (i.le.2) cycle
5480         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5481      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5482 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5483 C     &       .or. itype(i).eq.ntyp1) cycle
5484         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5485          if (iabs(itype(i)).eq.20) then
5486          iblock=2
5487          else
5488          iblock=1
5489          endif
5490         itori=itortyp(itype(i-2))
5491         itori1=itortyp(itype(i-1))
5492         phii=phi(i)
5493         gloci=0.0D0
5494 C Regular cosine and sine terms
5495         do j=1,nterm(itori,itori1,iblock)
5496           v1ij=v1(j,itori,itori1,iblock)
5497           v2ij=v2(j,itori,itori1,iblock)
5498           cosphi=dcos(j*phii)
5499           sinphi=dsin(j*phii)
5500           etors=etors+v1ij*cosphi+v2ij*sinphi
5501           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5502         enddo
5503 C Lorentz terms
5504 C                         v1
5505 C  E = SUM ----------------------------------- - v1
5506 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5507 C
5508         cosphi=dcos(0.5d0*phii)
5509         sinphi=dsin(0.5d0*phii)
5510         do j=1,nlor(itori,itori1,iblock)
5511           vl1ij=vlor1(j,itori,itori1)
5512           vl2ij=vlor2(j,itori,itori1)
5513           vl3ij=vlor3(j,itori,itori1)
5514           pom=vl2ij*cosphi+vl3ij*sinphi
5515           pom1=1.0d0/(pom*pom+1.0d0)
5516           etors=etors+vl1ij*pom1
5517 c          if (energy_dec) etors_ii=etors_ii+
5518 c     &                vl1ij*pom1
5519           pom=-pom*pom1*pom1
5520           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5521         enddo
5522 C Subtract the constant term
5523         etors=etors-v0(itori,itori1,iblock)
5524         if (lprn)
5525      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5526      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5527      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5528         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5529 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5530  1215   continue
5531       enddo
5532 ! 6/20/98 - dihedral angle constraints
5533       edihcnstr=0.0d0
5534       do i=1,ndih_constr
5535         itori=idih_constr(i)
5536         phii=phi(itori)
5537         difi=pinorm(phii-phi0(i))
5538         edihi=0.0d0
5539         if (difi.gt.drange(i)) then
5540           difi=difi-drange(i)
5541           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5542           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5543           edihi=0.25d0*ftors(i)*difi**4
5544         else if (difi.lt.-drange(i)) then
5545           difi=difi+drange(i)
5546           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5547           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5548           edihi=0.25d0*ftors(i)*difi**4
5549         else
5550           difi=0.0d0
5551         endif
5552         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5553      &    i,itori,rad2deg*phii,
5554      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5555 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5556 c     &    drange(i),edihi
5557 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5558 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5559       enddo
5560 !      write (iout,*) 'edihcnstr',edihcnstr
5561       return
5562       end
5563 c----------------------------------------------------------------------------
5564       subroutine etor_d(etors_d,fact2)
5565 C 6/23/01 Compute double torsional energy
5566       implicit real*8 (a-h,o-z)
5567       include 'DIMENSIONS'
5568       include 'DIMENSIONS.ZSCOPT'
5569       include 'COMMON.VAR'
5570       include 'COMMON.GEO'
5571       include 'COMMON.LOCAL'
5572       include 'COMMON.TORSION'
5573       include 'COMMON.INTERACT'
5574       include 'COMMON.DERIV'
5575       include 'COMMON.CHAIN'
5576       include 'COMMON.NAMES'
5577       include 'COMMON.IOUNITS'
5578       include 'COMMON.FFIELD'
5579       include 'COMMON.TORCNSTR'
5580       logical lprn
5581 C Set lprn=.true. for debugging
5582       lprn=.false.
5583 c     lprn=.true.
5584       etors_d=0.0D0
5585       do i=iphi_start,iphi_end-1
5586         if (i.le.3) cycle
5587 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5588 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5589          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5590      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5591      &  (itype(i+1).eq.ntyp1)) cycle
5592         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5593      &     goto 1215
5594         itori=itortyp(itype(i-2))
5595         itori1=itortyp(itype(i-1))
5596         itori2=itortyp(itype(i))
5597         phii=phi(i)
5598         phii1=phi(i+1)
5599         gloci1=0.0D0
5600         gloci2=0.0D0
5601         iblock=1
5602         if (iabs(itype(i+1)).eq.20) iblock=2
5603 C Regular cosine and sine terms
5604         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5605           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5606           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5607           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5608           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5609           cosphi1=dcos(j*phii)
5610           sinphi1=dsin(j*phii)
5611           cosphi2=dcos(j*phii1)
5612           sinphi2=dsin(j*phii1)
5613           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5614      &     v2cij*cosphi2+v2sij*sinphi2
5615           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5616           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5617         enddo
5618         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5619           do l=1,k-1
5620             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5621             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5622             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5623             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5624             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5625             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5626             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5627             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5628             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5629      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5630             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5631      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5632             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5633      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5634           enddo
5635         enddo
5636         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5637         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5638  1215   continue
5639       enddo
5640       return
5641       end
5642 #endif
5643 c------------------------------------------------------------------------------
5644       subroutine eback_sc_corr(esccor)
5645 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5646 c        conformational states; temporarily implemented as differences
5647 c        between UNRES torsional potentials (dependent on three types of
5648 c        residues) and the torsional potentials dependent on all 20 types
5649 c        of residues computed from AM1 energy surfaces of terminally-blocked
5650 c        amino-acid residues.
5651       implicit real*8 (a-h,o-z)
5652       include 'DIMENSIONS'
5653       include 'DIMENSIONS.ZSCOPT'
5654       include 'DIMENSIONS.FREE'
5655       include 'COMMON.VAR'
5656       include 'COMMON.GEO'
5657       include 'COMMON.LOCAL'
5658       include 'COMMON.TORSION'
5659       include 'COMMON.SCCOR'
5660       include 'COMMON.INTERACT'
5661       include 'COMMON.DERIV'
5662       include 'COMMON.CHAIN'
5663       include 'COMMON.NAMES'
5664       include 'COMMON.IOUNITS'
5665       include 'COMMON.FFIELD'
5666       include 'COMMON.CONTROL'
5667       logical lprn
5668 C Set lprn=.true. for debugging
5669       lprn=.false.
5670 c      lprn=.true.
5671 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5672       esccor=0.0D0
5673       do i=itau_start,itau_end
5674         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5675         esccor_ii=0.0D0
5676         isccori=isccortyp(itype(i-2))
5677         isccori1=isccortyp(itype(i-1))
5678         phii=phi(i)
5679         do intertyp=1,3 !intertyp
5680 cc Added 09 May 2012 (Adasko)
5681 cc  Intertyp means interaction type of backbone mainchain correlation:
5682 c   1 = SC...Ca...Ca...Ca
5683 c   2 = Ca...Ca...Ca...SC
5684 c   3 = SC...Ca...Ca...SCi
5685         gloci=0.0D0
5686         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5687      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5688      &      (itype(i-1).eq.ntyp1)))
5689      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5690      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5691      &     .or.(itype(i).eq.ntyp1)))
5692      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5693      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5694      &      (itype(i-3).eq.ntyp1)))) cycle
5695         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5696         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5697      & cycle
5698        do j=1,nterm_sccor(isccori,isccori1)
5699           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5700           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5701           cosphi=dcos(j*tauangle(intertyp,i))
5702           sinphi=dsin(j*tauangle(intertyp,i))
5703            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5704            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5705          enddo
5706 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5707 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5708 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5709         if (lprn)
5710      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5711      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5712      &  (v1sccor(j,1,itori,itori1),j=1,6)
5713      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5714 c        gsccor_loc(i-3)=gloci
5715        enddo !intertyp
5716       enddo
5717       return
5718       end
5719 c------------------------------------------------------------------------------
5720       subroutine multibody(ecorr)
5721 C This subroutine calculates multi-body contributions to energy following
5722 C the idea of Skolnick et al. If side chains I and J make a contact and
5723 C at the same time side chains I+1 and J+1 make a contact, an extra
5724 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5725       implicit real*8 (a-h,o-z)
5726       include 'DIMENSIONS'
5727       include 'COMMON.IOUNITS'
5728       include 'COMMON.DERIV'
5729       include 'COMMON.INTERACT'
5730       include 'COMMON.CONTACTS'
5731       double precision gx(3),gx1(3)
5732       logical lprn
5733
5734 C Set lprn=.true. for debugging
5735       lprn=.false.
5736
5737       if (lprn) then
5738         write (iout,'(a)') 'Contact function values:'
5739         do i=nnt,nct-2
5740           write (iout,'(i2,20(1x,i2,f10.5))')
5741      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5742         enddo
5743       endif
5744       ecorr=0.0D0
5745       do i=nnt,nct
5746         do j=1,3
5747           gradcorr(j,i)=0.0D0
5748           gradxorr(j,i)=0.0D0
5749         enddo
5750       enddo
5751       do i=nnt,nct-2
5752
5753         DO ISHIFT = 3,4
5754
5755         i1=i+ishift
5756         num_conti=num_cont(i)
5757         num_conti1=num_cont(i1)
5758         do jj=1,num_conti
5759           j=jcont(jj,i)
5760           do kk=1,num_conti1
5761             j1=jcont(kk,i1)
5762             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5763 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5764 cd   &                   ' ishift=',ishift
5765 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5766 C The system gains extra energy.
5767               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5768             endif   ! j1==j+-ishift
5769           enddo     ! kk
5770         enddo       ! jj
5771
5772         ENDDO ! ISHIFT
5773
5774       enddo         ! i
5775       return
5776       end
5777 c------------------------------------------------------------------------------
5778       double precision function esccorr(i,j,k,l,jj,kk)
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.IOUNITS'
5782       include 'COMMON.DERIV'
5783       include 'COMMON.INTERACT'
5784       include 'COMMON.CONTACTS'
5785       double precision gx(3),gx1(3)
5786       logical lprn
5787       lprn=.false.
5788       eij=facont(jj,i)
5789       ekl=facont(kk,k)
5790 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5791 C Calculate the multi-body contribution to energy.
5792 C Calculate multi-body contributions to the gradient.
5793 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5794 cd   & k,l,(gacont(m,kk,k),m=1,3)
5795       do m=1,3
5796         gx(m) =ekl*gacont(m,jj,i)
5797         gx1(m)=eij*gacont(m,kk,k)
5798         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5799         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5800         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5801         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5802       enddo
5803       do m=i,j-1
5804         do ll=1,3
5805           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5806         enddo
5807       enddo
5808       do m=k,l-1
5809         do ll=1,3
5810           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5811         enddo
5812       enddo
5813       esccorr=-eij*ekl
5814       return
5815       end
5816 c------------------------------------------------------------------------------
5817 #ifdef MPL
5818       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5819       implicit real*8 (a-h,o-z)
5820       include 'DIMENSIONS'
5821       integer dimen1,dimen2,atom,indx
5822       double precision buffer(dimen1,dimen2)
5823       double precision zapas
5824       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5825      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5826      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5827       num_kont=num_cont_hb(atom)
5828       do i=1,num_kont
5829         do k=1,7
5830           do j=1,3
5831             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5832           enddo ! j
5833         enddo ! k
5834         buffer(i,indx+22)=facont_hb(i,atom)
5835         buffer(i,indx+23)=ees0p(i,atom)
5836         buffer(i,indx+24)=ees0m(i,atom)
5837         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5838       enddo ! i
5839       buffer(1,indx+26)=dfloat(num_kont)
5840       return
5841       end
5842 c------------------------------------------------------------------------------
5843       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5844       implicit real*8 (a-h,o-z)
5845       include 'DIMENSIONS'
5846       integer dimen1,dimen2,atom,indx
5847       double precision buffer(dimen1,dimen2)
5848       double precision zapas
5849       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5850      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5851      &         ees0m(ntyp,maxres),
5852      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5853       num_kont=buffer(1,indx+26)
5854       num_kont_old=num_cont_hb(atom)
5855       num_cont_hb(atom)=num_kont+num_kont_old
5856       do i=1,num_kont
5857         ii=i+num_kont_old
5858         do k=1,7
5859           do j=1,3
5860             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5861           enddo ! j
5862         enddo ! k
5863         facont_hb(ii,atom)=buffer(i,indx+22)
5864         ees0p(ii,atom)=buffer(i,indx+23)
5865         ees0m(ii,atom)=buffer(i,indx+24)
5866         jcont_hb(ii,atom)=buffer(i,indx+25)
5867       enddo ! i
5868       return
5869       end
5870 c------------------------------------------------------------------------------
5871 #endif
5872       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5873 C This subroutine calculates multi-body contributions to hydrogen-bonding
5874       implicit real*8 (a-h,o-z)
5875       include 'DIMENSIONS'
5876       include 'DIMENSIONS.ZSCOPT'
5877       include 'COMMON.IOUNITS'
5878 #ifdef MPL
5879       include 'COMMON.INFO'
5880 #endif
5881       include 'COMMON.FFIELD'
5882       include 'COMMON.DERIV'
5883       include 'COMMON.INTERACT'
5884       include 'COMMON.CONTACTS'
5885 #ifdef MPL
5886       parameter (max_cont=maxconts)
5887       parameter (max_dim=2*(8*3+2))
5888       parameter (msglen1=max_cont*max_dim*4)
5889       parameter (msglen2=2*msglen1)
5890       integer source,CorrelType,CorrelID,Error
5891       double precision buffer(max_cont,max_dim)
5892 #endif
5893       double precision gx(3),gx1(3)
5894       logical lprn,ldone
5895
5896 C Set lprn=.true. for debugging
5897       lprn=.false.
5898 #ifdef MPL
5899       n_corr=0
5900       n_corr1=0
5901       if (fgProcs.le.1) goto 30
5902       if (lprn) then
5903         write (iout,'(a)') 'Contact function values:'
5904         do i=nnt,nct-2
5905           write (iout,'(2i3,50(1x,i2,f5.2))')
5906      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5907      &    j=1,num_cont_hb(i))
5908         enddo
5909       endif
5910 C Caution! Following code assumes that electrostatic interactions concerning
5911 C a given atom are split among at most two processors!
5912       CorrelType=477
5913       CorrelID=MyID+1
5914       ldone=.false.
5915       do i=1,max_cont
5916         do j=1,max_dim
5917           buffer(i,j)=0.0D0
5918         enddo
5919       enddo
5920       mm=mod(MyRank,2)
5921 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5922       if (mm) 20,20,10
5923    10 continue
5924 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5925       if (MyRank.gt.0) then
5926 C Send correlation contributions to the preceding processor
5927         msglen=msglen1
5928         nn=num_cont_hb(iatel_s)
5929         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5930 cd      write (iout,*) 'The BUFFER array:'
5931 cd      do i=1,nn
5932 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5933 cd      enddo
5934         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5935           msglen=msglen2
5936             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5937 C Clear the contacts of the atom passed to the neighboring processor
5938         nn=num_cont_hb(iatel_s+1)
5939 cd      do i=1,nn
5940 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5941 cd      enddo
5942             num_cont_hb(iatel_s)=0
5943         endif
5944 cd      write (iout,*) 'Processor ',MyID,MyRank,
5945 cd   & ' is sending correlation contribution to processor',MyID-1,
5946 cd   & ' msglen=',msglen
5947 cd      write (*,*) 'Processor ',MyID,MyRank,
5948 cd   & ' is sending correlation contribution to processor',MyID-1,
5949 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5950         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5951 cd      write (iout,*) 'Processor ',MyID,
5952 cd   & ' has sent correlation contribution to processor',MyID-1,
5953 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5954 cd      write (*,*) 'Processor ',MyID,
5955 cd   & ' has sent correlation contribution to processor',MyID-1,
5956 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5957         msglen=msglen1
5958       endif ! (MyRank.gt.0)
5959       if (ldone) goto 30
5960       ldone=.true.
5961    20 continue
5962 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5963       if (MyRank.lt.fgProcs-1) then
5964 C Receive correlation contributions from the next processor
5965         msglen=msglen1
5966         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5967 cd      write (iout,*) 'Processor',MyID,
5968 cd   & ' is receiving correlation contribution from processor',MyID+1,
5969 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5970 cd      write (*,*) 'Processor',MyID,
5971 cd   & ' is receiving correlation contribution from processor',MyID+1,
5972 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5973         nbytes=-1
5974         do while (nbytes.le.0)
5975           call mp_probe(MyID+1,CorrelType,nbytes)
5976         enddo
5977 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5978         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5979 cd      write (iout,*) 'Processor',MyID,
5980 cd   & ' has received correlation contribution from processor',MyID+1,
5981 cd   & ' msglen=',msglen,' nbytes=',nbytes
5982 cd      write (iout,*) 'The received BUFFER array:'
5983 cd      do i=1,max_cont
5984 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5985 cd      enddo
5986         if (msglen.eq.msglen1) then
5987           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5988         else if (msglen.eq.msglen2)  then
5989           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5990           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5991         else
5992           write (iout,*)
5993      & 'ERROR!!!! message length changed while processing correlations.'
5994           write (*,*)
5995      & 'ERROR!!!! message length changed while processing correlations.'
5996           call mp_stopall(Error)
5997         endif ! msglen.eq.msglen1
5998       endif ! MyRank.lt.fgProcs-1
5999       if (ldone) goto 30
6000       ldone=.true.
6001       goto 10
6002    30 continue
6003 #endif
6004       if (lprn) then
6005         write (iout,'(a)') 'Contact function values:'
6006         do i=nnt,nct-2
6007           write (iout,'(2i3,50(1x,i2,f5.2))')
6008      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6009      &    j=1,num_cont_hb(i))
6010         enddo
6011       endif
6012       ecorr=0.0D0
6013 C Remove the loop below after debugging !!!
6014       do i=nnt,nct
6015         do j=1,3
6016           gradcorr(j,i)=0.0D0
6017           gradxorr(j,i)=0.0D0
6018         enddo
6019       enddo
6020 C Calculate the local-electrostatic correlation terms
6021       do i=iatel_s,iatel_e+1
6022         i1=i+1
6023         num_conti=num_cont_hb(i)
6024         num_conti1=num_cont_hb(i+1)
6025         do jj=1,num_conti
6026           j=jcont_hb(jj,i)
6027           do kk=1,num_conti1
6028             j1=jcont_hb(kk,i1)
6029 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6030 c     &         ' jj=',jj,' kk=',kk
6031             if (j1.eq.j+1 .or. j1.eq.j-1) then
6032 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6033 C The system gains extra energy.
6034               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6035               n_corr=n_corr+1
6036             else if (j1.eq.j) then
6037 C Contacts I-J and I-(J+1) occur simultaneously.
6038 C The system loses extra energy.
6039 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6040             endif
6041           enddo ! kk
6042           do kk=1,num_conti
6043             j1=jcont_hb(kk,i)
6044 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6045 c    &         ' jj=',jj,' kk=',kk
6046             if (j1.eq.j+1) then
6047 C Contacts I-J and (I+1)-J occur simultaneously.
6048 C The system loses extra energy.
6049 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6050             endif ! j1==j+1
6051           enddo ! kk
6052         enddo ! jj
6053       enddo ! i
6054       return
6055       end
6056 c------------------------------------------------------------------------------
6057       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6058      &  n_corr1)
6059 C This subroutine calculates multi-body contributions to hydrogen-bonding
6060       implicit real*8 (a-h,o-z)
6061       include 'DIMENSIONS'
6062       include 'DIMENSIONS.ZSCOPT'
6063       include 'COMMON.IOUNITS'
6064 #ifdef MPL
6065       include 'COMMON.INFO'
6066 #endif
6067       include 'COMMON.FFIELD'
6068       include 'COMMON.DERIV'
6069       include 'COMMON.INTERACT'
6070       include 'COMMON.CONTACTS'
6071 #ifdef MPL
6072       parameter (max_cont=maxconts)
6073       parameter (max_dim=2*(8*3+2))
6074       parameter (msglen1=max_cont*max_dim*4)
6075       parameter (msglen2=2*msglen1)
6076       integer source,CorrelType,CorrelID,Error
6077       double precision buffer(max_cont,max_dim)
6078 #endif
6079       double precision gx(3),gx1(3)
6080       logical lprn,ldone
6081
6082 C Set lprn=.true. for debugging
6083       lprn=.false.
6084       eturn6=0.0d0
6085       ecorr6=0.0d0
6086 #ifdef MPL
6087       n_corr=0
6088       n_corr1=0
6089       if (fgProcs.le.1) goto 30
6090       if (lprn) then
6091         write (iout,'(a)') 'Contact function values:'
6092         do i=nnt,nct-2
6093           write (iout,'(2i3,50(1x,i2,f5.2))')
6094      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6095      &    j=1,num_cont_hb(i))
6096         enddo
6097       endif
6098 C Caution! Following code assumes that electrostatic interactions concerning
6099 C a given atom are split among at most two processors!
6100       CorrelType=477
6101       CorrelID=MyID+1
6102       ldone=.false.
6103       do i=1,max_cont
6104         do j=1,max_dim
6105           buffer(i,j)=0.0D0
6106         enddo
6107       enddo
6108       mm=mod(MyRank,2)
6109 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6110       if (mm) 20,20,10
6111    10 continue
6112 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6113       if (MyRank.gt.0) then
6114 C Send correlation contributions to the preceding processor
6115         msglen=msglen1
6116         nn=num_cont_hb(iatel_s)
6117         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6118 cd      write (iout,*) 'The BUFFER array:'
6119 cd      do i=1,nn
6120 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6121 cd      enddo
6122         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6123           msglen=msglen2
6124             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6125 C Clear the contacts of the atom passed to the neighboring processor
6126         nn=num_cont_hb(iatel_s+1)
6127 cd      do i=1,nn
6128 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6129 cd      enddo
6130             num_cont_hb(iatel_s)=0
6131         endif
6132 cd      write (iout,*) 'Processor ',MyID,MyRank,
6133 cd   & ' is sending correlation contribution to processor',MyID-1,
6134 cd   & ' msglen=',msglen
6135 cd      write (*,*) 'Processor ',MyID,MyRank,
6136 cd   & ' is sending correlation contribution to processor',MyID-1,
6137 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6138         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6139 cd      write (iout,*) 'Processor ',MyID,
6140 cd   & ' has sent correlation contribution to processor',MyID-1,
6141 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6142 cd      write (*,*) 'Processor ',MyID,
6143 cd   & ' has sent correlation contribution to processor',MyID-1,
6144 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6145         msglen=msglen1
6146       endif ! (MyRank.gt.0)
6147       if (ldone) goto 30
6148       ldone=.true.
6149    20 continue
6150 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6151       if (MyRank.lt.fgProcs-1) then
6152 C Receive correlation contributions from the next processor
6153         msglen=msglen1
6154         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6155 cd      write (iout,*) 'Processor',MyID,
6156 cd   & ' is receiving correlation contribution from processor',MyID+1,
6157 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6158 cd      write (*,*) 'Processor',MyID,
6159 cd   & ' is receiving correlation contribution from processor',MyID+1,
6160 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6161         nbytes=-1
6162         do while (nbytes.le.0)
6163           call mp_probe(MyID+1,CorrelType,nbytes)
6164         enddo
6165 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6166         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6167 cd      write (iout,*) 'Processor',MyID,
6168 cd   & ' has received correlation contribution from processor',MyID+1,
6169 cd   & ' msglen=',msglen,' nbytes=',nbytes
6170 cd      write (iout,*) 'The received BUFFER array:'
6171 cd      do i=1,max_cont
6172 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6173 cd      enddo
6174         if (msglen.eq.msglen1) then
6175           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6176         else if (msglen.eq.msglen2)  then
6177           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6178           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6179         else
6180           write (iout,*)
6181      & 'ERROR!!!! message length changed while processing correlations.'
6182           write (*,*)
6183      & 'ERROR!!!! message length changed while processing correlations.'
6184           call mp_stopall(Error)
6185         endif ! msglen.eq.msglen1
6186       endif ! MyRank.lt.fgProcs-1
6187       if (ldone) goto 30
6188       ldone=.true.
6189       goto 10
6190    30 continue
6191 #endif
6192       if (lprn) then
6193         write (iout,'(a)') 'Contact function values:'
6194         do i=nnt,nct-2
6195           write (iout,'(2i3,50(1x,i2,f5.2))')
6196      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6197      &    j=1,num_cont_hb(i))
6198         enddo
6199       endif
6200       ecorr=0.0D0
6201       ecorr5=0.0d0
6202       ecorr6=0.0d0
6203 C Remove the loop below after debugging !!!
6204       do i=nnt,nct
6205         do j=1,3
6206           gradcorr(j,i)=0.0D0
6207           gradxorr(j,i)=0.0D0
6208         enddo
6209       enddo
6210 C Calculate the dipole-dipole interaction energies
6211       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6212       do i=iatel_s,iatel_e+1
6213         num_conti=num_cont_hb(i)
6214         do jj=1,num_conti
6215           j=jcont_hb(jj,i)
6216           call dipole(i,j,jj)
6217         enddo
6218       enddo
6219       endif
6220 C Calculate the local-electrostatic correlation terms
6221       do i=iatel_s,iatel_e+1
6222         i1=i+1
6223         num_conti=num_cont_hb(i)
6224         num_conti1=num_cont_hb(i+1)
6225         do jj=1,num_conti
6226           j=jcont_hb(jj,i)
6227           do kk=1,num_conti1
6228             j1=jcont_hb(kk,i1)
6229 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6230 c     &         ' jj=',jj,' kk=',kk
6231             if (j1.eq.j+1 .or. j1.eq.j-1) then
6232 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6233 C The system gains extra energy.
6234               n_corr=n_corr+1
6235               sqd1=dsqrt(d_cont(jj,i))
6236               sqd2=dsqrt(d_cont(kk,i1))
6237               sred_geom = sqd1*sqd2
6238               IF (sred_geom.lt.cutoff_corr) THEN
6239                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6240      &            ekont,fprimcont)
6241 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6242 c     &         ' jj=',jj,' kk=',kk
6243                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6244                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6245                 do l=1,3
6246                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6247                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6248                 enddo
6249                 n_corr1=n_corr1+1
6250 cd               write (iout,*) 'sred_geom=',sred_geom,
6251 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6252                 call calc_eello(i,j,i+1,j1,jj,kk)
6253                 if (wcorr4.gt.0.0d0)
6254      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6255                 if (wcorr5.gt.0.0d0)
6256      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6257 c                print *,"wcorr5",ecorr5
6258 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6259 cd                write(2,*)'ijkl',i,j,i+1,j1
6260                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6261      &               .or. wturn6.eq.0.0d0))then
6262 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6263                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6264 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6265 cd     &            'ecorr6=',ecorr6
6266 cd                write (iout,'(4e15.5)') sred_geom,
6267 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6268 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6269 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6270                 else if (wturn6.gt.0.0d0
6271      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6272 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6273                   eturn6=eturn6+eello_turn6(i,jj,kk)
6274 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6275                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6276                    eturn6=0.0d0
6277                    ecorr6=0.0d0
6278                 endif
6279
6280               ENDIF
6281 1111          continue
6282             else if (j1.eq.j) then
6283 C Contacts I-J and I-(J+1) occur simultaneously.
6284 C The system loses extra energy.
6285 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6286             endif
6287           enddo ! kk
6288           do kk=1,num_conti
6289             j1=jcont_hb(kk,i)
6290 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6291 c    &         ' jj=',jj,' kk=',kk
6292             if (j1.eq.j+1) then
6293 C Contacts I-J and (I+1)-J occur simultaneously.
6294 C The system loses extra energy.
6295 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6296             endif ! j1==j+1
6297           enddo ! kk
6298         enddo ! jj
6299       enddo ! i
6300       write (iout,*) "eturn6",eturn6,ecorr6
6301       return
6302       end
6303 c------------------------------------------------------------------------------
6304       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6305       implicit real*8 (a-h,o-z)
6306       include 'DIMENSIONS'
6307       include 'COMMON.IOUNITS'
6308       include 'COMMON.DERIV'
6309       include 'COMMON.INTERACT'
6310       include 'COMMON.CONTACTS'
6311       double precision gx(3),gx1(3)
6312       logical lprn
6313       lprn=.false.
6314       eij=facont_hb(jj,i)
6315       ekl=facont_hb(kk,k)
6316       ees0pij=ees0p(jj,i)
6317       ees0pkl=ees0p(kk,k)
6318       ees0mij=ees0m(jj,i)
6319       ees0mkl=ees0m(kk,k)
6320       ekont=eij*ekl
6321       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6322 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6323 C Following 4 lines for diagnostics.
6324 cd    ees0pkl=0.0D0
6325 cd    ees0pij=1.0D0
6326 cd    ees0mkl=0.0D0
6327 cd    ees0mij=1.0D0
6328 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6329 c    &   ' and',k,l
6330 c     write (iout,*)'Contacts have occurred for peptide groups',
6331 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6332 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6333 C Calculate the multi-body contribution to energy.
6334       ecorr=ecorr+ekont*ees
6335       if (calc_grad) then
6336 C Calculate multi-body contributions to the gradient.
6337       do ll=1,3
6338         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6339         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6340      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6341      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6342         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6343      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6344      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6345         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6346         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6347      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6348      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6349         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6350      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6351      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6352       enddo
6353       do m=i+1,j-1
6354         do ll=1,3
6355           gradcorr(ll,m)=gradcorr(ll,m)+
6356      &     ees*ekl*gacont_hbr(ll,jj,i)-
6357      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6358      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6359         enddo
6360       enddo
6361       do m=k+1,l-1
6362         do ll=1,3
6363           gradcorr(ll,m)=gradcorr(ll,m)+
6364      &     ees*eij*gacont_hbr(ll,kk,k)-
6365      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6366      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6367         enddo
6368       enddo
6369       endif
6370       ehbcorr=ekont*ees
6371       return
6372       end
6373 C---------------------------------------------------------------------------
6374       subroutine dipole(i,j,jj)
6375       implicit real*8 (a-h,o-z)
6376       include 'DIMENSIONS'
6377       include 'DIMENSIONS.ZSCOPT'
6378       include 'COMMON.IOUNITS'
6379       include 'COMMON.CHAIN'
6380       include 'COMMON.FFIELD'
6381       include 'COMMON.DERIV'
6382       include 'COMMON.INTERACT'
6383       include 'COMMON.CONTACTS'
6384       include 'COMMON.TORSION'
6385       include 'COMMON.VAR'
6386       include 'COMMON.GEO'
6387       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6388      &  auxmat(2,2)
6389       iti1 = itortyp(itype(i+1))
6390       if (j.lt.nres-1) then
6391         if (itype(j).le.ntyp) then
6392           itj1 = itortyp(itype(j+1))
6393         else
6394           itj=ntortyp+1
6395         endif
6396       else
6397         itj1=ntortyp+1
6398       endif
6399       do iii=1,2
6400         dipi(iii,1)=Ub2(iii,i)
6401         dipderi(iii)=Ub2der(iii,i)
6402         dipi(iii,2)=b1(iii,iti1)
6403         dipj(iii,1)=Ub2(iii,j)
6404         dipderj(iii)=Ub2der(iii,j)
6405         dipj(iii,2)=b1(iii,itj1)
6406       enddo
6407       kkk=0
6408       do iii=1,2
6409         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6410         do jjj=1,2
6411           kkk=kkk+1
6412           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6413         enddo
6414       enddo
6415       if (.not.calc_grad) return
6416       do kkk=1,5
6417         do lll=1,3
6418           mmm=0
6419           do iii=1,2
6420             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6421      &        auxvec(1))
6422             do jjj=1,2
6423               mmm=mmm+1
6424               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6425             enddo
6426           enddo
6427         enddo
6428       enddo
6429       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6430       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6431       do iii=1,2
6432         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6433       enddo
6434       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6435       do iii=1,2
6436         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6437       enddo
6438       return
6439       end
6440 C---------------------------------------------------------------------------
6441       subroutine calc_eello(i,j,k,l,jj,kk)
6442 C
6443 C This subroutine computes matrices and vectors needed to calculate
6444 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6445 C
6446       implicit real*8 (a-h,o-z)
6447       include 'DIMENSIONS'
6448       include 'DIMENSIONS.ZSCOPT'
6449       include 'COMMON.IOUNITS'
6450       include 'COMMON.CHAIN'
6451       include 'COMMON.DERIV'
6452       include 'COMMON.INTERACT'
6453       include 'COMMON.CONTACTS'
6454       include 'COMMON.TORSION'
6455       include 'COMMON.VAR'
6456       include 'COMMON.GEO'
6457       include 'COMMON.FFIELD'
6458       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6459      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6460       logical lprn
6461       common /kutas/ lprn
6462 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6463 cd     & ' jj=',jj,' kk=',kk
6464 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6465       do iii=1,2
6466         do jjj=1,2
6467           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6468           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6469         enddo
6470       enddo
6471       call transpose2(aa1(1,1),aa1t(1,1))
6472       call transpose2(aa2(1,1),aa2t(1,1))
6473       do kkk=1,5
6474         do lll=1,3
6475           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6476      &      aa1tder(1,1,lll,kkk))
6477           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6478      &      aa2tder(1,1,lll,kkk))
6479         enddo
6480       enddo
6481       if (l.eq.j+1) then
6482 C parallel orientation of the two CA-CA-CA frames.
6483         if (i.gt.1 .and. itype(i).le.ntyp) then
6484           iti=itortyp(itype(i))
6485         else
6486           iti=ntortyp+1
6487         endif
6488         itk1=itortyp(itype(k+1))
6489         itj=itortyp(itype(j))
6490         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6491           itl1=itortyp(itype(l+1))
6492         else
6493           itl1=ntortyp+1
6494         endif
6495 C A1 kernel(j+1) A2T
6496 cd        do iii=1,2
6497 cd          write (iout,'(3f10.5,5x,3f10.5)')
6498 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6499 cd        enddo
6500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6501      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6502      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6503 C Following matrices are needed only for 6-th order cumulants
6504         IF (wcorr6.gt.0.0d0) THEN
6505         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6506      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6507      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6508         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6509      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6510      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6511      &   ADtEAderx(1,1,1,1,1,1))
6512         lprn=.false.
6513         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6514      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6515      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6516      &   ADtEA1derx(1,1,1,1,1,1))
6517         ENDIF
6518 C End 6-th order cumulants
6519 cd        lprn=.false.
6520 cd        if (lprn) then
6521 cd        write (2,*) 'In calc_eello6'
6522 cd        do iii=1,2
6523 cd          write (2,*) 'iii=',iii
6524 cd          do kkk=1,5
6525 cd            write (2,*) 'kkk=',kkk
6526 cd            do jjj=1,2
6527 cd              write (2,'(3(2f10.5),5x)')
6528 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6529 cd            enddo
6530 cd          enddo
6531 cd        enddo
6532 cd        endif
6533         call transpose2(EUgder(1,1,k),auxmat(1,1))
6534         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6535         call transpose2(EUg(1,1,k),auxmat(1,1))
6536         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6537         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6538         do iii=1,2
6539           do kkk=1,5
6540             do lll=1,3
6541               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6542      &          EAEAderx(1,1,lll,kkk,iii,1))
6543             enddo
6544           enddo
6545         enddo
6546 C A1T kernel(i+1) A2
6547         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6548      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6549      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6550 C Following matrices are needed only for 6-th order cumulants
6551         IF (wcorr6.gt.0.0d0) THEN
6552         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6553      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6554      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6555         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6556      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6557      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6558      &   ADtEAderx(1,1,1,1,1,2))
6559         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6560      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6561      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6562      &   ADtEA1derx(1,1,1,1,1,2))
6563         ENDIF
6564 C End 6-th order cumulants
6565         call transpose2(EUgder(1,1,l),auxmat(1,1))
6566         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6567         call transpose2(EUg(1,1,l),auxmat(1,1))
6568         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6569         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6570         do iii=1,2
6571           do kkk=1,5
6572             do lll=1,3
6573               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6574      &          EAEAderx(1,1,lll,kkk,iii,2))
6575             enddo
6576           enddo
6577         enddo
6578 C AEAb1 and AEAb2
6579 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6580 C They are needed only when the fifth- or the sixth-order cumulants are
6581 C indluded.
6582         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6583         call transpose2(AEA(1,1,1),auxmat(1,1))
6584         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6585         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6586         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6587         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6588         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6589         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6590         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6591         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6592         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6593         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6594         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6595         call transpose2(AEA(1,1,2),auxmat(1,1))
6596         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6597         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6598         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6599         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6600         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6601         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6602         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6603         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6604         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6605         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6606         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6607 C Calculate the Cartesian derivatives of the vectors.
6608         do iii=1,2
6609           do kkk=1,5
6610             do lll=1,3
6611               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6612               call matvec2(auxmat(1,1),b1(1,iti),
6613      &          AEAb1derx(1,lll,kkk,iii,1,1))
6614               call matvec2(auxmat(1,1),Ub2(1,i),
6615      &          AEAb2derx(1,lll,kkk,iii,1,1))
6616               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6617      &          AEAb1derx(1,lll,kkk,iii,2,1))
6618               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6619      &          AEAb2derx(1,lll,kkk,iii,2,1))
6620               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6621               call matvec2(auxmat(1,1),b1(1,itj),
6622      &          AEAb1derx(1,lll,kkk,iii,1,2))
6623               call matvec2(auxmat(1,1),Ub2(1,j),
6624      &          AEAb2derx(1,lll,kkk,iii,1,2))
6625               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6626      &          AEAb1derx(1,lll,kkk,iii,2,2))
6627               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6628      &          AEAb2derx(1,lll,kkk,iii,2,2))
6629             enddo
6630           enddo
6631         enddo
6632         ENDIF
6633 C End vectors
6634       else
6635 C Antiparallel orientation of the two CA-CA-CA frames.
6636         if (i.gt.1 .and. itype(i).le.ntyp) then
6637           iti=itortyp(itype(i))
6638         else
6639           iti=ntortyp+1
6640         endif
6641         itk1=itortyp(itype(k+1))
6642         itl=itortyp(itype(l))
6643         itj=itortyp(itype(j))
6644         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6645           itj1=itortyp(itype(j+1))
6646         else
6647           itj1=ntortyp+1
6648         endif
6649 C A2 kernel(j-1)T A1T
6650         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6651      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6652      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6653 C Following matrices are needed only for 6-th order cumulants
6654         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6655      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6656         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6657      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6658      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6659         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6660      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6661      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6662      &   ADtEAderx(1,1,1,1,1,1))
6663         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6664      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6665      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6666      &   ADtEA1derx(1,1,1,1,1,1))
6667         ENDIF
6668 C End 6-th order cumulants
6669         call transpose2(EUgder(1,1,k),auxmat(1,1))
6670         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6671         call transpose2(EUg(1,1,k),auxmat(1,1))
6672         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6673         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6674         do iii=1,2
6675           do kkk=1,5
6676             do lll=1,3
6677               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6678      &          EAEAderx(1,1,lll,kkk,iii,1))
6679             enddo
6680           enddo
6681         enddo
6682 C A2T kernel(i+1)T A1
6683         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6684      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6685      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6686 C Following matrices are needed only for 6-th order cumulants
6687         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6688      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6689         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6690      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6691      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6692         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6693      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6694      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6695      &   ADtEAderx(1,1,1,1,1,2))
6696         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6697      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6698      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6699      &   ADtEA1derx(1,1,1,1,1,2))
6700         ENDIF
6701 C End 6-th order cumulants
6702         call transpose2(EUgder(1,1,j),auxmat(1,1))
6703         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6704         call transpose2(EUg(1,1,j),auxmat(1,1))
6705         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6706         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6707         do iii=1,2
6708           do kkk=1,5
6709             do lll=1,3
6710               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6711      &          EAEAderx(1,1,lll,kkk,iii,2))
6712             enddo
6713           enddo
6714         enddo
6715 C AEAb1 and AEAb2
6716 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6717 C They are needed only when the fifth- or the sixth-order cumulants are
6718 C indluded.
6719         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6720      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6721         call transpose2(AEA(1,1,1),auxmat(1,1))
6722         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6723         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6724         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6725         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6726         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6727         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6728         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6729         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6730         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6731         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6732         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6733         call transpose2(AEA(1,1,2),auxmat(1,1))
6734         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6735         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6736         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6737         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6738         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6739         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6740         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6741         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6742         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6743         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6744         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6745 C Calculate the Cartesian derivatives of the vectors.
6746         do iii=1,2
6747           do kkk=1,5
6748             do lll=1,3
6749               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6750               call matvec2(auxmat(1,1),b1(1,iti),
6751      &          AEAb1derx(1,lll,kkk,iii,1,1))
6752               call matvec2(auxmat(1,1),Ub2(1,i),
6753      &          AEAb2derx(1,lll,kkk,iii,1,1))
6754               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6755      &          AEAb1derx(1,lll,kkk,iii,2,1))
6756               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6757      &          AEAb2derx(1,lll,kkk,iii,2,1))
6758               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6759               call matvec2(auxmat(1,1),b1(1,itl),
6760      &          AEAb1derx(1,lll,kkk,iii,1,2))
6761               call matvec2(auxmat(1,1),Ub2(1,l),
6762      &          AEAb2derx(1,lll,kkk,iii,1,2))
6763               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6764      &          AEAb1derx(1,lll,kkk,iii,2,2))
6765               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6766      &          AEAb2derx(1,lll,kkk,iii,2,2))
6767             enddo
6768           enddo
6769         enddo
6770         ENDIF
6771 C End vectors
6772       endif
6773       return
6774       end
6775 C---------------------------------------------------------------------------
6776       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6777      &  KK,KKderg,AKA,AKAderg,AKAderx)
6778       implicit none
6779       integer nderg
6780       logical transp
6781       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6782      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6783      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6784       integer iii,kkk,lll
6785       integer jjj,mmm
6786       logical lprn
6787       common /kutas/ lprn
6788       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6789       do iii=1,nderg
6790         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6791      &    AKAderg(1,1,iii))
6792       enddo
6793 cd      if (lprn) write (2,*) 'In kernel'
6794       do kkk=1,5
6795 cd        if (lprn) write (2,*) 'kkk=',kkk
6796         do lll=1,3
6797           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6798      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6799 cd          if (lprn) then
6800 cd            write (2,*) 'lll=',lll
6801 cd            write (2,*) 'iii=1'
6802 cd            do jjj=1,2
6803 cd              write (2,'(3(2f10.5),5x)')
6804 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6805 cd            enddo
6806 cd          endif
6807           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6808      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6809 cd          if (lprn) then
6810 cd            write (2,*) 'lll=',lll
6811 cd            write (2,*) 'iii=2'
6812 cd            do jjj=1,2
6813 cd              write (2,'(3(2f10.5),5x)')
6814 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6815 cd            enddo
6816 cd          endif
6817         enddo
6818       enddo
6819       return
6820       end
6821 C---------------------------------------------------------------------------
6822       double precision function eello4(i,j,k,l,jj,kk)
6823       implicit real*8 (a-h,o-z)
6824       include 'DIMENSIONS'
6825       include 'DIMENSIONS.ZSCOPT'
6826       include 'COMMON.IOUNITS'
6827       include 'COMMON.CHAIN'
6828       include 'COMMON.DERIV'
6829       include 'COMMON.INTERACT'
6830       include 'COMMON.CONTACTS'
6831       include 'COMMON.TORSION'
6832       include 'COMMON.VAR'
6833       include 'COMMON.GEO'
6834       double precision pizda(2,2),ggg1(3),ggg2(3)
6835 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6836 cd        eello4=0.0d0
6837 cd        return
6838 cd      endif
6839 cd      print *,'eello4:',i,j,k,l,jj,kk
6840 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6841 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6842 cold      eij=facont_hb(jj,i)
6843 cold      ekl=facont_hb(kk,k)
6844 cold      ekont=eij*ekl
6845       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6846       if (calc_grad) then
6847 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6848       gcorr_loc(k-1)=gcorr_loc(k-1)
6849      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6850       if (l.eq.j+1) then
6851         gcorr_loc(l-1)=gcorr_loc(l-1)
6852      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6853       else
6854         gcorr_loc(j-1)=gcorr_loc(j-1)
6855      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6856       endif
6857       do iii=1,2
6858         do kkk=1,5
6859           do lll=1,3
6860             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6861      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6862 cd            derx(lll,kkk,iii)=0.0d0
6863           enddo
6864         enddo
6865       enddo
6866 cd      gcorr_loc(l-1)=0.0d0
6867 cd      gcorr_loc(j-1)=0.0d0
6868 cd      gcorr_loc(k-1)=0.0d0
6869 cd      eel4=1.0d0
6870 cd      write (iout,*)'Contacts have occurred for peptide groups',
6871 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6872 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6873       if (j.lt.nres-1) then
6874         j1=j+1
6875         j2=j-1
6876       else
6877         j1=j-1
6878         j2=j-2
6879       endif
6880       if (l.lt.nres-1) then
6881         l1=l+1
6882         l2=l-1
6883       else
6884         l1=l-1
6885         l2=l-2
6886       endif
6887       do ll=1,3
6888 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6889         ggg1(ll)=eel4*g_contij(ll,1)
6890         ggg2(ll)=eel4*g_contij(ll,2)
6891         ghalf=0.5d0*ggg1(ll)
6892 cd        ghalf=0.0d0
6893         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6894         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6895         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6896         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6897 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6898         ghalf=0.5d0*ggg2(ll)
6899 cd        ghalf=0.0d0
6900         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6901         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6902         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6903         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6904       enddo
6905 cd      goto 1112
6906       do m=i+1,j-1
6907         do ll=1,3
6908 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6909           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6910         enddo
6911       enddo
6912       do m=k+1,l-1
6913         do ll=1,3
6914 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6915           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6916         enddo
6917       enddo
6918 1112  continue
6919       do m=i+2,j2
6920         do ll=1,3
6921           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6922         enddo
6923       enddo
6924       do m=k+2,l2
6925         do ll=1,3
6926           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6927         enddo
6928       enddo
6929 cd      do iii=1,nres-3
6930 cd        write (2,*) iii,gcorr_loc(iii)
6931 cd      enddo
6932       endif
6933       eello4=ekont*eel4
6934 cd      write (2,*) 'ekont',ekont
6935 cd      write (iout,*) 'eello4',ekont*eel4
6936       return
6937       end
6938 C---------------------------------------------------------------------------
6939       double precision function eello5(i,j,k,l,jj,kk)
6940       implicit real*8 (a-h,o-z)
6941       include 'DIMENSIONS'
6942       include 'DIMENSIONS.ZSCOPT'
6943       include 'COMMON.IOUNITS'
6944       include 'COMMON.CHAIN'
6945       include 'COMMON.DERIV'
6946       include 'COMMON.INTERACT'
6947       include 'COMMON.CONTACTS'
6948       include 'COMMON.TORSION'
6949       include 'COMMON.VAR'
6950       include 'COMMON.GEO'
6951       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6952       double precision ggg1(3),ggg2(3)
6953 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6954 C                                                                              C
6955 C                            Parallel chains                                   C
6956 C                                                                              C
6957 C          o             o                   o             o                   C
6958 C         /l\           / \             \   / \           / \   /              C
6959 C        /   \         /   \             \ /   \         /   \ /               C
6960 C       j| o |l1       | o |              o| o |         | o |o                C
6961 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6962 C      \i/   \         /   \ /             /   \         /   \                 C
6963 C       o    k1             o                                                  C
6964 C         (I)          (II)                (III)          (IV)                 C
6965 C                                                                              C
6966 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6967 C                                                                              C
6968 C                            Antiparallel chains                               C
6969 C                                                                              C
6970 C          o             o                   o             o                   C
6971 C         /j\           / \             \   / \           / \   /              C
6972 C        /   \         /   \             \ /   \         /   \ /               C
6973 C      j1| o |l        | o |              o| o |         | o |o                C
6974 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6975 C      \i/   \         /   \ /             /   \         /   \                 C
6976 C       o     k1            o                                                  C
6977 C         (I)          (II)                (III)          (IV)                 C
6978 C                                                                              C
6979 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6980 C                                                                              C
6981 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6982 C                                                                              C
6983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6984 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6985 cd        eello5=0.0d0
6986 cd        return
6987 cd      endif
6988 cd      write (iout,*)
6989 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6990 cd     &   ' and',k,l
6991       itk=itortyp(itype(k))
6992       itl=itortyp(itype(l))
6993       itj=itortyp(itype(j))
6994       eello5_1=0.0d0
6995       eello5_2=0.0d0
6996       eello5_3=0.0d0
6997       eello5_4=0.0d0
6998 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6999 cd     &   eel5_3_num,eel5_4_num)
7000       do iii=1,2
7001         do kkk=1,5
7002           do lll=1,3
7003             derx(lll,kkk,iii)=0.0d0
7004           enddo
7005         enddo
7006       enddo
7007 cd      eij=facont_hb(jj,i)
7008 cd      ekl=facont_hb(kk,k)
7009 cd      ekont=eij*ekl
7010 cd      write (iout,*)'Contacts have occurred for peptide groups',
7011 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7012 cd      goto 1111
7013 C Contribution from the graph I.
7014 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7015 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7016       call transpose2(EUg(1,1,k),auxmat(1,1))
7017       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7018       vv(1)=pizda(1,1)-pizda(2,2)
7019       vv(2)=pizda(1,2)+pizda(2,1)
7020       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7021      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7022       if (calc_grad) then
7023 C Explicit gradient in virtual-dihedral angles.
7024       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7025      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7026      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7027       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7028       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7029       vv(1)=pizda(1,1)-pizda(2,2)
7030       vv(2)=pizda(1,2)+pizda(2,1)
7031       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7032      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7033      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7034       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7035       vv(1)=pizda(1,1)-pizda(2,2)
7036       vv(2)=pizda(1,2)+pizda(2,1)
7037       if (l.eq.j+1) then
7038         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7039      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7040      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7041       else
7042         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7043      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7044      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7045       endif
7046 C Cartesian gradient
7047       do iii=1,2
7048         do kkk=1,5
7049           do lll=1,3
7050             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7051      &        pizda(1,1))
7052             vv(1)=pizda(1,1)-pizda(2,2)
7053             vv(2)=pizda(1,2)+pizda(2,1)
7054             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7055      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7056      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7057           enddo
7058         enddo
7059       enddo
7060 c      goto 1112
7061       endif
7062 c1111  continue
7063 C Contribution from graph II
7064       call transpose2(EE(1,1,itk),auxmat(1,1))
7065       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7066       vv(1)=pizda(1,1)+pizda(2,2)
7067       vv(2)=pizda(2,1)-pizda(1,2)
7068       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7069      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7070       if (calc_grad) then
7071 C Explicit gradient in virtual-dihedral angles.
7072       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7073      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7074       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7075       vv(1)=pizda(1,1)+pizda(2,2)
7076       vv(2)=pizda(2,1)-pizda(1,2)
7077       if (l.eq.j+1) then
7078         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7079      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7080      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7081       else
7082         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7083      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7084      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7085       endif
7086 C Cartesian gradient
7087       do iii=1,2
7088         do kkk=1,5
7089           do lll=1,3
7090             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7091      &        pizda(1,1))
7092             vv(1)=pizda(1,1)+pizda(2,2)
7093             vv(2)=pizda(2,1)-pizda(1,2)
7094             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7095      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7096      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7097           enddo
7098         enddo
7099       enddo
7100 cd      goto 1112
7101       endif
7102 cd1111  continue
7103       if (l.eq.j+1) then
7104 cd        goto 1110
7105 C Parallel orientation
7106 C Contribution from graph III
7107         call transpose2(EUg(1,1,l),auxmat(1,1))
7108         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7109         vv(1)=pizda(1,1)-pizda(2,2)
7110         vv(2)=pizda(1,2)+pizda(2,1)
7111         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7112      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7113         if (calc_grad) then
7114 C Explicit gradient in virtual-dihedral angles.
7115         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7116      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7117      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7118         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7119         vv(1)=pizda(1,1)-pizda(2,2)
7120         vv(2)=pizda(1,2)+pizda(2,1)
7121         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7122      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7123      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7124         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7125         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7126         vv(1)=pizda(1,1)-pizda(2,2)
7127         vv(2)=pizda(1,2)+pizda(2,1)
7128         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7129      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7130      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7131 C Cartesian gradient
7132         do iii=1,2
7133           do kkk=1,5
7134             do lll=1,3
7135               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7136      &          pizda(1,1))
7137               vv(1)=pizda(1,1)-pizda(2,2)
7138               vv(2)=pizda(1,2)+pizda(2,1)
7139               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7140      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7141      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7142             enddo
7143           enddo
7144         enddo
7145 cd        goto 1112
7146         endif
7147 C Contribution from graph IV
7148 cd1110    continue
7149         call transpose2(EE(1,1,itl),auxmat(1,1))
7150         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7151         vv(1)=pizda(1,1)+pizda(2,2)
7152         vv(2)=pizda(2,1)-pizda(1,2)
7153         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7154      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7155         if (calc_grad) then
7156 C Explicit gradient in virtual-dihedral angles.
7157         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7158      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7159         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7160         vv(1)=pizda(1,1)+pizda(2,2)
7161         vv(2)=pizda(2,1)-pizda(1,2)
7162         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7163      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7164      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7165 C Cartesian gradient
7166         do iii=1,2
7167           do kkk=1,5
7168             do lll=1,3
7169               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7170      &          pizda(1,1))
7171               vv(1)=pizda(1,1)+pizda(2,2)
7172               vv(2)=pizda(2,1)-pizda(1,2)
7173               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7174      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7175      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7176             enddo
7177           enddo
7178         enddo
7179         endif
7180       else
7181 C Antiparallel orientation
7182 C Contribution from graph III
7183 c        goto 1110
7184         call transpose2(EUg(1,1,j),auxmat(1,1))
7185         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7186         vv(1)=pizda(1,1)-pizda(2,2)
7187         vv(2)=pizda(1,2)+pizda(2,1)
7188         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7189      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7190         if (calc_grad) then
7191 C Explicit gradient in virtual-dihedral angles.
7192         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7193      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7194      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7195         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7196         vv(1)=pizda(1,1)-pizda(2,2)
7197         vv(2)=pizda(1,2)+pizda(2,1)
7198         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7199      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7200      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7201         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7202         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7203         vv(1)=pizda(1,1)-pizda(2,2)
7204         vv(2)=pizda(1,2)+pizda(2,1)
7205         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7206      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7207      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7208 C Cartesian gradient
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7213      &          pizda(1,1))
7214               vv(1)=pizda(1,1)-pizda(2,2)
7215               vv(2)=pizda(1,2)+pizda(2,1)
7216               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7217      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7218      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7219             enddo
7220           enddo
7221         enddo
7222 cd        goto 1112
7223         endif
7224 C Contribution from graph IV
7225 1110    continue
7226         call transpose2(EE(1,1,itj),auxmat(1,1))
7227         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7228         vv(1)=pizda(1,1)+pizda(2,2)
7229         vv(2)=pizda(2,1)-pizda(1,2)
7230         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7231      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7232         if (calc_grad) then
7233 C Explicit gradient in virtual-dihedral angles.
7234         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7235      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7236         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7237         vv(1)=pizda(1,1)+pizda(2,2)
7238         vv(2)=pizda(2,1)-pizda(1,2)
7239         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7240      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7241      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7242 C Cartesian gradient
7243         do iii=1,2
7244           do kkk=1,5
7245             do lll=1,3
7246               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7247      &          pizda(1,1))
7248               vv(1)=pizda(1,1)+pizda(2,2)
7249               vv(2)=pizda(2,1)-pizda(1,2)
7250               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7251      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7252      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7253             enddo
7254           enddo
7255         enddo
7256       endif
7257       endif
7258 1112  continue
7259       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7260 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7261 cd        write (2,*) 'ijkl',i,j,k,l
7262 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7263 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7264 cd      endif
7265 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7266 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7267 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7268 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7269       if (calc_grad) then
7270       if (j.lt.nres-1) then
7271         j1=j+1
7272         j2=j-1
7273       else
7274         j1=j-1
7275         j2=j-2
7276       endif
7277       if (l.lt.nres-1) then
7278         l1=l+1
7279         l2=l-1
7280       else
7281         l1=l-1
7282         l2=l-2
7283       endif
7284 cd      eij=1.0d0
7285 cd      ekl=1.0d0
7286 cd      ekont=1.0d0
7287 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7288       do ll=1,3
7289         ggg1(ll)=eel5*g_contij(ll,1)
7290         ggg2(ll)=eel5*g_contij(ll,2)
7291 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7292         ghalf=0.5d0*ggg1(ll)
7293 cd        ghalf=0.0d0
7294         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7295         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7296         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7297         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7298 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7299         ghalf=0.5d0*ggg2(ll)
7300 cd        ghalf=0.0d0
7301         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7302         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7303         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7304         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7305       enddo
7306 cd      goto 1112
7307       do m=i+1,j-1
7308         do ll=1,3
7309 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7310           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7311         enddo
7312       enddo
7313       do m=k+1,l-1
7314         do ll=1,3
7315 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7316           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7317         enddo
7318       enddo
7319 c1112  continue
7320       do m=i+2,j2
7321         do ll=1,3
7322           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7323         enddo
7324       enddo
7325       do m=k+2,l2
7326         do ll=1,3
7327           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7328         enddo
7329       enddo
7330 cd      do iii=1,nres-3
7331 cd        write (2,*) iii,g_corr5_loc(iii)
7332 cd      enddo
7333       endif
7334       eello5=ekont*eel5
7335 cd      write (2,*) 'ekont',ekont
7336 cd      write (iout,*) 'eello5',ekont*eel5
7337       return
7338       end
7339 c--------------------------------------------------------------------------
7340       double precision function eello6(i,j,k,l,jj,kk)
7341       implicit real*8 (a-h,o-z)
7342       include 'DIMENSIONS'
7343       include 'DIMENSIONS.ZSCOPT'
7344       include 'COMMON.IOUNITS'
7345       include 'COMMON.CHAIN'
7346       include 'COMMON.DERIV'
7347       include 'COMMON.INTERACT'
7348       include 'COMMON.CONTACTS'
7349       include 'COMMON.TORSION'
7350       include 'COMMON.VAR'
7351       include 'COMMON.GEO'
7352       include 'COMMON.FFIELD'
7353       double precision ggg1(3),ggg2(3)
7354 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7355 cd        eello6=0.0d0
7356 cd        return
7357 cd      endif
7358 cd      write (iout,*)
7359 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7360 cd     &   ' and',k,l
7361       eello6_1=0.0d0
7362       eello6_2=0.0d0
7363       eello6_3=0.0d0
7364       eello6_4=0.0d0
7365       eello6_5=0.0d0
7366       eello6_6=0.0d0
7367 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7368 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7369       do iii=1,2
7370         do kkk=1,5
7371           do lll=1,3
7372             derx(lll,kkk,iii)=0.0d0
7373           enddo
7374         enddo
7375       enddo
7376 cd      eij=facont_hb(jj,i)
7377 cd      ekl=facont_hb(kk,k)
7378 cd      ekont=eij*ekl
7379 cd      eij=1.0d0
7380 cd      ekl=1.0d0
7381 cd      ekont=1.0d0
7382       if (l.eq.j+1) then
7383         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7384         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7385         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7386         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7387         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7388         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7389       else
7390         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7391         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7392         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7393         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7394         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7395           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7396         else
7397           eello6_5=0.0d0
7398         endif
7399         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7400       endif
7401 C If turn contributions are considered, they will be handled separately.
7402       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7403 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7404 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7405 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7406 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7407 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7408 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7409 cd      goto 1112
7410       if (calc_grad) then
7411       if (j.lt.nres-1) then
7412         j1=j+1
7413         j2=j-1
7414       else
7415         j1=j-1
7416         j2=j-2
7417       endif
7418       if (l.lt.nres-1) then
7419         l1=l+1
7420         l2=l-1
7421       else
7422         l1=l-1
7423         l2=l-2
7424       endif
7425       do ll=1,3
7426         ggg1(ll)=eel6*g_contij(ll,1)
7427         ggg2(ll)=eel6*g_contij(ll,2)
7428 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7429         ghalf=0.5d0*ggg1(ll)
7430 cd        ghalf=0.0d0
7431         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7432         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7433         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7434         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7435         ghalf=0.5d0*ggg2(ll)
7436 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7437 cd        ghalf=0.0d0
7438         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7439         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7440         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7441         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7442       enddo
7443 cd      goto 1112
7444       do m=i+1,j-1
7445         do ll=1,3
7446 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7447           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7448         enddo
7449       enddo
7450       do m=k+1,l-1
7451         do ll=1,3
7452 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7453           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7454         enddo
7455       enddo
7456 1112  continue
7457       do m=i+2,j2
7458         do ll=1,3
7459           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7460         enddo
7461       enddo
7462       do m=k+2,l2
7463         do ll=1,3
7464           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7465         enddo
7466       enddo
7467 cd      do iii=1,nres-3
7468 cd        write (2,*) iii,g_corr6_loc(iii)
7469 cd      enddo
7470       endif
7471       eello6=ekont*eel6
7472 cd      write (2,*) 'ekont',ekont
7473 cd      write (iout,*) 'eello6',ekont*eel6
7474       return
7475       end
7476 c--------------------------------------------------------------------------
7477       double precision function eello6_graph1(i,j,k,l,imat,swap)
7478       implicit real*8 (a-h,o-z)
7479       include 'DIMENSIONS'
7480       include 'DIMENSIONS.ZSCOPT'
7481       include 'COMMON.IOUNITS'
7482       include 'COMMON.CHAIN'
7483       include 'COMMON.DERIV'
7484       include 'COMMON.INTERACT'
7485       include 'COMMON.CONTACTS'
7486       include 'COMMON.TORSION'
7487       include 'COMMON.VAR'
7488       include 'COMMON.GEO'
7489       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7490       logical swap
7491       logical lprn
7492       common /kutas/ lprn
7493 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7494 C                                                                              C
7495 C      Parallel       Antiparallel                                             C
7496 C                                                                              C
7497 C          o             o                                                     C
7498 C         /l\           /j\                                                    C
7499 C        /   \         /   \                                                   C
7500 C       /| o |         | o |\                                                  C
7501 C     \ j|/k\|  /   \  |/k\|l /                                                C
7502 C      \ /   \ /     \ /   \ /                                                 C
7503 C       o     o       o     o                                                  C
7504 C       i             i                                                        C
7505 C                                                                              C
7506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7507       itk=itortyp(itype(k))
7508       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7509       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7510       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7511       call transpose2(EUgC(1,1,k),auxmat(1,1))
7512       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7513       vv1(1)=pizda1(1,1)-pizda1(2,2)
7514       vv1(2)=pizda1(1,2)+pizda1(2,1)
7515       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7516       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7517       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7518       s5=scalar2(vv(1),Dtobr2(1,i))
7519 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7520       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7521       if (.not. calc_grad) return
7522       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7523      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7524      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7525      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7526      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7527      & +scalar2(vv(1),Dtobr2der(1,i)))
7528       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7529       vv1(1)=pizda1(1,1)-pizda1(2,2)
7530       vv1(2)=pizda1(1,2)+pizda1(2,1)
7531       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7532       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7533       if (l.eq.j+1) then
7534         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7535      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7536      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7537      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7538      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7539       else
7540         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7541      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7542      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7543      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7544      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7545       endif
7546       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7547       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7548       vv1(1)=pizda1(1,1)-pizda1(2,2)
7549       vv1(2)=pizda1(1,2)+pizda1(2,1)
7550       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7551      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7552      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7553      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7554       do iii=1,2
7555         if (swap) then
7556           ind=3-iii
7557         else
7558           ind=iii
7559         endif
7560         do kkk=1,5
7561           do lll=1,3
7562             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7563             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7564             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7565             call transpose2(EUgC(1,1,k),auxmat(1,1))
7566             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7567      &        pizda1(1,1))
7568             vv1(1)=pizda1(1,1)-pizda1(2,2)
7569             vv1(2)=pizda1(1,2)+pizda1(2,1)
7570             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7571             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7572      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7573             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7574      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7575             s5=scalar2(vv(1),Dtobr2(1,i))
7576             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7577           enddo
7578         enddo
7579       enddo
7580       return
7581       end
7582 c----------------------------------------------------------------------------
7583       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7584       implicit real*8 (a-h,o-z)
7585       include 'DIMENSIONS'
7586       include 'DIMENSIONS.ZSCOPT'
7587       include 'COMMON.IOUNITS'
7588       include 'COMMON.CHAIN'
7589       include 'COMMON.DERIV'
7590       include 'COMMON.INTERACT'
7591       include 'COMMON.CONTACTS'
7592       include 'COMMON.TORSION'
7593       include 'COMMON.VAR'
7594       include 'COMMON.GEO'
7595       logical swap
7596       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7597      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7598       logical lprn
7599       common /kutas/ lprn
7600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7601 C                                                                              C
7602 C      Parallel       Antiparallel                                             C
7603 C                                                                              C
7604 C          o             o                                                     C
7605 C     \   /l\           /j\   /                                                C
7606 C      \ /   \         /   \ /                                                 C
7607 C       o| o |         | o |o                                                  C
7608 C     \ j|/k\|      \  |/k\|l                                                  C
7609 C      \ /   \       \ /   \                                                   C
7610 C       o             o                                                        C
7611 C       i             i                                                        C
7612 C                                                                              C
7613 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7614 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7615 C AL 7/4/01 s1 would occur in the sixth-order moment,
7616 C           but not in a cluster cumulant
7617 #ifdef MOMENT
7618       s1=dip(1,jj,i)*dip(1,kk,k)
7619 #endif
7620       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7621       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7622       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7623       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7624       call transpose2(EUg(1,1,k),auxmat(1,1))
7625       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7626       vv(1)=pizda(1,1)-pizda(2,2)
7627       vv(2)=pizda(1,2)+pizda(2,1)
7628       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7629 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7630 #ifdef MOMENT
7631       eello6_graph2=-(s1+s2+s3+s4)
7632 #else
7633       eello6_graph2=-(s2+s3+s4)
7634 #endif
7635 c      eello6_graph2=-s3
7636       if (.not. calc_grad) return
7637 C Derivatives in gamma(i-1)
7638       if (i.gt.1) then
7639 #ifdef MOMENT
7640         s1=dipderg(1,jj,i)*dip(1,kk,k)
7641 #endif
7642         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7643         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7644         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7645         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7646 #ifdef MOMENT
7647         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7648 #else
7649         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7650 #endif
7651 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7652       endif
7653 C Derivatives in gamma(k-1)
7654 #ifdef MOMENT
7655       s1=dip(1,jj,i)*dipderg(1,kk,k)
7656 #endif
7657       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7658       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7659       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7660       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7661       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7662       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7663       vv(1)=pizda(1,1)-pizda(2,2)
7664       vv(2)=pizda(1,2)+pizda(2,1)
7665       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7666 #ifdef MOMENT
7667       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7668 #else
7669       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7670 #endif
7671 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7672 C Derivatives in gamma(j-1) or gamma(l-1)
7673       if (j.gt.1) then
7674 #ifdef MOMENT
7675         s1=dipderg(3,jj,i)*dip(1,kk,k)
7676 #endif
7677         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7678         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7679         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7680         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7681         vv(1)=pizda(1,1)-pizda(2,2)
7682         vv(2)=pizda(1,2)+pizda(2,1)
7683         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7684 #ifdef MOMENT
7685         if (swap) then
7686           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7687         else
7688           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7689         endif
7690 #endif
7691         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7692 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7693       endif
7694 C Derivatives in gamma(l-1) or gamma(j-1)
7695       if (l.gt.1) then
7696 #ifdef MOMENT
7697         s1=dip(1,jj,i)*dipderg(3,kk,k)
7698 #endif
7699         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7700         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7701         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7702         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7703         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7704         vv(1)=pizda(1,1)-pizda(2,2)
7705         vv(2)=pizda(1,2)+pizda(2,1)
7706         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7707 #ifdef MOMENT
7708         if (swap) then
7709           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7710         else
7711           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7712         endif
7713 #endif
7714         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7715 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7716       endif
7717 C Cartesian derivatives.
7718       if (lprn) then
7719         write (2,*) 'In eello6_graph2'
7720         do iii=1,2
7721           write (2,*) 'iii=',iii
7722           do kkk=1,5
7723             write (2,*) 'kkk=',kkk
7724             do jjj=1,2
7725               write (2,'(3(2f10.5),5x)')
7726      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7727             enddo
7728           enddo
7729         enddo
7730       endif
7731       do iii=1,2
7732         do kkk=1,5
7733           do lll=1,3
7734 #ifdef MOMENT
7735             if (iii.eq.1) then
7736               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7737             else
7738               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7739             endif
7740 #endif
7741             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7742      &        auxvec(1))
7743             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7744             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7745      &        auxvec(1))
7746             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7747             call transpose2(EUg(1,1,k),auxmat(1,1))
7748             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7749      &        pizda(1,1))
7750             vv(1)=pizda(1,1)-pizda(2,2)
7751             vv(2)=pizda(1,2)+pizda(2,1)
7752             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7753 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7754 #ifdef MOMENT
7755             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7756 #else
7757             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7758 #endif
7759             if (swap) then
7760               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7761             else
7762               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7763             endif
7764           enddo
7765         enddo
7766       enddo
7767       return
7768       end
7769 c----------------------------------------------------------------------------
7770       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7771       implicit real*8 (a-h,o-z)
7772       include 'DIMENSIONS'
7773       include 'DIMENSIONS.ZSCOPT'
7774       include 'COMMON.IOUNITS'
7775       include 'COMMON.CHAIN'
7776       include 'COMMON.DERIV'
7777       include 'COMMON.INTERACT'
7778       include 'COMMON.CONTACTS'
7779       include 'COMMON.TORSION'
7780       include 'COMMON.VAR'
7781       include 'COMMON.GEO'
7782       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7783       logical swap
7784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7785 C                                                                              C
7786 C      Parallel       Antiparallel                                             C
7787 C                                                                              C
7788 C          o             o                                                     C
7789 C         /l\   /   \   /j\                                                    C
7790 C        /   \ /     \ /   \                                                   C
7791 C       /| o |o       o| o |\                                                  C
7792 C       j|/k\|  /      |/k\|l /                                                C
7793 C        /   \ /       /   \ /                                                 C
7794 C       /     o       /     o                                                  C
7795 C       i             i                                                        C
7796 C                                                                              C
7797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7798 C
7799 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7800 C           energy moment and not to the cluster cumulant.
7801       iti=itortyp(itype(i))
7802       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7803         itj1=itortyp(itype(j+1))
7804       else
7805         itj1=ntortyp+1
7806       endif
7807       itk=itortyp(itype(k))
7808       itk1=itortyp(itype(k+1))
7809       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7810         itl1=itortyp(itype(l+1))
7811       else
7812         itl1=ntortyp+1
7813       endif
7814 #ifdef MOMENT
7815       s1=dip(4,jj,i)*dip(4,kk,k)
7816 #endif
7817       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7818       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7819       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7820       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7821       call transpose2(EE(1,1,itk),auxmat(1,1))
7822       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7823       vv(1)=pizda(1,1)+pizda(2,2)
7824       vv(2)=pizda(2,1)-pizda(1,2)
7825       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7826 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7827 #ifdef MOMENT
7828       eello6_graph3=-(s1+s2+s3+s4)
7829 #else
7830       eello6_graph3=-(s2+s3+s4)
7831 #endif
7832 c      eello6_graph3=-s4
7833       if (.not. calc_grad) return
7834 C Derivatives in gamma(k-1)
7835       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7836       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7837       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7838       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7839 C Derivatives in gamma(l-1)
7840       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7841       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7842       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7843       vv(1)=pizda(1,1)+pizda(2,2)
7844       vv(2)=pizda(2,1)-pizda(1,2)
7845       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7846       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7847 C Cartesian derivatives.
7848       do iii=1,2
7849         do kkk=1,5
7850           do lll=1,3
7851 #ifdef MOMENT
7852             if (iii.eq.1) then
7853               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7854             else
7855               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7856             endif
7857 #endif
7858             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7859      &        auxvec(1))
7860             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7861             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7862      &        auxvec(1))
7863             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7864             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7865      &        pizda(1,1))
7866             vv(1)=pizda(1,1)+pizda(2,2)
7867             vv(2)=pizda(2,1)-pizda(1,2)
7868             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7869 #ifdef MOMENT
7870             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7871 #else
7872             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7873 #endif
7874             if (swap) then
7875               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7876             else
7877               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7878             endif
7879 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7880           enddo
7881         enddo
7882       enddo
7883       return
7884       end
7885 c----------------------------------------------------------------------------
7886       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7887       implicit real*8 (a-h,o-z)
7888       include 'DIMENSIONS'
7889       include 'DIMENSIONS.ZSCOPT'
7890       include 'COMMON.IOUNITS'
7891       include 'COMMON.CHAIN'
7892       include 'COMMON.DERIV'
7893       include 'COMMON.INTERACT'
7894       include 'COMMON.CONTACTS'
7895       include 'COMMON.TORSION'
7896       include 'COMMON.VAR'
7897       include 'COMMON.GEO'
7898       include 'COMMON.FFIELD'
7899       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7900      & auxvec1(2),auxmat1(2,2)
7901       logical swap
7902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7903 C                                                                              C
7904 C      Parallel       Antiparallel                                             C
7905 C                                                                              C
7906 C          o             o                                                     C
7907 C         /l\   /   \   /j\                                                    C
7908 C        /   \ /     \ /   \                                                   C
7909 C       /| o |o       o| o |\                                                  C
7910 C     \ j|/k\|      \  |/k\|l                                                  C
7911 C      \ /   \       \ /   \                                                   C
7912 C       o     \       o     \                                                  C
7913 C       i             i                                                        C
7914 C                                                                              C
7915 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7916 C
7917 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7918 C           energy moment and not to the cluster cumulant.
7919 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7920       iti=itortyp(itype(i))
7921       itj=itortyp(itype(j))
7922       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7923         itj1=itortyp(itype(j+1))
7924       else
7925         itj1=ntortyp+1
7926       endif
7927       itk=itortyp(itype(k))
7928       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7929         itk1=itortyp(itype(k+1))
7930       else
7931         itk1=ntortyp+1
7932       endif
7933       itl=itortyp(itype(l))
7934       if (l.lt.nres-1) then
7935         itl1=itortyp(itype(l+1))
7936       else
7937         itl1=ntortyp+1
7938       endif
7939 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7940 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7941 cd     & ' itl',itl,' itl1',itl1
7942 #ifdef MOMENT
7943       if (imat.eq.1) then
7944         s1=dip(3,jj,i)*dip(3,kk,k)
7945       else
7946         s1=dip(2,jj,j)*dip(2,kk,l)
7947       endif
7948 #endif
7949       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7950       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7951       if (j.eq.l+1) then
7952         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7953         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7954       else
7955         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7956         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7957       endif
7958       call transpose2(EUg(1,1,k),auxmat(1,1))
7959       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7960       vv(1)=pizda(1,1)-pizda(2,2)
7961       vv(2)=pizda(2,1)+pizda(1,2)
7962       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7963 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7964 #ifdef MOMENT
7965       eello6_graph4=-(s1+s2+s3+s4)
7966 #else
7967       eello6_graph4=-(s2+s3+s4)
7968 #endif
7969       if (.not. calc_grad) return
7970 C Derivatives in gamma(i-1)
7971       if (i.gt.1) then
7972 #ifdef MOMENT
7973         if (imat.eq.1) then
7974           s1=dipderg(2,jj,i)*dip(3,kk,k)
7975         else
7976           s1=dipderg(4,jj,j)*dip(2,kk,l)
7977         endif
7978 #endif
7979         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7980         if (j.eq.l+1) then
7981           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7982           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7983         else
7984           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7985           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7986         endif
7987         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7988         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7989 cd          write (2,*) 'turn6 derivatives'
7990 #ifdef MOMENT
7991           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7992 #else
7993           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7994 #endif
7995         else
7996 #ifdef MOMENT
7997           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7998 #else
7999           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8000 #endif
8001         endif
8002       endif
8003 C Derivatives in gamma(k-1)
8004 #ifdef MOMENT
8005       if (imat.eq.1) then
8006         s1=dip(3,jj,i)*dipderg(2,kk,k)
8007       else
8008         s1=dip(2,jj,j)*dipderg(4,kk,l)
8009       endif
8010 #endif
8011       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8012       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8013       if (j.eq.l+1) then
8014         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8015         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8016       else
8017         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8018         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8019       endif
8020       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8021       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8022       vv(1)=pizda(1,1)-pizda(2,2)
8023       vv(2)=pizda(2,1)+pizda(1,2)
8024       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8025       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8026 #ifdef MOMENT
8027         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8028 #else
8029         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8030 #endif
8031       else
8032 #ifdef MOMENT
8033         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8034 #else
8035         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8036 #endif
8037       endif
8038 C Derivatives in gamma(j-1) or gamma(l-1)
8039       if (l.eq.j+1 .and. l.gt.1) then
8040         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8041         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8042         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8043         vv(1)=pizda(1,1)-pizda(2,2)
8044         vv(2)=pizda(2,1)+pizda(1,2)
8045         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8046         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8047       else if (j.gt.1) then
8048         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8049         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8050         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8051         vv(1)=pizda(1,1)-pizda(2,2)
8052         vv(2)=pizda(2,1)+pizda(1,2)
8053         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8054         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8055           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8056         else
8057           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8058         endif
8059       endif
8060 C Cartesian derivatives.
8061       do iii=1,2
8062         do kkk=1,5
8063           do lll=1,3
8064 #ifdef MOMENT
8065             if (iii.eq.1) then
8066               if (imat.eq.1) then
8067                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8068               else
8069                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8070               endif
8071             else
8072               if (imat.eq.1) then
8073                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8074               else
8075                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8076               endif
8077             endif
8078 #endif
8079             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8080      &        auxvec(1))
8081             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8082             if (j.eq.l+1) then
8083               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8084      &          b1(1,itj1),auxvec(1))
8085               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8086             else
8087               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8088      &          b1(1,itl1),auxvec(1))
8089               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8090             endif
8091             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8092      &        pizda(1,1))
8093             vv(1)=pizda(1,1)-pizda(2,2)
8094             vv(2)=pizda(2,1)+pizda(1,2)
8095             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8096             if (swap) then
8097               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8098 #ifdef MOMENT
8099                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8100      &             -(s1+s2+s4)
8101 #else
8102                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8103      &             -(s2+s4)
8104 #endif
8105                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8106               else
8107 #ifdef MOMENT
8108                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8109 #else
8110                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8111 #endif
8112                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8113               endif
8114             else
8115 #ifdef MOMENT
8116               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8117 #else
8118               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8119 #endif
8120               if (l.eq.j+1) then
8121                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8122               else
8123                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8124               endif
8125             endif
8126           enddo
8127         enddo
8128       enddo
8129       return
8130       end
8131 c----------------------------------------------------------------------------
8132       double precision function eello_turn6(i,jj,kk)
8133       implicit real*8 (a-h,o-z)
8134       include 'DIMENSIONS'
8135       include 'DIMENSIONS.ZSCOPT'
8136       include 'COMMON.IOUNITS'
8137       include 'COMMON.CHAIN'
8138       include 'COMMON.DERIV'
8139       include 'COMMON.INTERACT'
8140       include 'COMMON.CONTACTS'
8141       include 'COMMON.TORSION'
8142       include 'COMMON.VAR'
8143       include 'COMMON.GEO'
8144       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8145      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8146      &  ggg1(3),ggg2(3)
8147       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8148      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8149 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8150 C           the respective energy moment and not to the cluster cumulant.
8151       eello_turn6=0.0d0
8152       j=i+4
8153       k=i+1
8154       l=i+3
8155       iti=itortyp(itype(i))
8156       itk=itortyp(itype(k))
8157       itk1=itortyp(itype(k+1))
8158       itl=itortyp(itype(l))
8159       itj=itortyp(itype(j))
8160 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8161 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8162 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8163 cd        eello6=0.0d0
8164 cd        return
8165 cd      endif
8166 cd      write (iout,*)
8167 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8168 cd     &   ' and',k,l
8169 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8170       do iii=1,2
8171         do kkk=1,5
8172           do lll=1,3
8173             derx_turn(lll,kkk,iii)=0.0d0
8174           enddo
8175         enddo
8176       enddo
8177 cd      eij=1.0d0
8178 cd      ekl=1.0d0
8179 cd      ekont=1.0d0
8180       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8181 cd      eello6_5=0.0d0
8182 cd      write (2,*) 'eello6_5',eello6_5
8183 #ifdef MOMENT
8184       call transpose2(AEA(1,1,1),auxmat(1,1))
8185       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8186       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8187       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8188 #else
8189       s1 = 0.0d0
8190 #endif
8191       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8192       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8193       s2 = scalar2(b1(1,itk),vtemp1(1))
8194 #ifdef MOMENT
8195       call transpose2(AEA(1,1,2),atemp(1,1))
8196       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8197       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8198       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8199 #else
8200       s8=0.0d0
8201 #endif
8202       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8203       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8204       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8205 #ifdef MOMENT
8206       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8207       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8208       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8209       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8210       ss13 = scalar2(b1(1,itk),vtemp4(1))
8211       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8212 #else
8213       s13=0.0d0
8214 #endif
8215 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8216 c      s1=0.0d0
8217 c      s2=0.0d0
8218 c      s8=0.0d0
8219 c      s12=0.0d0
8220 c      s13=0.0d0
8221       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8222       if (calc_grad) then
8223 C Derivatives in gamma(i+2)
8224 #ifdef MOMENT
8225       call transpose2(AEA(1,1,1),auxmatd(1,1))
8226       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8227       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8228       call transpose2(AEAderg(1,1,2),atempd(1,1))
8229       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8230       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8231 #else
8232       s8d=0.0d0
8233 #endif
8234       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8235       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8236       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8237 c      s1d=0.0d0
8238 c      s2d=0.0d0
8239 c      s8d=0.0d0
8240 c      s12d=0.0d0
8241 c      s13d=0.0d0
8242       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8243 C Derivatives in gamma(i+3)
8244 #ifdef MOMENT
8245       call transpose2(AEA(1,1,1),auxmatd(1,1))
8246       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8247       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8248       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8249 #else
8250       s1d=0.0d0
8251 #endif
8252       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8253       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8254       s2d = scalar2(b1(1,itk),vtemp1d(1))
8255 #ifdef MOMENT
8256       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8257       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8258 #endif
8259       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8260 #ifdef MOMENT
8261       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8262       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8263       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8264 #else
8265       s13d=0.0d0
8266 #endif
8267 c      s1d=0.0d0
8268 c      s2d=0.0d0
8269 c      s8d=0.0d0
8270 c      s12d=0.0d0
8271 c      s13d=0.0d0
8272 #ifdef MOMENT
8273       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8274      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8275 #else
8276       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8277      &               -0.5d0*ekont*(s2d+s12d)
8278 #endif
8279 C Derivatives in gamma(i+4)
8280       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8281       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8282       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8283 #ifdef MOMENT
8284       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8285       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8286       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8287 #else
8288       s13d = 0.0d0
8289 #endif
8290 c      s1d=0.0d0
8291 c      s2d=0.0d0
8292 c      s8d=0.0d0
8293 C      s12d=0.0d0
8294 c      s13d=0.0d0
8295 #ifdef MOMENT
8296       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8297 #else
8298       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8299 #endif
8300 C Derivatives in gamma(i+5)
8301 #ifdef MOMENT
8302       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8303       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8304       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8305 #else
8306       s1d = 0.0d0
8307 #endif
8308       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8309       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8310       s2d = scalar2(b1(1,itk),vtemp1d(1))
8311 #ifdef MOMENT
8312       call transpose2(AEA(1,1,2),atempd(1,1))
8313       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8314       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8315 #else
8316       s8d = 0.0d0
8317 #endif
8318       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8319       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8320 #ifdef MOMENT
8321       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8322       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8323       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8324 #else
8325       s13d = 0.0d0
8326 #endif
8327 c      s1d=0.0d0
8328 c      s2d=0.0d0
8329 c      s8d=0.0d0
8330 c      s12d=0.0d0
8331 c      s13d=0.0d0
8332 #ifdef MOMENT
8333       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8334      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8335 #else
8336       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8337      &               -0.5d0*ekont*(s2d+s12d)
8338 #endif
8339 C Cartesian derivatives
8340       do iii=1,2
8341         do kkk=1,5
8342           do lll=1,3
8343 #ifdef MOMENT
8344             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8345             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8346             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8347 #else
8348             s1d = 0.0d0
8349 #endif
8350             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8351             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8352      &          vtemp1d(1))
8353             s2d = scalar2(b1(1,itk),vtemp1d(1))
8354 #ifdef MOMENT
8355             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8356             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8357             s8d = -(atempd(1,1)+atempd(2,2))*
8358      &           scalar2(cc(1,1,itl),vtemp2(1))
8359 #else
8360             s8d = 0.0d0
8361 #endif
8362             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8363      &           auxmatd(1,1))
8364             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8365             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8366 c      s1d=0.0d0
8367 c      s2d=0.0d0
8368 c      s8d=0.0d0
8369 c      s12d=0.0d0
8370 c      s13d=0.0d0
8371 #ifdef MOMENT
8372             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8373      &        - 0.5d0*(s1d+s2d)
8374 #else
8375             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8376      &        - 0.5d0*s2d
8377 #endif
8378 #ifdef MOMENT
8379             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8380      &        - 0.5d0*(s8d+s12d)
8381 #else
8382             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8383      &        - 0.5d0*s12d
8384 #endif
8385           enddo
8386         enddo
8387       enddo
8388 #ifdef MOMENT
8389       do kkk=1,5
8390         do lll=1,3
8391           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8392      &      achuj_tempd(1,1))
8393           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8394           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8395           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8396           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8397           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8398      &      vtemp4d(1))
8399           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8400           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8401           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8402         enddo
8403       enddo
8404 #endif
8405 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8406 cd     &  16*eel_turn6_num
8407 cd      goto 1112
8408       if (j.lt.nres-1) then
8409         j1=j+1
8410         j2=j-1
8411       else
8412         j1=j-1
8413         j2=j-2
8414       endif
8415       if (l.lt.nres-1) then
8416         l1=l+1
8417         l2=l-1
8418       else
8419         l1=l-1
8420         l2=l-2
8421       endif
8422       do ll=1,3
8423         ggg1(ll)=eel_turn6*g_contij(ll,1)
8424         ggg2(ll)=eel_turn6*g_contij(ll,2)
8425         ghalf=0.5d0*ggg1(ll)
8426 cd        ghalf=0.0d0
8427         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8428      &    +ekont*derx_turn(ll,2,1)
8429         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8430         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8431      &    +ekont*derx_turn(ll,4,1)
8432         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8433         ghalf=0.5d0*ggg2(ll)
8434 cd        ghalf=0.0d0
8435         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8436      &    +ekont*derx_turn(ll,2,2)
8437         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8438         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8439      &    +ekont*derx_turn(ll,4,2)
8440         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8441       enddo
8442 cd      goto 1112
8443       do m=i+1,j-1
8444         do ll=1,3
8445           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8446         enddo
8447       enddo
8448       do m=k+1,l-1
8449         do ll=1,3
8450           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8451         enddo
8452       enddo
8453 1112  continue
8454       do m=i+2,j2
8455         do ll=1,3
8456           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8457         enddo
8458       enddo
8459       do m=k+2,l2
8460         do ll=1,3
8461           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8462         enddo
8463       enddo
8464 cd      do iii=1,nres-3
8465 cd        write (2,*) iii,g_corr6_loc(iii)
8466 cd      enddo
8467       endif
8468       eello_turn6=ekont*eel_turn6
8469 cd      write (2,*) 'ekont',ekont
8470 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8471       return
8472       end
8473 crc-------------------------------------------------
8474       SUBROUTINE MATVEC2(A1,V1,V2)
8475       implicit real*8 (a-h,o-z)
8476       include 'DIMENSIONS'
8477       DIMENSION A1(2,2),V1(2),V2(2)
8478 c      DO 1 I=1,2
8479 c        VI=0.0
8480 c        DO 3 K=1,2
8481 c    3     VI=VI+A1(I,K)*V1(K)
8482 c        Vaux(I)=VI
8483 c    1 CONTINUE
8484
8485       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8486       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8487
8488       v2(1)=vaux1
8489       v2(2)=vaux2
8490       END
8491 C---------------------------------------
8492       SUBROUTINE MATMAT2(A1,A2,A3)
8493       implicit real*8 (a-h,o-z)
8494       include 'DIMENSIONS'
8495       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8496 c      DIMENSION AI3(2,2)
8497 c        DO  J=1,2
8498 c          A3IJ=0.0
8499 c          DO K=1,2
8500 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8501 c          enddo
8502 c          A3(I,J)=A3IJ
8503 c       enddo
8504 c      enddo
8505
8506       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8507       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8508       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8509       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8510
8511       A3(1,1)=AI3_11
8512       A3(2,1)=AI3_21
8513       A3(1,2)=AI3_12
8514       A3(2,2)=AI3_22
8515       END
8516
8517 c-------------------------------------------------------------------------
8518       double precision function scalar2(u,v)
8519       implicit none
8520       double precision u(2),v(2)
8521       double precision sc
8522       integer i
8523       scalar2=u(1)*v(1)+u(2)*v(2)
8524       return
8525       end
8526
8527 C-----------------------------------------------------------------------------
8528
8529       subroutine transpose2(a,at)
8530       implicit none
8531       double precision a(2,2),at(2,2)
8532       at(1,1)=a(1,1)
8533       at(1,2)=a(2,1)
8534       at(2,1)=a(1,2)
8535       at(2,2)=a(2,2)
8536       return
8537       end
8538 c--------------------------------------------------------------------------
8539       subroutine transpose(n,a,at)
8540       implicit none
8541       integer n,i,j
8542       double precision a(n,n),at(n,n)
8543       do i=1,n
8544         do j=1,n
8545           at(j,i)=a(i,j)
8546         enddo
8547       enddo
8548       return
8549       end
8550 C---------------------------------------------------------------------------
8551       subroutine prodmat3(a1,a2,kk,transp,prod)
8552       implicit none
8553       integer i,j
8554       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8555       logical transp
8556 crc      double precision auxmat(2,2),prod_(2,2)
8557
8558       if (transp) then
8559 crc        call transpose2(kk(1,1),auxmat(1,1))
8560 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8561 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8562
8563            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8564      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8565            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8566      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8567            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8568      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8569            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8570      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8571
8572       else
8573 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8574 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8575
8576            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8577      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8578            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8579      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8580            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8581      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8582            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8583      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8584
8585       endif
8586 c      call transpose2(a2(1,1),a2t(1,1))
8587
8588 crc      print *,transp
8589 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8590 crc      print *,((prod(i,j),i=1,2),j=1,2)
8591
8592       return
8593       end
8594 C-----------------------------------------------------------------------------
8595       double precision function scalar(u,v)
8596       implicit none
8597       double precision u(3),v(3)
8598       double precision sc
8599       integer i
8600       sc=0.0d0
8601       do i=1,3
8602         sc=sc+u(i)*v(i)
8603       enddo
8604       scalar=sc
8605       return
8606       end
8607 C-----------------------------------------------------------------------
8608       double precision function sscale(r)
8609       double precision r,gamm
8610       include "COMMON.SPLITELE"
8611       if(r.lt.r_cut-rlamb) then
8612         sscale=1.0d0
8613       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8614         gamm=(r-(r_cut-rlamb))/rlamb
8615         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8616       else
8617         sscale=0d0
8618       endif
8619       return
8620       end
8621 C-----------------------------------------------------------------------
8622 C-----------------------------------------------------------------------
8623       double precision function sscagrad(r)
8624       double precision r,gamm
8625       include "COMMON.SPLITELE"
8626       if(r.lt.r_cut-rlamb) then
8627         sscagrad=0.0d0
8628       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8629         gamm=(r-(r_cut-rlamb))/rlamb
8630         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8631       else
8632         sscagrad=0.0d0
8633       endif
8634       return
8635       end
8636 C-----------------------------------------------------------------------
8637 C-----------------------------------------------------------------------
8638       double precision function sscalelip(r)
8639       double precision r,gamm
8640       include "COMMON.SPLITELE"
8641 C      if(r.lt.r_cut-rlamb) then
8642 C        sscale=1.0d0
8643 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8644 C        gamm=(r-(r_cut-rlamb))/rlamb
8645         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8646 C      else
8647 C        sscale=0d0
8648 C      endif
8649       return
8650       end
8651 C-----------------------------------------------------------------------
8652       double precision function sscagradlip(r)
8653       double precision r,gamm
8654       include "COMMON.SPLITELE"
8655 C     if(r.lt.r_cut-rlamb) then
8656 C        sscagrad=0.0d0
8657 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8658 C        gamm=(r-(r_cut-rlamb))/rlamb
8659         sscagradlip=r*(6*r-6.0d0)
8660 C      else
8661 C        sscagrad=0.0d0
8662 C      endif
8663       return
8664       end
8665 c----------------------------------------------------------------------------
8666       double precision function sscale2(r,r_cut,r0,rlamb)
8667       implicit none
8668       double precision r,gamm,r_cut,r0,rlamb,rr
8669       rr = dabs(r-r0)
8670 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
8671 c      write (2,*) "rr",rr
8672       if(rr.lt.r_cut-rlamb) then
8673         sscale2=1.0d0
8674       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8675         gamm=(rr-(r_cut-rlamb))/rlamb
8676         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8677       else
8678         sscale2=0d0
8679       endif
8680       return
8681       end
8682 C-----------------------------------------------------------------------
8683       double precision function sscalgrad2(r,r_cut,r0,rlamb)
8684       implicit none
8685       double precision r,gamm,r_cut,r0,rlamb,rr
8686       rr = dabs(r-r0)
8687       if(rr.lt.r_cut-rlamb) then
8688         sscalgrad2=0.0d0
8689       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8690         gamm=(rr-(r_cut-rlamb))/rlamb
8691         if (r.ge.r0) then
8692           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
8693         else
8694           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
8695         endif
8696       else
8697         sscalgrad2=0.0d0
8698       endif
8699       return
8700       end
8701 c----------------------------------------------------------------------------
8702       subroutine e_saxs(Esaxs_constr)
8703       implicit none
8704       include 'DIMENSIONS'
8705       include 'DIMENSIONS.ZSCOPT'
8706       include 'DIMENSIONS.FREE'
8707 #ifdef MPI
8708       include "mpif.h"
8709       include "COMMON.SETUP"
8710       integer IERR
8711 #endif
8712       include 'COMMON.SBRIDGE'
8713       include 'COMMON.CHAIN'
8714       include 'COMMON.GEO'
8715       include 'COMMON.LOCAL'
8716       include 'COMMON.INTERACT'
8717       include 'COMMON.VAR'
8718       include 'COMMON.IOUNITS'
8719       include 'COMMON.DERIV'
8720       include 'COMMON.CONTROL'
8721       include 'COMMON.NAMES'
8722       include 'COMMON.FFIELD'
8723       include 'COMMON.LANGEVIN'
8724 c
8725       double precision Esaxs_constr
8726       integer i,iint,j,k,l
8727       double precision PgradC(maxSAXS,3,maxres),
8728      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
8729 #ifdef MPI
8730       double precision PgradC_(maxSAXS,3,maxres),
8731      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
8732 #endif
8733       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
8734      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
8735      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
8736      & auxX,auxX1,CACAgrad,Cnorm
8737       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
8738       double precision dist
8739       external dist
8740 c  SAXS restraint penalty function
8741 #ifdef DEBUG
8742       write(iout,*) "------- SAXS penalty function start -------"
8743       write (iout,*) "nsaxs",nsaxs
8744       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
8745       write (iout,*) "Psaxs"
8746       do i=1,nsaxs
8747         write (iout,'(i5,e15.5)') i, Psaxs(i)
8748       enddo
8749 #endif
8750       Esaxs_constr = 0.0d0
8751       do k=1,nsaxs
8752         Pcalc(k)=0.0d0
8753         do j=1,nres
8754           do l=1,3
8755             PgradC(k,l,j)=0.0d0
8756             PgradX(k,l,j)=0.0d0
8757           enddo
8758         enddo
8759       enddo
8760       do i=iatsc_s,iatsc_e
8761        if (itype(i).eq.ntyp1) cycle
8762        do iint=1,nint_gr(i)
8763          do j=istart(i,iint),iend(i,iint)
8764            if (itype(j).eq.ntyp1) cycle
8765 #ifdef ALLSAXS
8766            dijCACA=dist(i,j)
8767            dijCASC=dist(i,j+nres)
8768            dijSCCA=dist(i+nres,j)
8769            dijSCSC=dist(i+nres,j+nres)
8770            sigma2CACA=2.0d0/(pstok**2)
8771            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
8772            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
8773            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
8774            do k=1,nsaxs
8775              dk = distsaxs(k)
8776              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8777              if (itype(j).ne.10) then
8778              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
8779              else
8780              endif
8781              expCASC = 0.0d0
8782              if (itype(i).ne.10) then
8783              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
8784              else
8785              expSCCA = 0.0d0
8786              endif
8787              if (itype(i).ne.10 .and. itype(j).ne.10) then
8788              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
8789              else
8790              expSCSC = 0.0d0
8791              endif
8792              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
8793 #ifdef DEBUG
8794              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8795 #endif
8796              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8797              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
8798              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
8799              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
8800              do l=1,3
8801 c CA CA
8802                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8803                PgradC(k,l,i) = PgradC(k,l,i)-aux
8804                PgradC(k,l,j) = PgradC(k,l,j)+aux
8805 c CA SC
8806                if (itype(j).ne.10) then
8807                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
8808                PgradC(k,l,i) = PgradC(k,l,i)-aux
8809                PgradC(k,l,j) = PgradC(k,l,j)+aux
8810                PgradX(k,l,j) = PgradX(k,l,j)+aux
8811                endif
8812 c SC CA
8813                if (itype(i).ne.10) then
8814                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
8815                PgradX(k,l,i) = PgradX(k,l,i)-aux
8816                PgradC(k,l,i) = PgradC(k,l,i)-aux
8817                PgradC(k,l,j) = PgradC(k,l,j)+aux
8818                endif
8819 c SC SC
8820                if (itype(i).ne.10 .and. itype(j).ne.10) then
8821                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
8822                PgradC(k,l,i) = PgradC(k,l,i)-aux
8823                PgradC(k,l,j) = PgradC(k,l,j)+aux
8824                PgradX(k,l,i) = PgradX(k,l,i)-aux
8825                PgradX(k,l,j) = PgradX(k,l,j)+aux
8826                endif
8827              enddo ! l
8828            enddo ! k
8829 #else
8830            dijCACA=dist(i,j)
8831            sigma2CACA=scal_rad**2*0.25d0/
8832      &        (restok(itype(j))**2+restok(itype(i))**2)
8833
8834            IF (saxs_cutoff.eq.0) THEN
8835            do k=1,nsaxs
8836              dk = distsaxs(k)
8837              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8838              Pcalc(k) = Pcalc(k)+expCACA
8839              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8840              do l=1,3
8841                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8842                PgradC(k,l,i) = PgradC(k,l,i)-aux
8843                PgradC(k,l,j) = PgradC(k,l,j)+aux
8844              enddo ! l
8845            enddo ! k
8846            ELSE
8847            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
8848            do k=1,nsaxs
8849              dk = distsaxs(k)
8850 c             write (2,*) "ijk",i,j,k
8851              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
8852              if (sss2.eq.0.0d0) cycle
8853              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
8854              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
8855              Pcalc(k) = Pcalc(k)+expCACA
8856 #ifdef DEBUG
8857              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8858 #endif
8859              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
8860      &             ssgrad2*expCACA/sss2
8861              do l=1,3
8862 c CA CA
8863                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8864                PgradC(k,l,i) = PgradC(k,l,i)+aux
8865                PgradC(k,l,j) = PgradC(k,l,j)-aux
8866              enddo ! l
8867            enddo ! k
8868            ENDIF
8869 #endif
8870          enddo ! j
8871        enddo ! iint
8872       enddo ! i
8873 #ifdef MPI
8874       if (nfgtasks.gt.1) then
8875         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
8876      &    MPI_SUM,king,FG_COMM,IERR)
8877         if (fg_rank.eq.king) then
8878           do k=1,nsaxs
8879             Pcalc(k) = Pcalc_(k)
8880           enddo
8881         endif
8882         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
8883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8884         if (fg_rank.eq.king) then
8885           do i=1,nres
8886             do l=1,3
8887               do k=1,nsaxs
8888                 PgradC(k,l,i) = PgradC_(k,l,i)
8889               enddo
8890             enddo
8891           enddo
8892         endif
8893 #ifdef ALLSAXS
8894         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
8895      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8896         if (fg_rank.eq.king) then
8897           do i=1,nres
8898             do l=1,3
8899               do k=1,nsaxs
8900                 PgradX(k,l,i) = PgradX_(k,l,i)
8901               enddo
8902             enddo
8903           enddo
8904         endif
8905 #endif
8906       endif
8907 #endif
8908 #ifdef MPI
8909       if (fg_rank.eq.king) then
8910 #endif
8911       Cnorm = 0.0d0
8912       do k=1,nsaxs
8913         Cnorm = Cnorm + Pcalc(k)
8914       enddo
8915       Esaxs_constr = dlog(Cnorm)-wsaxs0
8916       do k=1,nsaxs
8917         if (Pcalc(k).gt.0.0d0)
8918      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
8919 #ifdef DEBUG
8920         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
8921 #endif
8922       enddo
8923 #ifdef DEBUG
8924       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
8925 #endif
8926       do i=nnt,nct
8927         do l=1,3
8928           auxC=0.0d0
8929           auxC1=0.0d0
8930           auxX=0.0d0
8931           auxX1=0.d0
8932           do k=1,nsaxs
8933             if (Pcalc(k).gt.0)
8934      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
8935             auxC1 = auxC1+PgradC(k,l,i)
8936 #ifdef ALLSAXS
8937             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
8938             auxX1 = auxX1+PgradX(k,l,i)
8939 #endif
8940           enddo
8941           gsaxsC(l,i) = auxC - auxC1/Cnorm
8942 #ifdef ALLSAXS
8943           gsaxsX(l,i) = auxX - auxX1/Cnorm
8944 #endif
8945 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
8946 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
8947         enddo
8948       enddo
8949 #ifdef MPI
8950       endif
8951 #endif
8952       return
8953       end
8954 c----------------------------------------------------------------------------
8955       subroutine e_saxsC(Esaxs_constr)
8956       implicit none
8957       include 'DIMENSIONS'
8958       include 'DIMENSIONS.ZSCOPT'
8959       include 'DIMENSIONS.FREE'
8960 #ifdef MPI
8961       include "mpif.h"
8962       include "COMMON.SETUP"
8963       integer IERR
8964 #endif
8965       include 'COMMON.SBRIDGE'
8966       include 'COMMON.CHAIN'
8967       include 'COMMON.GEO'
8968       include 'COMMON.LOCAL'
8969       include 'COMMON.INTERACT'
8970       include 'COMMON.VAR'
8971       include 'COMMON.IOUNITS'
8972       include 'COMMON.DERIV'
8973       include 'COMMON.CONTROL'
8974       include 'COMMON.NAMES'
8975       include 'COMMON.FFIELD'
8976       include 'COMMON.LANGEVIN'
8977 c
8978       double precision Esaxs_constr
8979       integer i,iint,j,k,l
8980       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
8981 #ifdef MPI
8982       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
8983 #endif
8984       double precision dk,dijCASPH,dijSCSPH,
8985      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
8986      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
8987      & auxX,auxX1,Cnorm
8988 c  SAXS restraint penalty function
8989 #ifdef DEBUG
8990       write(iout,*) "------- SAXS penalty function start -------"
8991       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
8992      & " isaxs_end",isaxs_end
8993       write (iout,*) "nnt",nnt," ntc",nct
8994       do i=nnt,nct
8995         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
8996      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
8997       enddo
8998       do i=nnt,nct
8999         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9000       enddo
9001 #endif
9002       Esaxs_constr = 0.0d0
9003       logPtot=0.0d0
9004       do j=isaxs_start,isaxs_end
9005         Pcalc=0.0d0
9006         do i=1,nres
9007           do l=1,3
9008             PgradC(l,i)=0.0d0
9009             PgradX(l,i)=0.0d0
9010           enddo
9011         enddo
9012         do i=nnt,nct
9013           dijCASPH=0.0d0
9014           dijSCSPH=0.0d0
9015           do l=1,3
9016             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9017           enddo
9018           if (itype(i).ne.10) then
9019           do l=1,3
9020             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9021           enddo
9022           endif
9023           sigma2CA=2.0d0/pstok**2
9024           sigma2SC=4.0d0/restok(itype(i))**2
9025           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9026           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9027           Pcalc = Pcalc+expCASPH+expSCSPH
9028 #ifdef DEBUG
9029           write(*,*) "processor i j Pcalc",
9030      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
9031 #endif
9032           CASPHgrad = sigma2CA*expCASPH
9033           SCSPHgrad = sigma2SC*expSCSPH
9034           do l=1,3
9035             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9036             PgradX(l,i) = PgradX(l,i) + aux
9037             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9038           enddo ! l
9039         enddo ! i
9040         do i=nnt,nct
9041           do l=1,3
9042             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
9043             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
9044           enddo
9045         enddo
9046         logPtot = logPtot - dlog(Pcalc)
9047 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
9048 c     &    " logPtot",logPtot
9049       enddo ! j
9050 #ifdef MPI
9051       if (nfgtasks.gt.1) then
9052 c        write (iout,*) "logPtot before reduction",logPtot
9053         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9054      &    MPI_SUM,king,FG_COMM,IERR)
9055         logPtot = logPtot_
9056 c        write (iout,*) "logPtot after reduction",logPtot
9057         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9058      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9059         if (fg_rank.eq.king) then
9060           do i=1,nres
9061             do l=1,3
9062               gsaxsC(l,i) = gsaxsC_(l,i)
9063             enddo
9064           enddo
9065         endif
9066         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9067      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9068         if (fg_rank.eq.king) then
9069           do i=1,nres
9070             do l=1,3
9071               gsaxsX(l,i) = gsaxsX_(l,i)
9072             enddo
9073           enddo
9074         endif
9075       endif
9076 #endif
9077       Esaxs_constr = logPtot
9078       return
9079       end