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.ZSCOPT'
3225       include 'DIMENSIONS.FREE'
3226       include 'COMMON.SBRIDGE'
3227       include 'COMMON.CHAIN'
3228       include 'COMMON.DERIV'
3229       include 'COMMON.VAR'
3230       include 'COMMON.INTERACT'
3231       include 'COMMON.CONTROL'
3232       include 'COMMON.IOUNITS'
3233       dimension ggg(3)
3234       ehpb=0.0D0
3235 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3236 cd    print *,'link_start=',link_start,' link_end=',link_end
3237 C      write(iout,*) link_end, "link_end"
3238       if (link_end.eq.0) return
3239       do i=link_start,link_end
3240 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3241 C CA-CA distance used in regularization of structure.
3242         ii=ihpb(i)
3243         jj=jhpb(i)
3244 C iii and jjj point to the residues for which the distance is assigned.
3245         if (ii.gt.nres) then
3246           iii=ii-nres
3247           jjj=jj-nres
3248         else
3249           iii=ii
3250           jjj=jj
3251         endif
3252 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3253 C    distance and angle dependent SS bond potential.
3254 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3255 C     & iabs(itype(jjj)).eq.1) then
3256 C       write(iout,*) constr_dist,"const"
3257        if (.not.dyn_ss .and. i.le.nss) then
3258          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3259      & iabs(itype(jjj)).eq.1) then
3260           call ssbond_ene(iii,jjj,eij)
3261           ehpb=ehpb+2*eij
3262            endif !ii.gt.neres
3263         else if (ii.gt.nres .and. jj.gt.nres) then
3264 c Restraints from contact prediction
3265           dd=dist(ii,jj)
3266           if (constr_dist.eq.11) then
3267 C            ehpb=ehpb+fordepth(i)**4.0d0
3268 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3269             ehpb=ehpb+fordepth(i)**4.0d0
3270      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3271             fac=fordepth(i)**4.0d0
3272      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3273 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3274 C     &    ehpb,fordepth(i),dd
3275 C            write(iout,*) ehpb,"atu?"
3276 C            ehpb,"tu?"
3277 C            fac=fordepth(i)**4.0d0
3278 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3279            else
3280           if (dhpb1(i).gt.0.0d0) then
3281             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3282             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3283 c            write (iout,*) "beta nmr",
3284 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3285           else
3286             dd=dist(ii,jj)
3287             rdis=dd-dhpb(i)
3288 C Get the force constant corresponding to this distance.
3289             waga=forcon(i)
3290 C Calculate the contribution to energy.
3291             ehpb=ehpb+waga*rdis*rdis
3292 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3293 C
3294 C Evaluate gradient.
3295 C
3296             fac=waga*rdis/dd
3297           endif !end dhpb1(i).gt.0
3298           endif !end const_dist=11
3299           do j=1,3
3300             ggg(j)=fac*(c(j,jj)-c(j,ii))
3301           enddo
3302           do j=1,3
3303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3305           enddo
3306           do k=1,3
3307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3309           enddo
3310         else !ii.gt.nres
3311 C          write(iout,*) "before"
3312           dd=dist(ii,jj)
3313 C          write(iout,*) "after",dd
3314           if (constr_dist.eq.11) then
3315             ehpb=ehpb+fordepth(i)**4.0d0
3316      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3317             fac=fordepth(i)**4.0d0
3318      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3319 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3320 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3321 C            print *,ehpb,"tu?"
3322 C            write(iout,*) ehpb,"btu?",
3323 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3324 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3325 C     &    ehpb,fordepth(i),dd
3326            else
3327           if (dhpb1(i).gt.0.0d0) then
3328             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3329             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3330 c            write (iout,*) "alph nmr",
3331 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3332           else
3333             rdis=dd-dhpb(i)
3334 C Get the force constant corresponding to this distance.
3335             waga=forcon(i)
3336 C Calculate the contribution to energy.
3337             ehpb=ehpb+waga*rdis*rdis
3338 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3339 C
3340 C Evaluate gradient.
3341 C
3342             fac=waga*rdis/dd
3343           endif
3344           endif
3345
3346         do j=1,3
3347           ggg(j)=fac*(c(j,jj)-c(j,ii))
3348         enddo
3349 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3350 C If this is a SC-SC distance, we need to calculate the contributions to the
3351 C Cartesian gradient in the SC vectors (ghpbx).
3352         if (iii.lt.ii) then
3353           do j=1,3
3354             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3355             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3356           enddo
3357         endif
3358         do j=iii,jjj-1
3359           do k=1,3
3360             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3361           enddo
3362         enddo
3363         endif
3364       enddo
3365       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3366       return
3367       end
3368 C--------------------------------------------------------------------------
3369       subroutine ssbond_ene(i,j,eij)
3370 C
3371 C Calculate the distance and angle dependent SS-bond potential energy
3372 C using a free-energy function derived based on RHF/6-31G** ab initio
3373 C calculations of diethyl disulfide.
3374 C
3375 C A. Liwo and U. Kozlowska, 11/24/03
3376 C
3377       implicit real*8 (a-h,o-z)
3378       include 'DIMENSIONS'
3379       include 'DIMENSIONS.ZSCOPT'
3380       include 'COMMON.SBRIDGE'
3381       include 'COMMON.CHAIN'
3382       include 'COMMON.DERIV'
3383       include 'COMMON.LOCAL'
3384       include 'COMMON.INTERACT'
3385       include 'COMMON.VAR'
3386       include 'COMMON.IOUNITS'
3387       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3388       itypi=iabs(itype(i))
3389       xi=c(1,nres+i)
3390       yi=c(2,nres+i)
3391       zi=c(3,nres+i)
3392       dxi=dc_norm(1,nres+i)
3393       dyi=dc_norm(2,nres+i)
3394       dzi=dc_norm(3,nres+i)
3395       dsci_inv=dsc_inv(itypi)
3396       itypj=iabs(itype(j))
3397       dscj_inv=dsc_inv(itypj)
3398       xj=c(1,nres+j)-xi
3399       yj=c(2,nres+j)-yi
3400       zj=c(3,nres+j)-zi
3401       dxj=dc_norm(1,nres+j)
3402       dyj=dc_norm(2,nres+j)
3403       dzj=dc_norm(3,nres+j)
3404       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3405       rij=dsqrt(rrij)
3406       erij(1)=xj*rij
3407       erij(2)=yj*rij
3408       erij(3)=zj*rij
3409       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3410       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3411       om12=dxi*dxj+dyi*dyj+dzi*dzj
3412       do k=1,3
3413         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3414         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3415       enddo
3416       rij=1.0d0/rij
3417       deltad=rij-d0cm
3418       deltat1=1.0d0-om1
3419       deltat2=1.0d0+om2
3420       deltat12=om2-om1+2.0d0
3421       cosphi=om12-om1*om2
3422       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3423      &  +akct*deltad*deltat12
3424      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3425 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3426 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3427 c     &  " deltat12",deltat12," eij",eij
3428       ed=2*akcm*deltad+akct*deltat12
3429       pom1=akct*deltad
3430       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3431       eom1=-2*akth*deltat1-pom1-om2*pom2
3432       eom2= 2*akth*deltat2+pom1-om1*pom2
3433       eom12=pom2
3434       do k=1,3
3435         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3436       enddo
3437       do k=1,3
3438         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3439      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3440         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3441      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3442       enddo
3443 C
3444 C Calculate the components of the gradient in DC and X
3445 C
3446       do k=i,j-1
3447         do l=1,3
3448           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3449         enddo
3450       enddo
3451       return
3452       end
3453 C--------------------------------------------------------------------------
3454 c MODELLER restraint function
3455       subroutine e_modeller(ehomology_constr)
3456       implicit real*8 (a-h,o-z)
3457       include 'DIMENSIONS'
3458       include 'DIMENSIONS.ZSCOPT'
3459       include 'DIMENSIONS.FREE'
3460       integer nnn, i, j, k, ki, irec, l
3461       integer katy, odleglosci, test7
3462       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3463       real*8 distance(max_template),distancek(max_template),
3464      &    min_odl,godl(max_template),dih_diff(max_template)
3465
3466 c
3467 c     FP - 30/10/2014 Temporary specifications for homology restraints
3468 c
3469       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3470      &                 sgtheta
3471       double precision, dimension (maxres) :: guscdiff,usc_diff
3472       double precision, dimension (max_template) ::
3473      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3474      &           theta_diff
3475
3476       include 'COMMON.SBRIDGE'
3477       include 'COMMON.CHAIN'
3478       include 'COMMON.GEO'
3479       include 'COMMON.DERIV'
3480       include 'COMMON.LOCAL'
3481       include 'COMMON.INTERACT'
3482       include 'COMMON.VAR'
3483       include 'COMMON.IOUNITS'
3484       include 'COMMON.CONTROL'
3485       include 'COMMON.HOMRESTR'
3486 c
3487       include 'COMMON.SETUP'
3488       include 'COMMON.NAMES'
3489
3490       do i=1,max_template
3491         distancek(i)=9999999.9
3492       enddo
3493
3494       odleg=0.0d0
3495
3496 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3497 c function)
3498 C AL 5/2/14 - Introduce list of restraints
3499 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3500 #ifdef DEBUG
3501       write(iout,*) "------- dist restrs start -------"
3502 #endif
3503       do ii = link_start_homo,link_end_homo
3504          i = ires_homo(ii)
3505          j = jres_homo(ii)
3506          dij=dist(i,j)
3507 c        write (iout,*) "dij(",i,j,") =",dij
3508          nexl=0
3509          do k=1,constr_homology
3510            if(.not.l_homo(k,ii)) then
3511               nexl=nexl+1
3512               cycle
3513            endif
3514            distance(k)=odl(k,ii)-dij
3515 c          write (iout,*) "distance(",k,") =",distance(k)
3516 c
3517 c          For Gaussian-type Urestr
3518 c
3519            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3520 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3521 c          write (iout,*) "distancek(",k,") =",distancek(k)
3522 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3523 c
3524 c          For Lorentzian-type Urestr
3525 c
3526            if (waga_dist.lt.0.0d0) then
3527               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3528               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3529      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3530            endif
3531          enddo
3532
3533 c         min_odl=minval(distancek)
3534          do kk=1,constr_homology
3535           if(l_homo(kk,ii)) then
3536             min_odl=distancek(kk)
3537             exit
3538           endif
3539          enddo
3540          do kk=1,constr_homology
3541           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3542      &              min_odl=distancek(kk)
3543          enddo
3544 c        write (iout,* )"min_odl",min_odl
3545 #ifdef DEBUG
3546          write (iout,*) "ij dij",i,j,dij
3547          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3548          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3549          write (iout,* )"min_odl",min_odl
3550 #endif
3551 #ifdef OLDRESTR
3552          odleg2=0.0d0
3553 #else
3554          if (waga_dist.ge.0.0d0) then
3555            odleg2=nexl
3556          else
3557            odleg2=0.0d0
3558          endif
3559 #endif
3560          do k=1,constr_homology
3561 c Nie wiem po co to liczycie jeszcze raz!
3562 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3563 c     &              (2*(sigma_odl(i,j,k))**2))
3564            if(.not.l_homo(k,ii)) cycle
3565            if (waga_dist.ge.0.0d0) then
3566 c
3567 c          For Gaussian-type Urestr
3568 c
3569             godl(k)=dexp(-distancek(k)+min_odl)
3570             odleg2=odleg2+godl(k)
3571 c
3572 c          For Lorentzian-type Urestr
3573 c
3574            else
3575             odleg2=odleg2+distancek(k)
3576            endif
3577
3578 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3579 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3580 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3581 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3582
3583          enddo
3584 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3585 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3586 #ifdef DEBUG
3587          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3588          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3589 #endif
3590            if (waga_dist.ge.0.0d0) then
3591 c
3592 c          For Gaussian-type Urestr
3593 c
3594               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3595 c
3596 c          For Lorentzian-type Urestr
3597 c
3598            else
3599               odleg=odleg+odleg2/constr_homology
3600            endif
3601 c
3602 #ifdef GRAD
3603 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3604 c Gradient
3605 c
3606 c          For Gaussian-type Urestr
3607 c
3608          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3609          sum_sgodl=0.0d0
3610          do k=1,constr_homology
3611 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3612 c     &           *waga_dist)+min_odl
3613 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3614 c
3615          if(.not.l_homo(k,ii)) cycle
3616          if (waga_dist.ge.0.0d0) then
3617 c          For Gaussian-type Urestr
3618 c
3619            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3620 c
3621 c          For Lorentzian-type Urestr
3622 c
3623          else
3624            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3625      &           sigma_odlir(k,ii)**2)**2)
3626          endif
3627            sum_sgodl=sum_sgodl+sgodl
3628
3629 c            sgodl2=sgodl2+sgodl
3630 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3631 c      write(iout,*) "constr_homology=",constr_homology
3632 c      write(iout,*) i, j, k, "TEST K"
3633          enddo
3634          if (waga_dist.ge.0.0d0) then
3635 c
3636 c          For Gaussian-type Urestr
3637 c
3638             grad_odl3=waga_homology(iset)*waga_dist
3639      &                *sum_sgodl/(sum_godl*dij)
3640 c
3641 c          For Lorentzian-type Urestr
3642 c
3643          else
3644 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3645 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3646             grad_odl3=-waga_homology(iset)*waga_dist*
3647      &                sum_sgodl/(constr_homology*dij)
3648          endif
3649 c
3650 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3651
3652
3653 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3654 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3655 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3656
3657 ccc      write(iout,*) godl, sgodl, grad_odl3
3658
3659 c          grad_odl=grad_odl+grad_odl3
3660
3661          do jik=1,3
3662             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3663 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3664 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3665 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3666             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3667             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3668 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3669 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3670 c         if (i.eq.25.and.j.eq.27) then
3671 c         write(iout,*) "jik",jik,"i",i,"j",j
3672 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3673 c         write(iout,*) "grad_odl3",grad_odl3
3674 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3675 c         write(iout,*) "ggodl",ggodl
3676 c         write(iout,*) "ghpbc(",jik,i,")",
3677 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3678 c     &                 ghpbc(jik,j)
3679 c         endif
3680          enddo
3681 #endif
3682 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3683 ccc     & dLOG(odleg2),"-odleg=", -odleg
3684
3685       enddo ! ii-loop for dist
3686 #ifdef DEBUG
3687       write(iout,*) "------- dist restrs end -------"
3688 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3689 c    &     waga_d.eq.1.0d0) call sum_gradient
3690 #endif
3691 c Pseudo-energy and gradient from dihedral-angle restraints from
3692 c homology templates
3693 c      write (iout,*) "End of distance loop"
3694 c      call flush(iout)
3695       kat=0.0d0
3696 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3697 #ifdef DEBUG
3698       write(iout,*) "------- dih restrs start -------"
3699       do i=idihconstr_start_homo,idihconstr_end_homo
3700         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3701       enddo
3702 #endif
3703       do i=idihconstr_start_homo,idihconstr_end_homo
3704         kat2=0.0d0
3705 c        betai=beta(i,i+1,i+2,i+3)
3706         betai = phi(i)
3707 c       write (iout,*) "betai =",betai
3708         do k=1,constr_homology
3709           dih_diff(k)=pinorm(dih(k,i)-betai)
3710 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3711 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3712 c     &                                   -(6.28318-dih_diff(i,k))
3713 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3714 c     &                                   6.28318+dih_diff(i,k)
3715 #ifdef OLD_DIHED
3716           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3717 #else
3718           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3719 #endif
3720 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3721           gdih(k)=dexp(kat3)
3722           kat2=kat2+gdih(k)
3723 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3724 c          write(*,*)""
3725         enddo
3726 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3727 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3728 #ifdef DEBUG
3729         write (iout,*) "i",i," betai",betai," kat2",kat2
3730         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3731 #endif
3732         if (kat2.le.1.0d-14) cycle
3733         kat=kat-dLOG(kat2/constr_homology)
3734 c       write (iout,*) "kat",kat ! sum of -ln-s
3735
3736 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3737 ccc     & dLOG(kat2), "-kat=", -kat
3738
3739 #ifdef GRAD
3740 c ----------------------------------------------------------------------
3741 c Gradient
3742 c ----------------------------------------------------------------------
3743
3744         sum_gdih=kat2
3745         sum_sgdih=0.0d0
3746         do k=1,constr_homology
3747 #ifdef OLD_DIHED
3748           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3749 #else
3750           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3751 #endif
3752 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3753           sum_sgdih=sum_sgdih+sgdih
3754         enddo
3755 c       grad_dih3=sum_sgdih/sum_gdih
3756         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3757
3758 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3759 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3760 ccc     & gloc(nphi+i-3,icg)
3761         gloc(i,icg)=gloc(i,icg)+grad_dih3
3762 c        if (i.eq.25) then
3763 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3764 c        endif
3765 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3766 ccc     & gloc(nphi+i-3,icg)
3767 #endif
3768       enddo ! i-loop for dih
3769 #ifdef DEBUG
3770       write(iout,*) "------- dih restrs end -------"
3771 #endif
3772
3773 c Pseudo-energy and gradient for theta angle restraints from
3774 c homology templates
3775 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3776 c adapted
3777
3778 c
3779 c     For constr_homology reference structures (FP)
3780 c
3781 c     Uconst_back_tot=0.0d0
3782       Eval=0.0d0
3783       Erot=0.0d0
3784 c     Econstr_back legacy
3785 #ifdef GRAD
3786       do i=1,nres
3787 c     do i=ithet_start,ithet_end
3788        dutheta(i)=0.0d0
3789 c     enddo
3790 c     do i=loc_start,loc_end
3791         do j=1,3
3792           duscdiff(j,i)=0.0d0
3793           duscdiffx(j,i)=0.0d0
3794         enddo
3795       enddo
3796 #endif
3797 c
3798 c     do iref=1,nref
3799 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3800 c     write (iout,*) "waga_theta",waga_theta
3801       if (waga_theta.gt.0.0d0) then
3802 #ifdef DEBUG
3803       write (iout,*) "usampl",usampl
3804       write(iout,*) "------- theta restrs start -------"
3805 c     do i=ithet_start,ithet_end
3806 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3807 c     enddo
3808 #endif
3809 c     write (iout,*) "maxres",maxres,"nres",nres
3810
3811       do i=ithet_start,ithet_end
3812 c
3813 c     do i=1,nfrag_back
3814 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3815 c
3816 c Deviation of theta angles wrt constr_homology ref structures
3817 c
3818         utheta_i=0.0d0 ! argument of Gaussian for single k
3819         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3820 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3821 c       over residues in a fragment
3822 c       write (iout,*) "theta(",i,")=",theta(i)
3823         do k=1,constr_homology
3824 c
3825 c         dtheta_i=theta(j)-thetaref(j,iref)
3826 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3827           theta_diff(k)=thetatpl(k,i)-theta(i)
3828 c
3829           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3830 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3831           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3832           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3833 c         Gradient for single Gaussian restraint in subr Econstr_back
3834 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3835 c
3836         enddo
3837 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3838 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3839
3840 c
3841 #ifdef GRAD
3842 c         Gradient for multiple Gaussian restraint
3843         sum_gtheta=gutheta_i
3844         sum_sgtheta=0.0d0
3845         do k=1,constr_homology
3846 c        New generalized expr for multiple Gaussian from Econstr_back
3847          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3848 c
3849 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3850           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3851         enddo
3852 c
3853 c       Final value of gradient using same var as in Econstr_back
3854         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3855      &               *waga_homology(iset)
3856 c       dutheta(i)=sum_sgtheta/sum_gtheta
3857 c
3858 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3859 #endif
3860         Eval=Eval-dLOG(gutheta_i/constr_homology)
3861 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3862 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3863 c       Uconst_back=Uconst_back+utheta(i)
3864       enddo ! (i-loop for theta)
3865 #ifdef DEBUG
3866       write(iout,*) "------- theta restrs end -------"
3867 #endif
3868       endif
3869 c
3870 c Deviation of local SC geometry
3871 c
3872 c Separation of two i-loops (instructed by AL - 11/3/2014)
3873 c
3874 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3875 c     write (iout,*) "waga_d",waga_d
3876
3877 #ifdef DEBUG
3878       write(iout,*) "------- SC restrs start -------"
3879       write (iout,*) "Initial duscdiff,duscdiffx"
3880       do i=loc_start,loc_end
3881         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3882      &                 (duscdiffx(jik,i),jik=1,3)
3883       enddo
3884 #endif
3885       do i=loc_start,loc_end
3886         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3887         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3888 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3889 c       write(iout,*) "xxtab, yytab, zztab"
3890 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3891         do k=1,constr_homology
3892 c
3893           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3894 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3895           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3896           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3897 c         write(iout,*) "dxx, dyy, dzz"
3898 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3899 c
3900           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3901 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3902 c         uscdiffk(k)=usc_diff(i)
3903           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3904           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3905 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3906 c     &      xxref(j),yyref(j),zzref(j)
3907         enddo
3908 c
3909 c       Gradient
3910 c
3911 c       Generalized expression for multiple Gaussian acc to that for a single
3912 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3913 c
3914 c       Original implementation
3915 c       sum_guscdiff=guscdiff(i)
3916 c
3917 c       sum_sguscdiff=0.0d0
3918 c       do k=1,constr_homology
3919 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3920 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3921 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3922 c       enddo
3923 c
3924 c       Implementation of new expressions for gradient (Jan. 2015)
3925 c
3926 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3927 #ifdef GRAD
3928         do k=1,constr_homology
3929 c
3930 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3931 c       before. Now the drivatives should be correct
3932 c
3933           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3934 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3935           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3936           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3937 c
3938 c         New implementation
3939 c
3940           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3941      &                 sigma_d(k,i) ! for the grad wrt r'
3942 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3943 c
3944 c
3945 c        New implementation
3946          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3947          do jik=1,3
3948             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3949      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3950      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3951             duscdiff(jik,i)=duscdiff(jik,i)+
3952      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3953      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3954             duscdiffx(jik,i)=duscdiffx(jik,i)+
3955      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3956      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3957 c
3958 #ifdef DEBUG
3959              write(iout,*) "jik",jik,"i",i
3960              write(iout,*) "dxx, dyy, dzz"
3961              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3962              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3963 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3964 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3965 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3966 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3967 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3968 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3969 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3970 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3971 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3972 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3973 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3974 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3975 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3976 c            endif
3977 #endif
3978          enddo
3979         enddo
3980 #endif
3981 c
3982 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3983 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3984 c
3985 c        write (iout,*) i," uscdiff",uscdiff(i)
3986 c
3987 c Put together deviations from local geometry
3988
3989 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3990 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3991         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3992 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3993 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3994 c       Uconst_back=Uconst_back+usc_diff(i)
3995 c
3996 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3997 c
3998 c     New implment: multiplied by sum_sguscdiff
3999 c
4000
4001       enddo ! (i-loop for dscdiff)
4002
4003 c      endif
4004
4005 #ifdef DEBUG
4006       write(iout,*) "------- SC restrs end -------"
4007         write (iout,*) "------ After SC loop in e_modeller ------"
4008         do i=loc_start,loc_end
4009          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4010          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4011         enddo
4012       if (waga_theta.eq.1.0d0) then
4013       write (iout,*) "in e_modeller after SC restr end: dutheta"
4014       do i=ithet_start,ithet_end
4015         write (iout,*) i,dutheta(i)
4016       enddo
4017       endif
4018       if (waga_d.eq.1.0d0) then
4019       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4020       do i=1,nres
4021         write (iout,*) i,(duscdiff(j,i),j=1,3)
4022         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4023       enddo
4024       endif
4025 #endif
4026
4027 c Total energy from homology restraints
4028 #ifdef DEBUG
4029       write (iout,*) "odleg",odleg," kat",kat
4030       write (iout,*) "odleg",odleg," kat",kat
4031       write (iout,*) "Eval",Eval," Erot",Erot
4032       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4033       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4034       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4035 #endif
4036 c
4037 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4038 c
4039 c     ehomology_constr=odleg+kat
4040 c
4041 c     For Lorentzian-type Urestr
4042 c
4043
4044       if (waga_dist.ge.0.0d0) then
4045 c
4046 c          For Gaussian-type Urestr
4047 c
4048 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4049 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4050         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4051      &              waga_theta*Eval+waga_d*Erot
4052 c     write (iout,*) "ehomology_constr=",ehomology_constr
4053       else
4054 c
4055 c          For Lorentzian-type Urestr
4056 c
4057 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4058 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4059         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4060      &              waga_theta*Eval+waga_d*Erot
4061 c     write (iout,*) "ehomology_constr=",ehomology_constr
4062       endif
4063 #ifdef DEBUG
4064       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4065      & "Eval",waga_theta,eval,
4066      &   "Erot",waga_d,Erot
4067       write (iout,*) "ehomology_constr",ehomology_constr
4068 #endif
4069       return
4070
4071   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4072   747 format(a12,i4,i4,i4,f8.3,f8.3)
4073   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4074   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4075   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4076      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4077       end
4078 c-----------------------------------------------------------------------
4079       subroutine ebond(estr)
4080 c
4081 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4082 c
4083       implicit real*8 (a-h,o-z)
4084       include 'DIMENSIONS'
4085       include 'DIMENSIONS.ZSCOPT'
4086       include 'DIMENSIONS.FREE'
4087       include 'COMMON.LOCAL'
4088       include 'COMMON.GEO'
4089       include 'COMMON.INTERACT'
4090       include 'COMMON.DERIV'
4091       include 'COMMON.VAR'
4092       include 'COMMON.CHAIN'
4093       include 'COMMON.IOUNITS'
4094       include 'COMMON.NAMES'
4095       include 'COMMON.FFIELD'
4096       include 'COMMON.CONTROL'
4097       logical energy_dec /.false./
4098       double precision u(3),ud(3)
4099       estr=0.0d0
4100 C      write (iout,*) "distchainmax",distchainmax
4101       estr1=0.0d0
4102 c      write (iout,*) "distchainmax",distchainmax
4103       do i=nnt+1,nct
4104         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4105 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4106 C          do j=1,3
4107 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4108 C     &      *dc(j,i-1)/vbld(i)
4109 C          enddo
4110 C          if (energy_dec) write(iout,*)
4111 C     &       "estr1",i,vbld(i),distchainmax,
4112 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4113 C        else
4114          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4115         diff = vbld(i)-vbldpDUM
4116 C         write(iout,*) i,diff
4117          else
4118           diff = vbld(i)-vbldp0
4119 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4120          endif
4121           estr=estr+diff*diff
4122           do j=1,3
4123             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4124           enddo
4125 C        endif
4126 C        write (iout,'(a7,i5,4f7.3)')
4127 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4128       enddo
4129       estr=0.5d0*AKP*estr+estr1
4130 c
4131 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4132 c
4133       do i=nnt,nct
4134         iti=iabs(itype(i))
4135         if (iti.ne.10 .and. iti.ne.ntyp1) then
4136           nbi=nbondterm(iti)
4137           if (nbi.eq.1) then
4138             diff=vbld(i+nres)-vbldsc0(1,iti)
4139 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4140 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4141             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4142             do j=1,3
4143               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4144             enddo
4145           else
4146             do j=1,nbi
4147               diff=vbld(i+nres)-vbldsc0(j,iti)
4148               ud(j)=aksc(j,iti)*diff
4149               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4150             enddo
4151             uprod=u(1)
4152             do j=2,nbi
4153               uprod=uprod*u(j)
4154             enddo
4155             usum=0.0d0
4156             usumsqder=0.0d0
4157             do j=1,nbi
4158               uprod1=1.0d0
4159               uprod2=1.0d0
4160               do k=1,nbi
4161                 if (k.ne.j) then
4162                   uprod1=uprod1*u(k)
4163                   uprod2=uprod2*u(k)*u(k)
4164                 endif
4165               enddo
4166               usum=usum+uprod1
4167               usumsqder=usumsqder+ud(j)*uprod2
4168             enddo
4169 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4170 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4171             estr=estr+uprod/usum
4172             do j=1,3
4173              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4174             enddo
4175           endif
4176         endif
4177       enddo
4178       return
4179       end
4180 #ifdef CRYST_THETA
4181 C--------------------------------------------------------------------------
4182       subroutine ebend(etheta)
4183 C
4184 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4185 C angles gamma and its derivatives in consecutive thetas and gammas.
4186 C
4187       implicit real*8 (a-h,o-z)
4188       include 'DIMENSIONS'
4189       include 'DIMENSIONS.ZSCOPT'
4190       include 'COMMON.LOCAL'
4191       include 'COMMON.GEO'
4192       include 'COMMON.INTERACT'
4193       include 'COMMON.DERIV'
4194       include 'COMMON.VAR'
4195       include 'COMMON.CHAIN'
4196       include 'COMMON.IOUNITS'
4197       include 'COMMON.NAMES'
4198       include 'COMMON.FFIELD'
4199       common /calcthet/ term1,term2,termm,diffak,ratak,
4200      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4201      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4202       double precision y(2),z(2)
4203       delta=0.02d0*pi
4204       time11=dexp(-2*time)
4205       time12=1.0d0
4206       etheta=0.0D0
4207 c      write (iout,*) "nres",nres
4208 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4209 c      write (iout,*) ithet_start,ithet_end
4210       do i=ithet_start,ithet_end
4211 C        if (itype(i-1).eq.ntyp1) cycle
4212 c        if (i.le.2) cycle
4213         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4214      &  .or.itype(i).eq.ntyp1) cycle
4215 C Zero the energy function and its derivative at 0 or pi.
4216         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4217         it=itype(i-1)
4218         ichir1=isign(1,itype(i-2))
4219         ichir2=isign(1,itype(i))
4220          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4221          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4222          if (itype(i-1).eq.10) then
4223           itype1=isign(10,itype(i-2))
4224           ichir11=isign(1,itype(i-2))
4225           ichir12=isign(1,itype(i-2))
4226           itype2=isign(10,itype(i))
4227           ichir21=isign(1,itype(i))
4228           ichir22=isign(1,itype(i))
4229          endif
4230          if (i.eq.3) then
4231           y(1)=0.0D0
4232           y(2)=0.0D0
4233           else
4234
4235         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4236 #ifdef OSF
4237           phii=phi(i)
4238 c          icrc=0
4239 c          call proc_proc(phii,icrc)
4240           if (icrc.eq.1) phii=150.0
4241 #else
4242           phii=phi(i)
4243 #endif
4244           y(1)=dcos(phii)
4245           y(2)=dsin(phii)
4246         else
4247           y(1)=0.0D0
4248           y(2)=0.0D0
4249         endif
4250         endif
4251         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4252 #ifdef OSF
4253           phii1=phi(i+1)
4254 c          icrc=0
4255 c          call proc_proc(phii1,icrc)
4256           if (icrc.eq.1) phii1=150.0
4257           phii1=pinorm(phii1)
4258           z(1)=cos(phii1)
4259 #else
4260           phii1=phi(i+1)
4261           z(1)=dcos(phii1)
4262 #endif
4263           z(2)=dsin(phii1)
4264         else
4265           z(1)=0.0D0
4266           z(2)=0.0D0
4267         endif
4268 C Calculate the "mean" value of theta from the part of the distribution
4269 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4270 C In following comments this theta will be referred to as t_c.
4271         thet_pred_mean=0.0d0
4272         do k=1,2
4273             athetk=athet(k,it,ichir1,ichir2)
4274             bthetk=bthet(k,it,ichir1,ichir2)
4275           if (it.eq.10) then
4276              athetk=athet(k,itype1,ichir11,ichir12)
4277              bthetk=bthet(k,itype2,ichir21,ichir22)
4278           endif
4279           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4280         enddo
4281 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4282         dthett=thet_pred_mean*ssd
4283         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4284 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4285 C Derivatives of the "mean" values in gamma1 and gamma2.
4286         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4287      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4288          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4289      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4290          if (it.eq.10) then
4291       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4292      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4293         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4294      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4295          endif
4296         if (theta(i).gt.pi-delta) then
4297           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4298      &         E_tc0)
4299           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4300           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4301           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4302      &        E_theta)
4303           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4304      &        E_tc)
4305         else if (theta(i).lt.delta) then
4306           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4307           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4308           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4309      &        E_theta)
4310           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4311           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4312      &        E_tc)
4313         else
4314           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4315      &        E_theta,E_tc)
4316         endif
4317         etheta=etheta+ethetai
4318 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4319 c     &      'ebend',i,ethetai,theta(i),itype(i)
4320 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4321 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4322         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4323         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4324         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4325 c 1215   continue
4326       enddo
4327       ethetacnstr=0.0d0
4328 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4329       do i=1,ntheta_constr
4330         itheta=itheta_constr(i)
4331         thetiii=theta(itheta)
4332         difi=pinorm(thetiii-theta_constr0(i))
4333         if (difi.gt.theta_drange(i)) then
4334           difi=difi-theta_drange(i)
4335           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4336           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4337      &    +for_thet_constr(i)*difi**3
4338         else if (difi.lt.-drange(i)) then
4339           difi=difi+drange(i)
4340           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4341           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4342      &    +for_thet_constr(i)*difi**3
4343         else
4344           difi=0.0
4345         endif
4346 C       if (energy_dec) then
4347 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4348 C     &    i,itheta,rad2deg*thetiii,
4349 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4350 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4351 C     &    gloc(itheta+nphi-2,icg)
4352 C        endif
4353       enddo
4354 C Ufff.... We've done all this!!!
4355       return
4356       end
4357 C---------------------------------------------------------------------------
4358       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4359      &     E_tc)
4360       implicit real*8 (a-h,o-z)
4361       include 'DIMENSIONS'
4362       include 'COMMON.LOCAL'
4363       include 'COMMON.IOUNITS'
4364       common /calcthet/ term1,term2,termm,diffak,ratak,
4365      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4366      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4367 C Calculate the contributions to both Gaussian lobes.
4368 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4369 C The "polynomial part" of the "standard deviation" of this part of
4370 C the distribution.
4371         sig=polthet(3,it)
4372         do j=2,0,-1
4373           sig=sig*thet_pred_mean+polthet(j,it)
4374         enddo
4375 C Derivative of the "interior part" of the "standard deviation of the"
4376 C gamma-dependent Gaussian lobe in t_c.
4377         sigtc=3*polthet(3,it)
4378         do j=2,1,-1
4379           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4380         enddo
4381         sigtc=sig*sigtc
4382 C Set the parameters of both Gaussian lobes of the distribution.
4383 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4384         fac=sig*sig+sigc0(it)
4385         sigcsq=fac+fac
4386         sigc=1.0D0/sigcsq
4387 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4388         sigsqtc=-4.0D0*sigcsq*sigtc
4389 c       print *,i,sig,sigtc,sigsqtc
4390 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4391         sigtc=-sigtc/(fac*fac)
4392 C Following variable is sigma(t_c)**(-2)
4393         sigcsq=sigcsq*sigcsq
4394         sig0i=sig0(it)
4395         sig0inv=1.0D0/sig0i**2
4396         delthec=thetai-thet_pred_mean
4397         delthe0=thetai-theta0i
4398         term1=-0.5D0*sigcsq*delthec*delthec
4399         term2=-0.5D0*sig0inv*delthe0*delthe0
4400 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4401 C NaNs in taking the logarithm. We extract the largest exponent which is added
4402 C to the energy (this being the log of the distribution) at the end of energy
4403 C term evaluation for this virtual-bond angle.
4404         if (term1.gt.term2) then
4405           termm=term1
4406           term2=dexp(term2-termm)
4407           term1=1.0d0
4408         else
4409           termm=term2
4410           term1=dexp(term1-termm)
4411           term2=1.0d0
4412         endif
4413 C The ratio between the gamma-independent and gamma-dependent lobes of
4414 C the distribution is a Gaussian function of thet_pred_mean too.
4415         diffak=gthet(2,it)-thet_pred_mean
4416         ratak=diffak/gthet(3,it)**2
4417         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4418 C Let's differentiate it in thet_pred_mean NOW.
4419         aktc=ak*ratak
4420 C Now put together the distribution terms to make complete distribution.
4421         termexp=term1+ak*term2
4422         termpre=sigc+ak*sig0i
4423 C Contribution of the bending energy from this theta is just the -log of
4424 C the sum of the contributions from the two lobes and the pre-exponential
4425 C factor. Simple enough, isn't it?
4426         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4427 C NOW the derivatives!!!
4428 C 6/6/97 Take into account the deformation.
4429         E_theta=(delthec*sigcsq*term1
4430      &       +ak*delthe0*sig0inv*term2)/termexp
4431         E_tc=((sigtc+aktc*sig0i)/termpre
4432      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4433      &       aktc*term2)/termexp)
4434       return
4435       end
4436 c-----------------------------------------------------------------------------
4437       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4438       implicit real*8 (a-h,o-z)
4439       include 'DIMENSIONS'
4440       include 'COMMON.LOCAL'
4441       include 'COMMON.IOUNITS'
4442       common /calcthet/ term1,term2,termm,diffak,ratak,
4443      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4444      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4445       delthec=thetai-thet_pred_mean
4446       delthe0=thetai-theta0i
4447 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4448       t3 = thetai-thet_pred_mean
4449       t6 = t3**2
4450       t9 = term1
4451       t12 = t3*sigcsq
4452       t14 = t12+t6*sigsqtc
4453       t16 = 1.0d0
4454       t21 = thetai-theta0i
4455       t23 = t21**2
4456       t26 = term2
4457       t27 = t21*t26
4458       t32 = termexp
4459       t40 = t32**2
4460       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4461      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4462      & *(-t12*t9-ak*sig0inv*t27)
4463       return
4464       end
4465 #else
4466 C--------------------------------------------------------------------------
4467       subroutine ebend(etheta)
4468 C
4469 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4470 C angles gamma and its derivatives in consecutive thetas and gammas.
4471 C ab initio-derived potentials from
4472 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4473 C
4474       implicit real*8 (a-h,o-z)
4475       include 'DIMENSIONS'
4476       include 'DIMENSIONS.ZSCOPT'
4477       include 'DIMENSIONS.FREE'
4478       include 'COMMON.LOCAL'
4479       include 'COMMON.GEO'
4480       include 'COMMON.INTERACT'
4481       include 'COMMON.DERIV'
4482       include 'COMMON.VAR'
4483       include 'COMMON.CHAIN'
4484       include 'COMMON.IOUNITS'
4485       include 'COMMON.NAMES'
4486       include 'COMMON.FFIELD'
4487       include 'COMMON.CONTROL'
4488       include 'COMMON.TORCNSTR'
4489       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4490      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4491      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4492      & sinph1ph2(maxdouble,maxdouble)
4493       logical lprn /.false./, lprn1 /.false./
4494       etheta=0.0D0
4495 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4496       do i=ithet_start,ithet_end
4497 c        if (i.eq.2) cycle
4498 c        print *,i,itype(i-1),itype(i),itype(i-2)
4499         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4500      &  .or.(itype(i).eq.ntyp1)) cycle
4501 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4502
4503         if (iabs(itype(i+1)).eq.20) iblock=2
4504         if (iabs(itype(i+1)).ne.20) iblock=1
4505         dethetai=0.0d0
4506         dephii=0.0d0
4507         dephii1=0.0d0
4508         theti2=0.5d0*theta(i)
4509         ityp2=ithetyp((itype(i-1)))
4510         do k=1,nntheterm
4511           coskt(k)=dcos(k*theti2)
4512           sinkt(k)=dsin(k*theti2)
4513         enddo
4514         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4515 #ifdef OSF
4516           phii=phi(i)
4517           if (phii.ne.phii) phii=150.0
4518 #else
4519           phii=phi(i)
4520 #endif
4521           ityp1=ithetyp((itype(i-2)))
4522           do k=1,nsingle
4523             cosph1(k)=dcos(k*phii)
4524             sinph1(k)=dsin(k*phii)
4525           enddo
4526         else
4527           phii=0.0d0
4528           ityp1=ithetyp(itype(i-2))
4529           do k=1,nsingle
4530             cosph1(k)=0.0d0
4531             sinph1(k)=0.0d0
4532           enddo
4533         endif
4534         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4535 #ifdef OSF
4536           phii1=phi(i+1)
4537           if (phii1.ne.phii1) phii1=150.0
4538           phii1=pinorm(phii1)
4539 #else
4540           phii1=phi(i+1)
4541 #endif
4542           ityp3=ithetyp((itype(i)))
4543           do k=1,nsingle
4544             cosph2(k)=dcos(k*phii1)
4545             sinph2(k)=dsin(k*phii1)
4546           enddo
4547         else
4548           phii1=0.0d0
4549           ityp3=ithetyp(itype(i))
4550           do k=1,nsingle
4551             cosph2(k)=0.0d0
4552             sinph2(k)=0.0d0
4553           enddo
4554         endif
4555 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4556 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4557 c        call flush(iout)
4558         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4559         do k=1,ndouble
4560           do l=1,k-1
4561             ccl=cosph1(l)*cosph2(k-l)
4562             ssl=sinph1(l)*sinph2(k-l)
4563             scl=sinph1(l)*cosph2(k-l)
4564             csl=cosph1(l)*sinph2(k-l)
4565             cosph1ph2(l,k)=ccl-ssl
4566             cosph1ph2(k,l)=ccl+ssl
4567             sinph1ph2(l,k)=scl+csl
4568             sinph1ph2(k,l)=scl-csl
4569           enddo
4570         enddo
4571         if (lprn) then
4572         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4573      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4574         write (iout,*) "coskt and sinkt"
4575         do k=1,nntheterm
4576           write (iout,*) k,coskt(k),sinkt(k)
4577         enddo
4578         endif
4579         do k=1,ntheterm
4580           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4581           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4582      &      *coskt(k)
4583           if (lprn)
4584      &    write (iout,*) "k",k,"
4585      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4586      &     " ethetai",ethetai
4587         enddo
4588         if (lprn) then
4589         write (iout,*) "cosph and sinph"
4590         do k=1,nsingle
4591           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4592         enddo
4593         write (iout,*) "cosph1ph2 and sinph2ph2"
4594         do k=2,ndouble
4595           do l=1,k-1
4596             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4597      &         sinph1ph2(l,k),sinph1ph2(k,l)
4598           enddo
4599         enddo
4600         write(iout,*) "ethetai",ethetai
4601         endif
4602         do m=1,ntheterm2
4603           do k=1,nsingle
4604             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4605      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4606      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4607      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4608             ethetai=ethetai+sinkt(m)*aux
4609             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4610             dephii=dephii+k*sinkt(m)*(
4611      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4612      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4613             dephii1=dephii1+k*sinkt(m)*(
4614      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4615      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4616             if (lprn)
4617      &      write (iout,*) "m",m," k",k," bbthet",
4618      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4619      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4620      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4621      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4622           enddo
4623         enddo
4624         if (lprn)
4625      &  write(iout,*) "ethetai",ethetai
4626         do m=1,ntheterm3
4627           do k=2,ndouble
4628             do l=1,k-1
4629               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4630      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4631      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4632      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4633               ethetai=ethetai+sinkt(m)*aux
4634               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4635               dephii=dephii+l*sinkt(m)*(
4636      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4637      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4638      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4639      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4640               dephii1=dephii1+(k-l)*sinkt(m)*(
4641      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4642      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4643      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4644      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4645               if (lprn) then
4646               write (iout,*) "m",m," k",k," l",l," ffthet",
4647      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4648      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4649      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4650      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4651      &            " ethetai",ethetai
4652               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4653      &            cosph1ph2(k,l)*sinkt(m),
4654      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4655               endif
4656             enddo
4657           enddo
4658         enddo
4659 10      continue
4660         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4661      &   i,theta(i)*rad2deg,phii*rad2deg,
4662      &   phii1*rad2deg,ethetai
4663         etheta=etheta+ethetai
4664         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4665         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4666 c        gloc(nphi+i-2,icg)=wang*dethetai
4667         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4668       enddo
4669 C now constrains
4670       ethetacnstr=0.0d0
4671 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4672       do i=1,ntheta_constr
4673         itheta=itheta_constr(i)
4674         thetiii=theta(itheta)
4675         difi=pinorm(thetiii-theta_constr0(i))
4676         if (difi.gt.theta_drange(i)) then
4677           difi=difi-theta_drange(i)
4678           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4679           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4680      &    +for_thet_constr(i)*difi**3
4681         else if (difi.lt.-drange(i)) then
4682           difi=difi+drange(i)
4683           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4684           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4685      &    +for_thet_constr(i)*difi**3
4686         else
4687           difi=0.0
4688         endif
4689 C       if (energy_dec) then
4690 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4691 C     &    i,itheta,rad2deg*thetiii,
4692 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4693 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4694 C     &    gloc(itheta+nphi-2,icg)
4695 C        endif
4696       enddo
4697       return
4698       end
4699
4700 #endif
4701 #ifdef CRYST_SC
4702 c-----------------------------------------------------------------------------
4703       subroutine esc(escloc)
4704 C Calculate the local energy of a side chain and its derivatives in the
4705 C corresponding virtual-bond valence angles THETA and the spherical angles
4706 C ALPHA and OMEGA.
4707       implicit real*8 (a-h,o-z)
4708       include 'DIMENSIONS'
4709       include 'DIMENSIONS.ZSCOPT'
4710       include 'COMMON.GEO'
4711       include 'COMMON.LOCAL'
4712       include 'COMMON.VAR'
4713       include 'COMMON.INTERACT'
4714       include 'COMMON.DERIV'
4715       include 'COMMON.CHAIN'
4716       include 'COMMON.IOUNITS'
4717       include 'COMMON.NAMES'
4718       include 'COMMON.FFIELD'
4719       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4720      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4721       common /sccalc/ time11,time12,time112,theti,it,nlobit
4722       delta=0.02d0*pi
4723       escloc=0.0D0
4724 C      write (iout,*) 'ESC'
4725       do i=loc_start,loc_end
4726         it=itype(i)
4727         if (it.eq.ntyp1) cycle
4728         if (it.eq.10) goto 1
4729         nlobit=nlob(iabs(it))
4730 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4731 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4732         theti=theta(i+1)-pipol
4733         x(1)=dtan(theti)
4734         x(2)=alph(i)
4735         x(3)=omeg(i)
4736 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4737
4738         if (x(2).gt.pi-delta) then
4739           xtemp(1)=x(1)
4740           xtemp(2)=pi-delta
4741           xtemp(3)=x(3)
4742           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4743           xtemp(2)=pi
4744           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4745           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4746      &        escloci,dersc(2))
4747           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4748      &        ddersc0(1),dersc(1))
4749           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4750      &        ddersc0(3),dersc(3))
4751           xtemp(2)=pi-delta
4752           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4753           xtemp(2)=pi
4754           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4755           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4756      &            dersc0(2),esclocbi,dersc02)
4757           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4758      &            dersc12,dersc01)
4759           call splinthet(x(2),0.5d0*delta,ss,ssd)
4760           dersc0(1)=dersc01
4761           dersc0(2)=dersc02
4762           dersc0(3)=0.0d0
4763           do k=1,3
4764             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4765           enddo
4766           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4767           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4768      &             esclocbi,ss,ssd
4769           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4770 c         escloci=esclocbi
4771 c         write (iout,*) escloci
4772         else if (x(2).lt.delta) then
4773           xtemp(1)=x(1)
4774           xtemp(2)=delta
4775           xtemp(3)=x(3)
4776           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4777           xtemp(2)=0.0d0
4778           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4779           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4780      &        escloci,dersc(2))
4781           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4782      &        ddersc0(1),dersc(1))
4783           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4784      &        ddersc0(3),dersc(3))
4785           xtemp(2)=delta
4786           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4787           xtemp(2)=0.0d0
4788           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4789           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4790      &            dersc0(2),esclocbi,dersc02)
4791           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4792      &            dersc12,dersc01)
4793           dersc0(1)=dersc01
4794           dersc0(2)=dersc02
4795           dersc0(3)=0.0d0
4796           call splinthet(x(2),0.5d0*delta,ss,ssd)
4797           do k=1,3
4798             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4799           enddo
4800           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4801 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4802 c     &             esclocbi,ss,ssd
4803           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4804 C         write (iout,*) 'i=',i, escloci
4805         else
4806           call enesc(x,escloci,dersc,ddummy,.false.)
4807         endif
4808
4809         escloc=escloc+escloci
4810 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4811             write (iout,'(a6,i5,0pf7.3)')
4812      &     'escloc',i,escloci
4813
4814         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4815      &   wscloc*dersc(1)
4816         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4817         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4818     1   continue
4819       enddo
4820       return
4821       end
4822 C---------------------------------------------------------------------------
4823       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4824       implicit real*8 (a-h,o-z)
4825       include 'DIMENSIONS'
4826       include 'COMMON.GEO'
4827       include 'COMMON.LOCAL'
4828       include 'COMMON.IOUNITS'
4829       common /sccalc/ time11,time12,time112,theti,it,nlobit
4830       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4831       double precision contr(maxlob,-1:1)
4832       logical mixed
4833 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4834         escloc_i=0.0D0
4835         do j=1,3
4836           dersc(j)=0.0D0
4837           if (mixed) ddersc(j)=0.0d0
4838         enddo
4839         x3=x(3)
4840
4841 C Because of periodicity of the dependence of the SC energy in omega we have
4842 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4843 C To avoid underflows, first compute & store the exponents.
4844
4845         do iii=-1,1
4846
4847           x(3)=x3+iii*dwapi
4848
4849           do j=1,nlobit
4850             do k=1,3
4851               z(k)=x(k)-censc(k,j,it)
4852             enddo
4853             do k=1,3
4854               Axk=0.0D0
4855               do l=1,3
4856                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4857               enddo
4858               Ax(k,j,iii)=Axk
4859             enddo
4860             expfac=0.0D0
4861             do k=1,3
4862               expfac=expfac+Ax(k,j,iii)*z(k)
4863             enddo
4864             contr(j,iii)=expfac
4865           enddo ! j
4866
4867         enddo ! iii
4868
4869         x(3)=x3
4870 C As in the case of ebend, we want to avoid underflows in exponentiation and
4871 C subsequent NaNs and INFs in energy calculation.
4872 C Find the largest exponent
4873         emin=contr(1,-1)
4874         do iii=-1,1
4875           do j=1,nlobit
4876             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4877           enddo
4878         enddo
4879         emin=0.5D0*emin
4880 cd      print *,'it=',it,' emin=',emin
4881
4882 C Compute the contribution to SC energy and derivatives
4883         do iii=-1,1
4884
4885           do j=1,nlobit
4886             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4887 cd          print *,'j=',j,' expfac=',expfac
4888             escloc_i=escloc_i+expfac
4889             do k=1,3
4890               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4891             enddo
4892             if (mixed) then
4893               do k=1,3,2
4894                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4895      &            +gaussc(k,2,j,it))*expfac
4896               enddo
4897             endif
4898           enddo
4899
4900         enddo ! iii
4901
4902         dersc(1)=dersc(1)/cos(theti)**2
4903         ddersc(1)=ddersc(1)/cos(theti)**2
4904         ddersc(3)=ddersc(3)
4905
4906         escloci=-(dlog(escloc_i)-emin)
4907         do j=1,3
4908           dersc(j)=dersc(j)/escloc_i
4909         enddo
4910         if (mixed) then
4911           do j=1,3,2
4912             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4913           enddo
4914         endif
4915       return
4916       end
4917 C------------------------------------------------------------------------------
4918       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4919       implicit real*8 (a-h,o-z)
4920       include 'DIMENSIONS'
4921       include 'COMMON.GEO'
4922       include 'COMMON.LOCAL'
4923       include 'COMMON.IOUNITS'
4924       common /sccalc/ time11,time12,time112,theti,it,nlobit
4925       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4926       double precision contr(maxlob)
4927       logical mixed
4928
4929       escloc_i=0.0D0
4930
4931       do j=1,3
4932         dersc(j)=0.0D0
4933       enddo
4934
4935       do j=1,nlobit
4936         do k=1,2
4937           z(k)=x(k)-censc(k,j,it)
4938         enddo
4939         z(3)=dwapi
4940         do k=1,3
4941           Axk=0.0D0
4942           do l=1,3
4943             Axk=Axk+gaussc(l,k,j,it)*z(l)
4944           enddo
4945           Ax(k,j)=Axk
4946         enddo
4947         expfac=0.0D0
4948         do k=1,3
4949           expfac=expfac+Ax(k,j)*z(k)
4950         enddo
4951         contr(j)=expfac
4952       enddo ! j
4953
4954 C As in the case of ebend, we want to avoid underflows in exponentiation and
4955 C subsequent NaNs and INFs in energy calculation.
4956 C Find the largest exponent
4957       emin=contr(1)
4958       do j=1,nlobit
4959         if (emin.gt.contr(j)) emin=contr(j)
4960       enddo
4961       emin=0.5D0*emin
4962
4963 C Compute the contribution to SC energy and derivatives
4964
4965       dersc12=0.0d0
4966       do j=1,nlobit
4967         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4968         escloc_i=escloc_i+expfac
4969         do k=1,2
4970           dersc(k)=dersc(k)+Ax(k,j)*expfac
4971         enddo
4972         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4973      &            +gaussc(1,2,j,it))*expfac
4974         dersc(3)=0.0d0
4975       enddo
4976
4977       dersc(1)=dersc(1)/cos(theti)**2
4978       dersc12=dersc12/cos(theti)**2
4979       escloci=-(dlog(escloc_i)-emin)
4980       do j=1,2
4981         dersc(j)=dersc(j)/escloc_i
4982       enddo
4983       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4984       return
4985       end
4986 #else
4987 c----------------------------------------------------------------------------------
4988       subroutine esc(escloc)
4989 C Calculate the local energy of a side chain and its derivatives in the
4990 C corresponding virtual-bond valence angles THETA and the spherical angles
4991 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4992 C added by Urszula Kozlowska. 07/11/2007
4993 C
4994       implicit real*8 (a-h,o-z)
4995       include 'DIMENSIONS'
4996       include 'DIMENSIONS.ZSCOPT'
4997       include 'DIMENSIONS.FREE'
4998       include 'COMMON.GEO'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.VAR'
5001       include 'COMMON.SCROT'
5002       include 'COMMON.INTERACT'
5003       include 'COMMON.DERIV'
5004       include 'COMMON.CHAIN'
5005       include 'COMMON.IOUNITS'
5006       include 'COMMON.NAMES'
5007       include 'COMMON.FFIELD'
5008       include 'COMMON.CONTROL'
5009       include 'COMMON.VECTORS'
5010       double precision x_prime(3),y_prime(3),z_prime(3)
5011      &    , sumene,dsc_i,dp2_i,x(65),
5012      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5013      &    de_dxx,de_dyy,de_dzz,de_dt
5014       double precision s1_t,s1_6_t,s2_t,s2_6_t
5015       double precision
5016      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5017      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5018      & dt_dCi(3),dt_dCi1(3)
5019       common /sccalc/ time11,time12,time112,theti,it,nlobit
5020       delta=0.02d0*pi
5021       escloc=0.0D0
5022       do i=loc_start,loc_end
5023         if (itype(i).eq.ntyp1) cycle
5024         costtab(i+1) =dcos(theta(i+1))
5025         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5026         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5027         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5028         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5029         cosfac=dsqrt(cosfac2)
5030         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5031         sinfac=dsqrt(sinfac2)
5032         it=iabs(itype(i))
5033         if (it.eq.10) goto 1
5034 c
5035 C  Compute the axes of tghe local cartesian coordinates system; store in
5036 c   x_prime, y_prime and z_prime
5037 c
5038         do j=1,3
5039           x_prime(j) = 0.00
5040           y_prime(j) = 0.00
5041           z_prime(j) = 0.00
5042         enddo
5043 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5044 C     &   dc_norm(3,i+nres)
5045         do j = 1,3
5046           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5047           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5048         enddo
5049         do j = 1,3
5050           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5051         enddo
5052 c       write (2,*) "i",i
5053 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5054 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5055 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5056 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5057 c      & " xy",scalar(x_prime(1),y_prime(1)),
5058 c      & " xz",scalar(x_prime(1),z_prime(1)),
5059 c      & " yy",scalar(y_prime(1),y_prime(1)),
5060 c      & " yz",scalar(y_prime(1),z_prime(1)),
5061 c      & " zz",scalar(z_prime(1),z_prime(1))
5062 c
5063 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5064 C to local coordinate system. Store in xx, yy, zz.
5065 c
5066         xx=0.0d0
5067         yy=0.0d0
5068         zz=0.0d0
5069         do j = 1,3
5070           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5071           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5072           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5073         enddo
5074
5075         xxtab(i)=xx
5076         yytab(i)=yy
5077         zztab(i)=zz
5078 C
5079 C Compute the energy of the ith side cbain
5080 C
5081 c        write (2,*) "xx",xx," yy",yy," zz",zz
5082         it=iabs(itype(i))
5083         do j = 1,65
5084           x(j) = sc_parmin(j,it)
5085         enddo
5086 #ifdef CHECK_COORD
5087 Cc diagnostics - remove later
5088         xx1 = dcos(alph(2))
5089         yy1 = dsin(alph(2))*dcos(omeg(2))
5090         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5091         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5092      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5093      &    xx1,yy1,zz1
5094 C,"  --- ", xx_w,yy_w,zz_w
5095 c end diagnostics
5096 #endif
5097         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5098      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5099      &   + x(10)*yy*zz
5100         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5101      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5102      & + x(20)*yy*zz
5103         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5104      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5105      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5106      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5107      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5108      &  +x(40)*xx*yy*zz
5109         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5110      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5111      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5112      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5113      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5114      &  +x(60)*xx*yy*zz
5115         dsc_i   = 0.743d0+x(61)
5116         dp2_i   = 1.9d0+x(62)
5117         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5118      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5119         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5120      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5121         s1=(1+x(63))/(0.1d0 + dscp1)
5122         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5123         s2=(1+x(65))/(0.1d0 + dscp2)
5124         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5125         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5126      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5127 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5128 c     &   sumene4,
5129 c     &   dscp1,dscp2,sumene
5130 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5131         escloc = escloc + sumene
5132 c        write (2,*) "escloc",escloc
5133 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5134 c     &  zz,xx,yy
5135         if (.not. calc_grad) goto 1
5136 #ifdef DEBUG
5137 C
5138 C This section to check the numerical derivatives of the energy of ith side
5139 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5140 C #define DEBUG in the code to turn it on.
5141 C
5142         write (2,*) "sumene               =",sumene
5143         aincr=1.0d-7
5144         xxsave=xx
5145         xx=xx+aincr
5146         write (2,*) xx,yy,zz
5147         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5148         de_dxx_num=(sumenep-sumene)/aincr
5149         xx=xxsave
5150         write (2,*) "xx+ sumene from enesc=",sumenep
5151         yysave=yy
5152         yy=yy+aincr
5153         write (2,*) xx,yy,zz
5154         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5155         de_dyy_num=(sumenep-sumene)/aincr
5156         yy=yysave
5157         write (2,*) "yy+ sumene from enesc=",sumenep
5158         zzsave=zz
5159         zz=zz+aincr
5160         write (2,*) xx,yy,zz
5161         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5162         de_dzz_num=(sumenep-sumene)/aincr
5163         zz=zzsave
5164         write (2,*) "zz+ sumene from enesc=",sumenep
5165         costsave=cost2tab(i+1)
5166         sintsave=sint2tab(i+1)
5167         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5168         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5169         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5170         de_dt_num=(sumenep-sumene)/aincr
5171         write (2,*) " t+ sumene from enesc=",sumenep
5172         cost2tab(i+1)=costsave
5173         sint2tab(i+1)=sintsave
5174 C End of diagnostics section.
5175 #endif
5176 C
5177 C Compute the gradient of esc
5178 C
5179         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5180         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5181         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5182         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5183         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5184         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5185         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5186         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5187         pom1=(sumene3*sint2tab(i+1)+sumene1)
5188      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5189         pom2=(sumene4*cost2tab(i+1)+sumene2)
5190      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5191         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5192         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5193      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5194      &  +x(40)*yy*zz
5195         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5196         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5197      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5198      &  +x(60)*yy*zz
5199         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5200      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5201      &        +(pom1+pom2)*pom_dx
5202 #ifdef DEBUG
5203         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5204 #endif
5205 C
5206         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5207         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5208      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5209      &  +x(40)*xx*zz
5210         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5211         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5212      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5213      &  +x(59)*zz**2 +x(60)*xx*zz
5214         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5215      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5216      &        +(pom1-pom2)*pom_dy
5217 #ifdef DEBUG
5218         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5219 #endif
5220 C
5221         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5222      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5223      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5224      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5225      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5226      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5227      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5228      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5229 #ifdef DEBUG
5230         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5231 #endif
5232 C
5233         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5234      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5235      &  +pom1*pom_dt1+pom2*pom_dt2
5236 #ifdef DEBUG
5237         write(2,*), "de_dt = ", de_dt,de_dt_num
5238 #endif
5239 c
5240 C
5241        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5242        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5243        cosfac2xx=cosfac2*xx
5244        sinfac2yy=sinfac2*yy
5245        do k = 1,3
5246          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5247      &      vbld_inv(i+1)
5248          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5249      &      vbld_inv(i)
5250          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5251          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5252 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5253 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5254 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5255 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5256          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5257          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5258          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5259          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5260          dZZ_Ci1(k)=0.0d0
5261          dZZ_Ci(k)=0.0d0
5262          do j=1,3
5263            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5264      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5265            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5266      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5267          enddo
5268
5269          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5270          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5271          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5272 c
5273          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5274          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5275        enddo
5276
5277        do k=1,3
5278          dXX_Ctab(k,i)=dXX_Ci(k)
5279          dXX_C1tab(k,i)=dXX_Ci1(k)
5280          dYY_Ctab(k,i)=dYY_Ci(k)
5281          dYY_C1tab(k,i)=dYY_Ci1(k)
5282          dZZ_Ctab(k,i)=dZZ_Ci(k)
5283          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5284          dXX_XYZtab(k,i)=dXX_XYZ(k)
5285          dYY_XYZtab(k,i)=dYY_XYZ(k)
5286          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5287        enddo
5288
5289        do k = 1,3
5290 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5291 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5292 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5293 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5294 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5295 c     &    dt_dci(k)
5296 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5297 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5298          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5299      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5300          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5301      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5302          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5303      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5304        enddo
5305 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5306 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5307
5308 C to check gradient call subroutine check_grad
5309
5310     1 continue
5311       enddo
5312       return
5313       end
5314 #endif
5315 c------------------------------------------------------------------------------
5316       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5317 C
5318 C This procedure calculates two-body contact function g(rij) and its derivative:
5319 C
5320 C           eps0ij                                     !       x < -1
5321 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5322 C            0                                         !       x > 1
5323 C
5324 C where x=(rij-r0ij)/delta
5325 C
5326 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5327 C
5328       implicit none
5329       double precision rij,r0ij,eps0ij,fcont,fprimcont
5330       double precision x,x2,x4,delta
5331 c     delta=0.02D0*r0ij
5332 c      delta=0.2D0*r0ij
5333       x=(rij-r0ij)/delta
5334       if (x.lt.-1.0D0) then
5335         fcont=eps0ij
5336         fprimcont=0.0D0
5337       else if (x.le.1.0D0) then
5338         x2=x*x
5339         x4=x2*x2
5340         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5341         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5342       else
5343         fcont=0.0D0
5344         fprimcont=0.0D0
5345       endif
5346       return
5347       end
5348 c------------------------------------------------------------------------------
5349       subroutine splinthet(theti,delta,ss,ssder)
5350       implicit real*8 (a-h,o-z)
5351       include 'DIMENSIONS'
5352       include 'DIMENSIONS.ZSCOPT'
5353       include 'COMMON.VAR'
5354       include 'COMMON.GEO'
5355       thetup=pi-delta
5356       thetlow=delta
5357       if (theti.gt.pipol) then
5358         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5359       else
5360         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5361         ssder=-ssder
5362       endif
5363       return
5364       end
5365 c------------------------------------------------------------------------------
5366       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5367       implicit none
5368       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5369       double precision ksi,ksi2,ksi3,a1,a2,a3
5370       a1=fprim0*delta/(f1-f0)
5371       a2=3.0d0-2.0d0*a1
5372       a3=a1-2.0d0
5373       ksi=(x-x0)/delta
5374       ksi2=ksi*ksi
5375       ksi3=ksi2*ksi
5376       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5377       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5378       return
5379       end
5380 c------------------------------------------------------------------------------
5381       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5382       implicit none
5383       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5384       double precision ksi,ksi2,ksi3,a1,a2,a3
5385       ksi=(x-x0)/delta
5386       ksi2=ksi*ksi
5387       ksi3=ksi2*ksi
5388       a1=fprim0x*delta
5389       a2=3*(f1x-f0x)-2*fprim0x*delta
5390       a3=fprim0x*delta-2*(f1x-f0x)
5391       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5392       return
5393       end
5394 C-----------------------------------------------------------------------------
5395 #ifdef CRYST_TOR
5396 C-----------------------------------------------------------------------------
5397       subroutine etor(etors,edihcnstr,fact)
5398       implicit real*8 (a-h,o-z)
5399       include 'DIMENSIONS'
5400       include 'DIMENSIONS.ZSCOPT'
5401       include 'COMMON.VAR'
5402       include 'COMMON.GEO'
5403       include 'COMMON.LOCAL'
5404       include 'COMMON.TORSION'
5405       include 'COMMON.INTERACT'
5406       include 'COMMON.DERIV'
5407       include 'COMMON.CHAIN'
5408       include 'COMMON.NAMES'
5409       include 'COMMON.IOUNITS'
5410       include 'COMMON.FFIELD'
5411       include 'COMMON.TORCNSTR'
5412       logical lprn
5413 C Set lprn=.true. for debugging
5414       lprn=.false.
5415 c      lprn=.true.
5416       etors=0.0D0
5417       do i=iphi_start,iphi_end
5418         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5419      &      .or. itype(i).eq.ntyp1) cycle
5420         itori=itortyp(itype(i-2))
5421         itori1=itortyp(itype(i-1))
5422         phii=phi(i)
5423         gloci=0.0D0
5424 C Proline-Proline pair is a special case...
5425         if (itori.eq.3 .and. itori1.eq.3) then
5426           if (phii.gt.-dwapi3) then
5427             cosphi=dcos(3*phii)
5428             fac=1.0D0/(1.0D0-cosphi)
5429             etorsi=v1(1,3,3)*fac
5430             etorsi=etorsi+etorsi
5431             etors=etors+etorsi-v1(1,3,3)
5432             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5433           endif
5434           do j=1,3
5435             v1ij=v1(j+1,itori,itori1)
5436             v2ij=v2(j+1,itori,itori1)
5437             cosphi=dcos(j*phii)
5438             sinphi=dsin(j*phii)
5439             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5440             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5441           enddo
5442         else
5443           do j=1,nterm_old
5444             v1ij=v1(j,itori,itori1)
5445             v2ij=v2(j,itori,itori1)
5446             cosphi=dcos(j*phii)
5447             sinphi=dsin(j*phii)
5448             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5449             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5450           enddo
5451         endif
5452         if (lprn)
5453      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5454      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5455      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5456         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5457 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5458       enddo
5459 ! 6/20/98 - dihedral angle constraints
5460       edihcnstr=0.0d0
5461       do i=1,ndih_constr
5462         itori=idih_constr(i)
5463         phii=phi(itori)
5464         difi=phii-phi0(i)
5465         if (difi.gt.drange(i)) then
5466           difi=difi-drange(i)
5467           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5468           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5469         else if (difi.lt.-drange(i)) then
5470           difi=difi+drange(i)
5471           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5472           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5473         endif
5474 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5475 C     &    i,itori,rad2deg*phii,
5476 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5477       enddo
5478 !      write (iout,*) 'edihcnstr',edihcnstr
5479       return
5480       end
5481 c------------------------------------------------------------------------------
5482 #else
5483       subroutine etor(etors,edihcnstr,fact)
5484       implicit real*8 (a-h,o-z)
5485       include 'DIMENSIONS'
5486       include 'DIMENSIONS.ZSCOPT'
5487       include 'COMMON.VAR'
5488       include 'COMMON.GEO'
5489       include 'COMMON.LOCAL'
5490       include 'COMMON.TORSION'
5491       include 'COMMON.INTERACT'
5492       include 'COMMON.DERIV'
5493       include 'COMMON.CHAIN'
5494       include 'COMMON.NAMES'
5495       include 'COMMON.IOUNITS'
5496       include 'COMMON.FFIELD'
5497       include 'COMMON.TORCNSTR'
5498       logical lprn
5499 C Set lprn=.true. for debugging
5500       lprn=.false.
5501 c      lprn=.true.
5502       etors=0.0D0
5503       do i=iphi_start,iphi_end
5504         if (i.le.2) cycle
5505         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5506      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5507 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5508 C     &       .or. itype(i).eq.ntyp1) cycle
5509         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5510          if (iabs(itype(i)).eq.20) then
5511          iblock=2
5512          else
5513          iblock=1
5514          endif
5515         itori=itortyp(itype(i-2))
5516         itori1=itortyp(itype(i-1))
5517         phii=phi(i)
5518         gloci=0.0D0
5519 C Regular cosine and sine terms
5520         do j=1,nterm(itori,itori1,iblock)
5521           v1ij=v1(j,itori,itori1,iblock)
5522           v2ij=v2(j,itori,itori1,iblock)
5523           cosphi=dcos(j*phii)
5524           sinphi=dsin(j*phii)
5525           etors=etors+v1ij*cosphi+v2ij*sinphi
5526           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5527         enddo
5528 C Lorentz terms
5529 C                         v1
5530 C  E = SUM ----------------------------------- - v1
5531 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5532 C
5533         cosphi=dcos(0.5d0*phii)
5534         sinphi=dsin(0.5d0*phii)
5535         do j=1,nlor(itori,itori1,iblock)
5536           vl1ij=vlor1(j,itori,itori1)
5537           vl2ij=vlor2(j,itori,itori1)
5538           vl3ij=vlor3(j,itori,itori1)
5539           pom=vl2ij*cosphi+vl3ij*sinphi
5540           pom1=1.0d0/(pom*pom+1.0d0)
5541           etors=etors+vl1ij*pom1
5542 c          if (energy_dec) etors_ii=etors_ii+
5543 c     &                vl1ij*pom1
5544           pom=-pom*pom1*pom1
5545           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5546         enddo
5547 C Subtract the constant term
5548         etors=etors-v0(itori,itori1,iblock)
5549         if (lprn)
5550      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5551      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5552      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5553         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5554 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5555  1215   continue
5556       enddo
5557 ! 6/20/98 - dihedral angle constraints
5558       edihcnstr=0.0d0
5559       do i=1,ndih_constr
5560         itori=idih_constr(i)
5561         phii=phi(itori)
5562         difi=pinorm(phii-phi0(i))
5563         edihi=0.0d0
5564         if (difi.gt.drange(i)) then
5565           difi=difi-drange(i)
5566           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5567           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5568           edihi=0.25d0*ftors(i)*difi**4
5569         else if (difi.lt.-drange(i)) then
5570           difi=difi+drange(i)
5571           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5572           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5573           edihi=0.25d0*ftors(i)*difi**4
5574         else
5575           difi=0.0d0
5576         endif
5577         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5578      &    i,itori,rad2deg*phii,
5579      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5580 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5581 c     &    drange(i),edihi
5582 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5583 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5584       enddo
5585 !      write (iout,*) 'edihcnstr',edihcnstr
5586       return
5587       end
5588 c----------------------------------------------------------------------------
5589       subroutine etor_d(etors_d,fact2)
5590 C 6/23/01 Compute double torsional energy
5591       implicit real*8 (a-h,o-z)
5592       include 'DIMENSIONS'
5593       include 'DIMENSIONS.ZSCOPT'
5594       include 'COMMON.VAR'
5595       include 'COMMON.GEO'
5596       include 'COMMON.LOCAL'
5597       include 'COMMON.TORSION'
5598       include 'COMMON.INTERACT'
5599       include 'COMMON.DERIV'
5600       include 'COMMON.CHAIN'
5601       include 'COMMON.NAMES'
5602       include 'COMMON.IOUNITS'
5603       include 'COMMON.FFIELD'
5604       include 'COMMON.TORCNSTR'
5605       logical lprn
5606 C Set lprn=.true. for debugging
5607       lprn=.false.
5608 c     lprn=.true.
5609       etors_d=0.0D0
5610       do i=iphi_start,iphi_end-1
5611         if (i.le.3) cycle
5612 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5613 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5614          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5615      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5616      &  (itype(i+1).eq.ntyp1)) cycle
5617         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5618      &     goto 1215
5619         itori=itortyp(itype(i-2))
5620         itori1=itortyp(itype(i-1))
5621         itori2=itortyp(itype(i))
5622         phii=phi(i)
5623         phii1=phi(i+1)
5624         gloci1=0.0D0
5625         gloci2=0.0D0
5626         iblock=1
5627         if (iabs(itype(i+1)).eq.20) iblock=2
5628 C Regular cosine and sine terms
5629         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5630           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5631           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5632           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5633           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5634           cosphi1=dcos(j*phii)
5635           sinphi1=dsin(j*phii)
5636           cosphi2=dcos(j*phii1)
5637           sinphi2=dsin(j*phii1)
5638           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5639      &     v2cij*cosphi2+v2sij*sinphi2
5640           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5641           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5642         enddo
5643         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5644           do l=1,k-1
5645             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5646             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5647             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5648             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5649             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5650             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5651             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5652             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5653             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5654      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5655             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5656      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5657             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5658      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5659           enddo
5660         enddo
5661         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5662         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5663  1215   continue
5664       enddo
5665       return
5666       end
5667 #endif
5668 c------------------------------------------------------------------------------
5669       subroutine eback_sc_corr(esccor)
5670 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5671 c        conformational states; temporarily implemented as differences
5672 c        between UNRES torsional potentials (dependent on three types of
5673 c        residues) and the torsional potentials dependent on all 20 types
5674 c        of residues computed from AM1 energy surfaces of terminally-blocked
5675 c        amino-acid residues.
5676       implicit real*8 (a-h,o-z)
5677       include 'DIMENSIONS'
5678       include 'DIMENSIONS.ZSCOPT'
5679       include 'DIMENSIONS.FREE'
5680       include 'COMMON.VAR'
5681       include 'COMMON.GEO'
5682       include 'COMMON.LOCAL'
5683       include 'COMMON.TORSION'
5684       include 'COMMON.SCCOR'
5685       include 'COMMON.INTERACT'
5686       include 'COMMON.DERIV'
5687       include 'COMMON.CHAIN'
5688       include 'COMMON.NAMES'
5689       include 'COMMON.IOUNITS'
5690       include 'COMMON.FFIELD'
5691       include 'COMMON.CONTROL'
5692       logical lprn
5693 C Set lprn=.true. for debugging
5694       lprn=.false.
5695 c      lprn=.true.
5696 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5697       esccor=0.0D0
5698       do i=itau_start,itau_end
5699         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5700         esccor_ii=0.0D0
5701         isccori=isccortyp(itype(i-2))
5702         isccori1=isccortyp(itype(i-1))
5703         phii=phi(i)
5704         do intertyp=1,3 !intertyp
5705 cc Added 09 May 2012 (Adasko)
5706 cc  Intertyp means interaction type of backbone mainchain correlation:
5707 c   1 = SC...Ca...Ca...Ca
5708 c   2 = Ca...Ca...Ca...SC
5709 c   3 = SC...Ca...Ca...SCi
5710         gloci=0.0D0
5711         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5712      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5713      &      (itype(i-1).eq.ntyp1)))
5714      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5715      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5716      &     .or.(itype(i).eq.ntyp1)))
5717      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5718      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5719      &      (itype(i-3).eq.ntyp1)))) cycle
5720         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5721         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5722      & cycle
5723        do j=1,nterm_sccor(isccori,isccori1)
5724           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5725           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5726           cosphi=dcos(j*tauangle(intertyp,i))
5727           sinphi=dsin(j*tauangle(intertyp,i))
5728            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5729            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5730          enddo
5731 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5732 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5733 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5734         if (lprn)
5735      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5736      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5737      &  (v1sccor(j,1,itori,itori1),j=1,6)
5738      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5739 c        gsccor_loc(i-3)=gloci
5740        enddo !intertyp
5741       enddo
5742       return
5743       end
5744 c------------------------------------------------------------------------------
5745       subroutine multibody(ecorr)
5746 C This subroutine calculates multi-body contributions to energy following
5747 C the idea of Skolnick et al. If side chains I and J make a contact and
5748 C at the same time side chains I+1 and J+1 make a contact, an extra
5749 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5750       implicit real*8 (a-h,o-z)
5751       include 'DIMENSIONS'
5752       include 'COMMON.IOUNITS'
5753       include 'COMMON.DERIV'
5754       include 'COMMON.INTERACT'
5755       include 'COMMON.CONTACTS'
5756       double precision gx(3),gx1(3)
5757       logical lprn
5758
5759 C Set lprn=.true. for debugging
5760       lprn=.false.
5761
5762       if (lprn) then
5763         write (iout,'(a)') 'Contact function values:'
5764         do i=nnt,nct-2
5765           write (iout,'(i2,20(1x,i2,f10.5))')
5766      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5767         enddo
5768       endif
5769       ecorr=0.0D0
5770       do i=nnt,nct
5771         do j=1,3
5772           gradcorr(j,i)=0.0D0
5773           gradxorr(j,i)=0.0D0
5774         enddo
5775       enddo
5776       do i=nnt,nct-2
5777
5778         DO ISHIFT = 3,4
5779
5780         i1=i+ishift
5781         num_conti=num_cont(i)
5782         num_conti1=num_cont(i1)
5783         do jj=1,num_conti
5784           j=jcont(jj,i)
5785           do kk=1,num_conti1
5786             j1=jcont(kk,i1)
5787             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5788 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5789 cd   &                   ' ishift=',ishift
5790 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5791 C The system gains extra energy.
5792               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5793             endif   ! j1==j+-ishift
5794           enddo     ! kk
5795         enddo       ! jj
5796
5797         ENDDO ! ISHIFT
5798
5799       enddo         ! i
5800       return
5801       end
5802 c------------------------------------------------------------------------------
5803       double precision function esccorr(i,j,k,l,jj,kk)
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       include 'COMMON.IOUNITS'
5807       include 'COMMON.DERIV'
5808       include 'COMMON.INTERACT'
5809       include 'COMMON.CONTACTS'
5810       double precision gx(3),gx1(3)
5811       logical lprn
5812       lprn=.false.
5813       eij=facont(jj,i)
5814       ekl=facont(kk,k)
5815 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5816 C Calculate the multi-body contribution to energy.
5817 C Calculate multi-body contributions to the gradient.
5818 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5819 cd   & k,l,(gacont(m,kk,k),m=1,3)
5820       do m=1,3
5821         gx(m) =ekl*gacont(m,jj,i)
5822         gx1(m)=eij*gacont(m,kk,k)
5823         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5824         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5825         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5826         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5827       enddo
5828       do m=i,j-1
5829         do ll=1,3
5830           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5831         enddo
5832       enddo
5833       do m=k,l-1
5834         do ll=1,3
5835           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5836         enddo
5837       enddo
5838       esccorr=-eij*ekl
5839       return
5840       end
5841 c------------------------------------------------------------------------------
5842 #ifdef MPL
5843       subroutine pack_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),ees0m(ntyp,maxres),
5851      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5852       num_kont=num_cont_hb(atom)
5853       do i=1,num_kont
5854         do k=1,7
5855           do j=1,3
5856             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5857           enddo ! j
5858         enddo ! k
5859         buffer(i,indx+22)=facont_hb(i,atom)
5860         buffer(i,indx+23)=ees0p(i,atom)
5861         buffer(i,indx+24)=ees0m(i,atom)
5862         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5863       enddo ! i
5864       buffer(1,indx+26)=dfloat(num_kont)
5865       return
5866       end
5867 c------------------------------------------------------------------------------
5868       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       integer dimen1,dimen2,atom,indx
5872       double precision buffer(dimen1,dimen2)
5873       double precision zapas
5874       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5875      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5876      &         ees0m(ntyp,maxres),
5877      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5878       num_kont=buffer(1,indx+26)
5879       num_kont_old=num_cont_hb(atom)
5880       num_cont_hb(atom)=num_kont+num_kont_old
5881       do i=1,num_kont
5882         ii=i+num_kont_old
5883         do k=1,7
5884           do j=1,3
5885             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5886           enddo ! j
5887         enddo ! k
5888         facont_hb(ii,atom)=buffer(i,indx+22)
5889         ees0p(ii,atom)=buffer(i,indx+23)
5890         ees0m(ii,atom)=buffer(i,indx+24)
5891         jcont_hb(ii,atom)=buffer(i,indx+25)
5892       enddo ! i
5893       return
5894       end
5895 c------------------------------------------------------------------------------
5896 #endif
5897       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5898 C This subroutine calculates multi-body contributions to hydrogen-bonding
5899       implicit real*8 (a-h,o-z)
5900       include 'DIMENSIONS'
5901       include 'DIMENSIONS.ZSCOPT'
5902       include 'COMMON.IOUNITS'
5903 #ifdef MPL
5904       include 'COMMON.INFO'
5905 #endif
5906       include 'COMMON.FFIELD'
5907       include 'COMMON.DERIV'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.CONTACTS'
5910 #ifdef MPL
5911       parameter (max_cont=maxconts)
5912       parameter (max_dim=2*(8*3+2))
5913       parameter (msglen1=max_cont*max_dim*4)
5914       parameter (msglen2=2*msglen1)
5915       integer source,CorrelType,CorrelID,Error
5916       double precision buffer(max_cont,max_dim)
5917 #endif
5918       double precision gx(3),gx1(3)
5919       logical lprn,ldone
5920
5921 C Set lprn=.true. for debugging
5922       lprn=.false.
5923 #ifdef MPL
5924       n_corr=0
5925       n_corr1=0
5926       if (fgProcs.le.1) goto 30
5927       if (lprn) then
5928         write (iout,'(a)') 'Contact function values:'
5929         do i=nnt,nct-2
5930           write (iout,'(2i3,50(1x,i2,f5.2))')
5931      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5932      &    j=1,num_cont_hb(i))
5933         enddo
5934       endif
5935 C Caution! Following code assumes that electrostatic interactions concerning
5936 C a given atom are split among at most two processors!
5937       CorrelType=477
5938       CorrelID=MyID+1
5939       ldone=.false.
5940       do i=1,max_cont
5941         do j=1,max_dim
5942           buffer(i,j)=0.0D0
5943         enddo
5944       enddo
5945       mm=mod(MyRank,2)
5946 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5947       if (mm) 20,20,10
5948    10 continue
5949 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5950       if (MyRank.gt.0) then
5951 C Send correlation contributions to the preceding processor
5952         msglen=msglen1
5953         nn=num_cont_hb(iatel_s)
5954         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5955 cd      write (iout,*) 'The BUFFER array:'
5956 cd      do i=1,nn
5957 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5958 cd      enddo
5959         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5960           msglen=msglen2
5961             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5962 C Clear the contacts of the atom passed to the neighboring processor
5963         nn=num_cont_hb(iatel_s+1)
5964 cd      do i=1,nn
5965 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5966 cd      enddo
5967             num_cont_hb(iatel_s)=0
5968         endif
5969 cd      write (iout,*) 'Processor ',MyID,MyRank,
5970 cd   & ' is sending correlation contribution to processor',MyID-1,
5971 cd   & ' msglen=',msglen
5972 cd      write (*,*) 'Processor ',MyID,MyRank,
5973 cd   & ' is sending correlation contribution to processor',MyID-1,
5974 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5975         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5976 cd      write (iout,*) 'Processor ',MyID,
5977 cd   & ' has sent correlation contribution to processor',MyID-1,
5978 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5979 cd      write (*,*) 'Processor ',MyID,
5980 cd   & ' has sent correlation contribution to processor',MyID-1,
5981 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5982         msglen=msglen1
5983       endif ! (MyRank.gt.0)
5984       if (ldone) goto 30
5985       ldone=.true.
5986    20 continue
5987 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5988       if (MyRank.lt.fgProcs-1) then
5989 C Receive correlation contributions from the next processor
5990         msglen=msglen1
5991         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5992 cd      write (iout,*) 'Processor',MyID,
5993 cd   & ' is receiving correlation contribution from processor',MyID+1,
5994 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5995 cd      write (*,*) 'Processor',MyID,
5996 cd   & ' is receiving correlation contribution from processor',MyID+1,
5997 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5998         nbytes=-1
5999         do while (nbytes.le.0)
6000           call mp_probe(MyID+1,CorrelType,nbytes)
6001         enddo
6002 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6003         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6004 cd      write (iout,*) 'Processor',MyID,
6005 cd   & ' has received correlation contribution from processor',MyID+1,
6006 cd   & ' msglen=',msglen,' nbytes=',nbytes
6007 cd      write (iout,*) 'The received BUFFER array:'
6008 cd      do i=1,max_cont
6009 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6010 cd      enddo
6011         if (msglen.eq.msglen1) then
6012           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6013         else if (msglen.eq.msglen2)  then
6014           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6015           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6016         else
6017           write (iout,*)
6018      & 'ERROR!!!! message length changed while processing correlations.'
6019           write (*,*)
6020      & 'ERROR!!!! message length changed while processing correlations.'
6021           call mp_stopall(Error)
6022         endif ! msglen.eq.msglen1
6023       endif ! MyRank.lt.fgProcs-1
6024       if (ldone) goto 30
6025       ldone=.true.
6026       goto 10
6027    30 continue
6028 #endif
6029       if (lprn) then
6030         write (iout,'(a)') 'Contact function values:'
6031         do i=nnt,nct-2
6032           write (iout,'(2i3,50(1x,i2,f5.2))')
6033      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6034      &    j=1,num_cont_hb(i))
6035         enddo
6036       endif
6037       ecorr=0.0D0
6038 C Remove the loop below after debugging !!!
6039       do i=nnt,nct
6040         do j=1,3
6041           gradcorr(j,i)=0.0D0
6042           gradxorr(j,i)=0.0D0
6043         enddo
6044       enddo
6045 C Calculate the local-electrostatic correlation terms
6046       do i=iatel_s,iatel_e+1
6047         i1=i+1
6048         num_conti=num_cont_hb(i)
6049         num_conti1=num_cont_hb(i+1)
6050         do jj=1,num_conti
6051           j=jcont_hb(jj,i)
6052           do kk=1,num_conti1
6053             j1=jcont_hb(kk,i1)
6054 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6055 c     &         ' jj=',jj,' kk=',kk
6056             if (j1.eq.j+1 .or. j1.eq.j-1) then
6057 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6058 C The system gains extra energy.
6059               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6060               n_corr=n_corr+1
6061             else if (j1.eq.j) then
6062 C Contacts I-J and I-(J+1) occur simultaneously.
6063 C The system loses extra energy.
6064 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6065             endif
6066           enddo ! kk
6067           do kk=1,num_conti
6068             j1=jcont_hb(kk,i)
6069 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6070 c    &         ' jj=',jj,' kk=',kk
6071             if (j1.eq.j+1) then
6072 C Contacts I-J and (I+1)-J occur simultaneously.
6073 C The system loses extra energy.
6074 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6075             endif ! j1==j+1
6076           enddo ! kk
6077         enddo ! jj
6078       enddo ! i
6079       return
6080       end
6081 c------------------------------------------------------------------------------
6082       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6083      &  n_corr1)
6084 C This subroutine calculates multi-body contributions to hydrogen-bonding
6085       implicit real*8 (a-h,o-z)
6086       include 'DIMENSIONS'
6087       include 'DIMENSIONS.ZSCOPT'
6088       include 'COMMON.IOUNITS'
6089 #ifdef MPL
6090       include 'COMMON.INFO'
6091 #endif
6092       include 'COMMON.FFIELD'
6093       include 'COMMON.DERIV'
6094       include 'COMMON.INTERACT'
6095       include 'COMMON.CONTACTS'
6096 #ifdef MPL
6097       parameter (max_cont=maxconts)
6098       parameter (max_dim=2*(8*3+2))
6099       parameter (msglen1=max_cont*max_dim*4)
6100       parameter (msglen2=2*msglen1)
6101       integer source,CorrelType,CorrelID,Error
6102       double precision buffer(max_cont,max_dim)
6103 #endif
6104       double precision gx(3),gx1(3)
6105       logical lprn,ldone
6106
6107 C Set lprn=.true. for debugging
6108       lprn=.false.
6109       eturn6=0.0d0
6110       ecorr6=0.0d0
6111 #ifdef MPL
6112       n_corr=0
6113       n_corr1=0
6114       if (fgProcs.le.1) goto 30
6115       if (lprn) then
6116         write (iout,'(a)') 'Contact function values:'
6117         do i=nnt,nct-2
6118           write (iout,'(2i3,50(1x,i2,f5.2))')
6119      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6120      &    j=1,num_cont_hb(i))
6121         enddo
6122       endif
6123 C Caution! Following code assumes that electrostatic interactions concerning
6124 C a given atom are split among at most two processors!
6125       CorrelType=477
6126       CorrelID=MyID+1
6127       ldone=.false.
6128       do i=1,max_cont
6129         do j=1,max_dim
6130           buffer(i,j)=0.0D0
6131         enddo
6132       enddo
6133       mm=mod(MyRank,2)
6134 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6135       if (mm) 20,20,10
6136    10 continue
6137 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6138       if (MyRank.gt.0) then
6139 C Send correlation contributions to the preceding processor
6140         msglen=msglen1
6141         nn=num_cont_hb(iatel_s)
6142         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6143 cd      write (iout,*) 'The BUFFER array:'
6144 cd      do i=1,nn
6145 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6146 cd      enddo
6147         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6148           msglen=msglen2
6149             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6150 C Clear the contacts of the atom passed to the neighboring processor
6151         nn=num_cont_hb(iatel_s+1)
6152 cd      do i=1,nn
6153 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6154 cd      enddo
6155             num_cont_hb(iatel_s)=0
6156         endif
6157 cd      write (iout,*) 'Processor ',MyID,MyRank,
6158 cd   & ' is sending correlation contribution to processor',MyID-1,
6159 cd   & ' msglen=',msglen
6160 cd      write (*,*) 'Processor ',MyID,MyRank,
6161 cd   & ' is sending correlation contribution to processor',MyID-1,
6162 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6163         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6164 cd      write (iout,*) 'Processor ',MyID,
6165 cd   & ' has sent correlation contribution to processor',MyID-1,
6166 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6167 cd      write (*,*) 'Processor ',MyID,
6168 cd   & ' has sent correlation contribution to processor',MyID-1,
6169 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6170         msglen=msglen1
6171       endif ! (MyRank.gt.0)
6172       if (ldone) goto 30
6173       ldone=.true.
6174    20 continue
6175 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6176       if (MyRank.lt.fgProcs-1) then
6177 C Receive correlation contributions from the next processor
6178         msglen=msglen1
6179         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6180 cd      write (iout,*) 'Processor',MyID,
6181 cd   & ' is receiving correlation contribution from processor',MyID+1,
6182 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6183 cd      write (*,*) 'Processor',MyID,
6184 cd   & ' is receiving correlation contribution from processor',MyID+1,
6185 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6186         nbytes=-1
6187         do while (nbytes.le.0)
6188           call mp_probe(MyID+1,CorrelType,nbytes)
6189         enddo
6190 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6191         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6192 cd      write (iout,*) 'Processor',MyID,
6193 cd   & ' has received correlation contribution from processor',MyID+1,
6194 cd   & ' msglen=',msglen,' nbytes=',nbytes
6195 cd      write (iout,*) 'The received BUFFER array:'
6196 cd      do i=1,max_cont
6197 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6198 cd      enddo
6199         if (msglen.eq.msglen1) then
6200           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6201         else if (msglen.eq.msglen2)  then
6202           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6203           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6204         else
6205           write (iout,*)
6206      & 'ERROR!!!! message length changed while processing correlations.'
6207           write (*,*)
6208      & 'ERROR!!!! message length changed while processing correlations.'
6209           call mp_stopall(Error)
6210         endif ! msglen.eq.msglen1
6211       endif ! MyRank.lt.fgProcs-1
6212       if (ldone) goto 30
6213       ldone=.true.
6214       goto 10
6215    30 continue
6216 #endif
6217       if (lprn) then
6218         write (iout,'(a)') 'Contact function values:'
6219         do i=nnt,nct-2
6220           write (iout,'(2i3,50(1x,i2,f5.2))')
6221      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6222      &    j=1,num_cont_hb(i))
6223         enddo
6224       endif
6225       ecorr=0.0D0
6226       ecorr5=0.0d0
6227       ecorr6=0.0d0
6228 C Remove the loop below after debugging !!!
6229       do i=nnt,nct
6230         do j=1,3
6231           gradcorr(j,i)=0.0D0
6232           gradxorr(j,i)=0.0D0
6233         enddo
6234       enddo
6235 C Calculate the dipole-dipole interaction energies
6236       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6237       do i=iatel_s,iatel_e+1
6238         num_conti=num_cont_hb(i)
6239         do jj=1,num_conti
6240           j=jcont_hb(jj,i)
6241           call dipole(i,j,jj)
6242         enddo
6243       enddo
6244       endif
6245 C Calculate the local-electrostatic correlation terms
6246       do i=iatel_s,iatel_e+1
6247         i1=i+1
6248         num_conti=num_cont_hb(i)
6249         num_conti1=num_cont_hb(i+1)
6250         do jj=1,num_conti
6251           j=jcont_hb(jj,i)
6252           do kk=1,num_conti1
6253             j1=jcont_hb(kk,i1)
6254 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6255 c     &         ' jj=',jj,' kk=',kk
6256             if (j1.eq.j+1 .or. j1.eq.j-1) then
6257 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6258 C The system gains extra energy.
6259               n_corr=n_corr+1
6260               sqd1=dsqrt(d_cont(jj,i))
6261               sqd2=dsqrt(d_cont(kk,i1))
6262               sred_geom = sqd1*sqd2
6263               IF (sred_geom.lt.cutoff_corr) THEN
6264                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6265      &            ekont,fprimcont)
6266 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6267 c     &         ' jj=',jj,' kk=',kk
6268                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6269                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6270                 do l=1,3
6271                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6272                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6273                 enddo
6274                 n_corr1=n_corr1+1
6275 cd               write (iout,*) 'sred_geom=',sred_geom,
6276 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6277                 call calc_eello(i,j,i+1,j1,jj,kk)
6278                 if (wcorr4.gt.0.0d0)
6279      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6280                 if (wcorr5.gt.0.0d0)
6281      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6282 c                print *,"wcorr5",ecorr5
6283 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6284 cd                write(2,*)'ijkl',i,j,i+1,j1
6285                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6286      &               .or. wturn6.eq.0.0d0))then
6287 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6288                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6289 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6290 cd     &            'ecorr6=',ecorr6
6291 cd                write (iout,'(4e15.5)') sred_geom,
6292 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6293 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6294 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6295                 else if (wturn6.gt.0.0d0
6296      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6297 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6298                   eturn6=eturn6+eello_turn6(i,jj,kk)
6299 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6300                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6301                    eturn6=0.0d0
6302                    ecorr6=0.0d0
6303                 endif
6304
6305               ENDIF
6306 1111          continue
6307             else if (j1.eq.j) then
6308 C Contacts I-J and I-(J+1) occur simultaneously.
6309 C The system loses extra energy.
6310 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6311             endif
6312           enddo ! kk
6313           do kk=1,num_conti
6314             j1=jcont_hb(kk,i)
6315 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6316 c    &         ' jj=',jj,' kk=',kk
6317             if (j1.eq.j+1) then
6318 C Contacts I-J and (I+1)-J occur simultaneously.
6319 C The system loses extra energy.
6320 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6321             endif ! j1==j+1
6322           enddo ! kk
6323         enddo ! jj
6324       enddo ! i
6325       write (iout,*) "eturn6",eturn6,ecorr6
6326       return
6327       end
6328 c------------------------------------------------------------------------------
6329       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6330       implicit real*8 (a-h,o-z)
6331       include 'DIMENSIONS'
6332       include 'COMMON.IOUNITS'
6333       include 'COMMON.DERIV'
6334       include 'COMMON.INTERACT'
6335       include 'COMMON.CONTACTS'
6336       double precision gx(3),gx1(3)
6337       logical lprn
6338       lprn=.false.
6339       eij=facont_hb(jj,i)
6340       ekl=facont_hb(kk,k)
6341       ees0pij=ees0p(jj,i)
6342       ees0pkl=ees0p(kk,k)
6343       ees0mij=ees0m(jj,i)
6344       ees0mkl=ees0m(kk,k)
6345       ekont=eij*ekl
6346       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6347 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6348 C Following 4 lines for diagnostics.
6349 cd    ees0pkl=0.0D0
6350 cd    ees0pij=1.0D0
6351 cd    ees0mkl=0.0D0
6352 cd    ees0mij=1.0D0
6353 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6354 c    &   ' and',k,l
6355 c     write (iout,*)'Contacts have occurred for peptide groups',
6356 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6357 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6358 C Calculate the multi-body contribution to energy.
6359       ecorr=ecorr+ekont*ees
6360       if (calc_grad) then
6361 C Calculate multi-body contributions to the gradient.
6362       do ll=1,3
6363         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6364         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6365      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6366      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6367         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6368      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6369      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6370         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6371         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6372      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6373      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6374         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6375      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6376      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6377       enddo
6378       do m=i+1,j-1
6379         do ll=1,3
6380           gradcorr(ll,m)=gradcorr(ll,m)+
6381      &     ees*ekl*gacont_hbr(ll,jj,i)-
6382      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6383      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6384         enddo
6385       enddo
6386       do m=k+1,l-1
6387         do ll=1,3
6388           gradcorr(ll,m)=gradcorr(ll,m)+
6389      &     ees*eij*gacont_hbr(ll,kk,k)-
6390      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6391      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6392         enddo
6393       enddo
6394       endif
6395       ehbcorr=ekont*ees
6396       return
6397       end
6398 C---------------------------------------------------------------------------
6399       subroutine dipole(i,j,jj)
6400       implicit real*8 (a-h,o-z)
6401       include 'DIMENSIONS'
6402       include 'DIMENSIONS.ZSCOPT'
6403       include 'COMMON.IOUNITS'
6404       include 'COMMON.CHAIN'
6405       include 'COMMON.FFIELD'
6406       include 'COMMON.DERIV'
6407       include 'COMMON.INTERACT'
6408       include 'COMMON.CONTACTS'
6409       include 'COMMON.TORSION'
6410       include 'COMMON.VAR'
6411       include 'COMMON.GEO'
6412       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6413      &  auxmat(2,2)
6414       iti1 = itortyp(itype(i+1))
6415       if (j.lt.nres-1) then
6416         if (itype(j).le.ntyp) then
6417           itj1 = itortyp(itype(j+1))
6418         else
6419           itj=ntortyp+1
6420         endif
6421       else
6422         itj1=ntortyp+1
6423       endif
6424       do iii=1,2
6425         dipi(iii,1)=Ub2(iii,i)
6426         dipderi(iii)=Ub2der(iii,i)
6427         dipi(iii,2)=b1(iii,iti1)
6428         dipj(iii,1)=Ub2(iii,j)
6429         dipderj(iii)=Ub2der(iii,j)
6430         dipj(iii,2)=b1(iii,itj1)
6431       enddo
6432       kkk=0
6433       do iii=1,2
6434         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6435         do jjj=1,2
6436           kkk=kkk+1
6437           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6438         enddo
6439       enddo
6440       if (.not.calc_grad) return
6441       do kkk=1,5
6442         do lll=1,3
6443           mmm=0
6444           do iii=1,2
6445             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6446      &        auxvec(1))
6447             do jjj=1,2
6448               mmm=mmm+1
6449               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6450             enddo
6451           enddo
6452         enddo
6453       enddo
6454       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6455       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6456       do iii=1,2
6457         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6458       enddo
6459       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6460       do iii=1,2
6461         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6462       enddo
6463       return
6464       end
6465 C---------------------------------------------------------------------------
6466       subroutine calc_eello(i,j,k,l,jj,kk)
6467 C
6468 C This subroutine computes matrices and vectors needed to calculate
6469 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6470 C
6471       implicit real*8 (a-h,o-z)
6472       include 'DIMENSIONS'
6473       include 'DIMENSIONS.ZSCOPT'
6474       include 'COMMON.IOUNITS'
6475       include 'COMMON.CHAIN'
6476       include 'COMMON.DERIV'
6477       include 'COMMON.INTERACT'
6478       include 'COMMON.CONTACTS'
6479       include 'COMMON.TORSION'
6480       include 'COMMON.VAR'
6481       include 'COMMON.GEO'
6482       include 'COMMON.FFIELD'
6483       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6484      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6485       logical lprn
6486       common /kutas/ lprn
6487 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6488 cd     & ' jj=',jj,' kk=',kk
6489 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6490       do iii=1,2
6491         do jjj=1,2
6492           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6493           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6494         enddo
6495       enddo
6496       call transpose2(aa1(1,1),aa1t(1,1))
6497       call transpose2(aa2(1,1),aa2t(1,1))
6498       do kkk=1,5
6499         do lll=1,3
6500           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6501      &      aa1tder(1,1,lll,kkk))
6502           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6503      &      aa2tder(1,1,lll,kkk))
6504         enddo
6505       enddo
6506       if (l.eq.j+1) then
6507 C parallel orientation of the two CA-CA-CA frames.
6508         if (i.gt.1 .and. itype(i).le.ntyp) then
6509           iti=itortyp(itype(i))
6510         else
6511           iti=ntortyp+1
6512         endif
6513         itk1=itortyp(itype(k+1))
6514         itj=itortyp(itype(j))
6515         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6516           itl1=itortyp(itype(l+1))
6517         else
6518           itl1=ntortyp+1
6519         endif
6520 C A1 kernel(j+1) A2T
6521 cd        do iii=1,2
6522 cd          write (iout,'(3f10.5,5x,3f10.5)')
6523 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6524 cd        enddo
6525         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6526      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6527      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6528 C Following matrices are needed only for 6-th order cumulants
6529         IF (wcorr6.gt.0.0d0) THEN
6530         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6531      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6532      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6533         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6534      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6535      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6536      &   ADtEAderx(1,1,1,1,1,1))
6537         lprn=.false.
6538         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6539      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6540      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6541      &   ADtEA1derx(1,1,1,1,1,1))
6542         ENDIF
6543 C End 6-th order cumulants
6544 cd        lprn=.false.
6545 cd        if (lprn) then
6546 cd        write (2,*) 'In calc_eello6'
6547 cd        do iii=1,2
6548 cd          write (2,*) 'iii=',iii
6549 cd          do kkk=1,5
6550 cd            write (2,*) 'kkk=',kkk
6551 cd            do jjj=1,2
6552 cd              write (2,'(3(2f10.5),5x)')
6553 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6554 cd            enddo
6555 cd          enddo
6556 cd        enddo
6557 cd        endif
6558         call transpose2(EUgder(1,1,k),auxmat(1,1))
6559         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6560         call transpose2(EUg(1,1,k),auxmat(1,1))
6561         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6562         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6563         do iii=1,2
6564           do kkk=1,5
6565             do lll=1,3
6566               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6567      &          EAEAderx(1,1,lll,kkk,iii,1))
6568             enddo
6569           enddo
6570         enddo
6571 C A1T kernel(i+1) A2
6572         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6573      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6574      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6575 C Following matrices are needed only for 6-th order cumulants
6576         IF (wcorr6.gt.0.0d0) THEN
6577         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6578      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6579      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6580         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6581      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6582      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6583      &   ADtEAderx(1,1,1,1,1,2))
6584         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6585      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6586      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6587      &   ADtEA1derx(1,1,1,1,1,2))
6588         ENDIF
6589 C End 6-th order cumulants
6590         call transpose2(EUgder(1,1,l),auxmat(1,1))
6591         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6592         call transpose2(EUg(1,1,l),auxmat(1,1))
6593         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6594         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6595         do iii=1,2
6596           do kkk=1,5
6597             do lll=1,3
6598               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6599      &          EAEAderx(1,1,lll,kkk,iii,2))
6600             enddo
6601           enddo
6602         enddo
6603 C AEAb1 and AEAb2
6604 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6605 C They are needed only when the fifth- or the sixth-order cumulants are
6606 C indluded.
6607         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6608         call transpose2(AEA(1,1,1),auxmat(1,1))
6609         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6610         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6611         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6612         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6613         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6614         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6615         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6616         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6617         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6618         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6619         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6620         call transpose2(AEA(1,1,2),auxmat(1,1))
6621         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6622         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6623         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6624         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6625         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6626         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6627         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6628         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6629         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6630         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6631         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6632 C Calculate the Cartesian derivatives of the vectors.
6633         do iii=1,2
6634           do kkk=1,5
6635             do lll=1,3
6636               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6637               call matvec2(auxmat(1,1),b1(1,iti),
6638      &          AEAb1derx(1,lll,kkk,iii,1,1))
6639               call matvec2(auxmat(1,1),Ub2(1,i),
6640      &          AEAb2derx(1,lll,kkk,iii,1,1))
6641               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6642      &          AEAb1derx(1,lll,kkk,iii,2,1))
6643               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6644      &          AEAb2derx(1,lll,kkk,iii,2,1))
6645               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6646               call matvec2(auxmat(1,1),b1(1,itj),
6647      &          AEAb1derx(1,lll,kkk,iii,1,2))
6648               call matvec2(auxmat(1,1),Ub2(1,j),
6649      &          AEAb2derx(1,lll,kkk,iii,1,2))
6650               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6651      &          AEAb1derx(1,lll,kkk,iii,2,2))
6652               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6653      &          AEAb2derx(1,lll,kkk,iii,2,2))
6654             enddo
6655           enddo
6656         enddo
6657         ENDIF
6658 C End vectors
6659       else
6660 C Antiparallel orientation of the two CA-CA-CA frames.
6661         if (i.gt.1 .and. itype(i).le.ntyp) then
6662           iti=itortyp(itype(i))
6663         else
6664           iti=ntortyp+1
6665         endif
6666         itk1=itortyp(itype(k+1))
6667         itl=itortyp(itype(l))
6668         itj=itortyp(itype(j))
6669         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6670           itj1=itortyp(itype(j+1))
6671         else
6672           itj1=ntortyp+1
6673         endif
6674 C A2 kernel(j-1)T A1T
6675         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6676      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6677      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6678 C Following matrices are needed only for 6-th order cumulants
6679         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6680      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6681         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6682      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6683      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6684         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6685      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6686      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6687      &   ADtEAderx(1,1,1,1,1,1))
6688         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6689      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6690      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6691      &   ADtEA1derx(1,1,1,1,1,1))
6692         ENDIF
6693 C End 6-th order cumulants
6694         call transpose2(EUgder(1,1,k),auxmat(1,1))
6695         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6696         call transpose2(EUg(1,1,k),auxmat(1,1))
6697         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6698         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6699         do iii=1,2
6700           do kkk=1,5
6701             do lll=1,3
6702               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6703      &          EAEAderx(1,1,lll,kkk,iii,1))
6704             enddo
6705           enddo
6706         enddo
6707 C A2T kernel(i+1)T A1
6708         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6709      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6710      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6711 C Following matrices are needed only for 6-th order cumulants
6712         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6713      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6714         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6715      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6716      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6717         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6718      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6719      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6720      &   ADtEAderx(1,1,1,1,1,2))
6721         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6722      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6723      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6724      &   ADtEA1derx(1,1,1,1,1,2))
6725         ENDIF
6726 C End 6-th order cumulants
6727         call transpose2(EUgder(1,1,j),auxmat(1,1))
6728         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6729         call transpose2(EUg(1,1,j),auxmat(1,1))
6730         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6731         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6732         do iii=1,2
6733           do kkk=1,5
6734             do lll=1,3
6735               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6736      &          EAEAderx(1,1,lll,kkk,iii,2))
6737             enddo
6738           enddo
6739         enddo
6740 C AEAb1 and AEAb2
6741 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6742 C They are needed only when the fifth- or the sixth-order cumulants are
6743 C indluded.
6744         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6745      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6746         call transpose2(AEA(1,1,1),auxmat(1,1))
6747         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6748         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6749         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6750         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6751         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6752         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6753         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6754         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6755         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6756         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6757         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6758         call transpose2(AEA(1,1,2),auxmat(1,1))
6759         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6760         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6761         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6762         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6763         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6764         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6765         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6766         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6767         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6768         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6769         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6770 C Calculate the Cartesian derivatives of the vectors.
6771         do iii=1,2
6772           do kkk=1,5
6773             do lll=1,3
6774               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6775               call matvec2(auxmat(1,1),b1(1,iti),
6776      &          AEAb1derx(1,lll,kkk,iii,1,1))
6777               call matvec2(auxmat(1,1),Ub2(1,i),
6778      &          AEAb2derx(1,lll,kkk,iii,1,1))
6779               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6780      &          AEAb1derx(1,lll,kkk,iii,2,1))
6781               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6782      &          AEAb2derx(1,lll,kkk,iii,2,1))
6783               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6784               call matvec2(auxmat(1,1),b1(1,itl),
6785      &          AEAb1derx(1,lll,kkk,iii,1,2))
6786               call matvec2(auxmat(1,1),Ub2(1,l),
6787      &          AEAb2derx(1,lll,kkk,iii,1,2))
6788               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6789      &          AEAb1derx(1,lll,kkk,iii,2,2))
6790               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6791      &          AEAb2derx(1,lll,kkk,iii,2,2))
6792             enddo
6793           enddo
6794         enddo
6795         ENDIF
6796 C End vectors
6797       endif
6798       return
6799       end
6800 C---------------------------------------------------------------------------
6801       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6802      &  KK,KKderg,AKA,AKAderg,AKAderx)
6803       implicit none
6804       integer nderg
6805       logical transp
6806       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6807      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6808      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6809       integer iii,kkk,lll
6810       integer jjj,mmm
6811       logical lprn
6812       common /kutas/ lprn
6813       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6814       do iii=1,nderg
6815         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6816      &    AKAderg(1,1,iii))
6817       enddo
6818 cd      if (lprn) write (2,*) 'In kernel'
6819       do kkk=1,5
6820 cd        if (lprn) write (2,*) 'kkk=',kkk
6821         do lll=1,3
6822           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6823      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6824 cd          if (lprn) then
6825 cd            write (2,*) 'lll=',lll
6826 cd            write (2,*) 'iii=1'
6827 cd            do jjj=1,2
6828 cd              write (2,'(3(2f10.5),5x)')
6829 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6830 cd            enddo
6831 cd          endif
6832           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6833      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6834 cd          if (lprn) then
6835 cd            write (2,*) 'lll=',lll
6836 cd            write (2,*) 'iii=2'
6837 cd            do jjj=1,2
6838 cd              write (2,'(3(2f10.5),5x)')
6839 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6840 cd            enddo
6841 cd          endif
6842         enddo
6843       enddo
6844       return
6845       end
6846 C---------------------------------------------------------------------------
6847       double precision function eello4(i,j,k,l,jj,kk)
6848       implicit real*8 (a-h,o-z)
6849       include 'DIMENSIONS'
6850       include 'DIMENSIONS.ZSCOPT'
6851       include 'COMMON.IOUNITS'
6852       include 'COMMON.CHAIN'
6853       include 'COMMON.DERIV'
6854       include 'COMMON.INTERACT'
6855       include 'COMMON.CONTACTS'
6856       include 'COMMON.TORSION'
6857       include 'COMMON.VAR'
6858       include 'COMMON.GEO'
6859       double precision pizda(2,2),ggg1(3),ggg2(3)
6860 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6861 cd        eello4=0.0d0
6862 cd        return
6863 cd      endif
6864 cd      print *,'eello4:',i,j,k,l,jj,kk
6865 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6866 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6867 cold      eij=facont_hb(jj,i)
6868 cold      ekl=facont_hb(kk,k)
6869 cold      ekont=eij*ekl
6870       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6871       if (calc_grad) then
6872 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6873       gcorr_loc(k-1)=gcorr_loc(k-1)
6874      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6875       if (l.eq.j+1) then
6876         gcorr_loc(l-1)=gcorr_loc(l-1)
6877      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6878       else
6879         gcorr_loc(j-1)=gcorr_loc(j-1)
6880      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6881       endif
6882       do iii=1,2
6883         do kkk=1,5
6884           do lll=1,3
6885             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6886      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6887 cd            derx(lll,kkk,iii)=0.0d0
6888           enddo
6889         enddo
6890       enddo
6891 cd      gcorr_loc(l-1)=0.0d0
6892 cd      gcorr_loc(j-1)=0.0d0
6893 cd      gcorr_loc(k-1)=0.0d0
6894 cd      eel4=1.0d0
6895 cd      write (iout,*)'Contacts have occurred for peptide groups',
6896 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6897 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6898       if (j.lt.nres-1) then
6899         j1=j+1
6900         j2=j-1
6901       else
6902         j1=j-1
6903         j2=j-2
6904       endif
6905       if (l.lt.nres-1) then
6906         l1=l+1
6907         l2=l-1
6908       else
6909         l1=l-1
6910         l2=l-2
6911       endif
6912       do ll=1,3
6913 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6914         ggg1(ll)=eel4*g_contij(ll,1)
6915         ggg2(ll)=eel4*g_contij(ll,2)
6916         ghalf=0.5d0*ggg1(ll)
6917 cd        ghalf=0.0d0
6918         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6919         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6920         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6921         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6922 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6923         ghalf=0.5d0*ggg2(ll)
6924 cd        ghalf=0.0d0
6925         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6926         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6927         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6928         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6929       enddo
6930 cd      goto 1112
6931       do m=i+1,j-1
6932         do ll=1,3
6933 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6934           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6935         enddo
6936       enddo
6937       do m=k+1,l-1
6938         do ll=1,3
6939 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6940           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6941         enddo
6942       enddo
6943 1112  continue
6944       do m=i+2,j2
6945         do ll=1,3
6946           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6947         enddo
6948       enddo
6949       do m=k+2,l2
6950         do ll=1,3
6951           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6952         enddo
6953       enddo
6954 cd      do iii=1,nres-3
6955 cd        write (2,*) iii,gcorr_loc(iii)
6956 cd      enddo
6957       endif
6958       eello4=ekont*eel4
6959 cd      write (2,*) 'ekont',ekont
6960 cd      write (iout,*) 'eello4',ekont*eel4
6961       return
6962       end
6963 C---------------------------------------------------------------------------
6964       double precision function eello5(i,j,k,l,jj,kk)
6965       implicit real*8 (a-h,o-z)
6966       include 'DIMENSIONS'
6967       include 'DIMENSIONS.ZSCOPT'
6968       include 'COMMON.IOUNITS'
6969       include 'COMMON.CHAIN'
6970       include 'COMMON.DERIV'
6971       include 'COMMON.INTERACT'
6972       include 'COMMON.CONTACTS'
6973       include 'COMMON.TORSION'
6974       include 'COMMON.VAR'
6975       include 'COMMON.GEO'
6976       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6977       double precision ggg1(3),ggg2(3)
6978 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6979 C                                                                              C
6980 C                            Parallel chains                                   C
6981 C                                                                              C
6982 C          o             o                   o             o                   C
6983 C         /l\           / \             \   / \           / \   /              C
6984 C        /   \         /   \             \ /   \         /   \ /               C
6985 C       j| o |l1       | o |              o| o |         | o |o                C
6986 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6987 C      \i/   \         /   \ /             /   \         /   \                 C
6988 C       o    k1             o                                                  C
6989 C         (I)          (II)                (III)          (IV)                 C
6990 C                                                                              C
6991 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6992 C                                                                              C
6993 C                            Antiparallel chains                               C
6994 C                                                                              C
6995 C          o             o                   o             o                   C
6996 C         /j\           / \             \   / \           / \   /              C
6997 C        /   \         /   \             \ /   \         /   \ /               C
6998 C      j1| o |l        | o |              o| o |         | o |o                C
6999 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7000 C      \i/   \         /   \ /             /   \         /   \                 C
7001 C       o     k1            o                                                  C
7002 C         (I)          (II)                (III)          (IV)                 C
7003 C                                                                              C
7004 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7005 C                                                                              C
7006 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7007 C                                                                              C
7008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7009 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7010 cd        eello5=0.0d0
7011 cd        return
7012 cd      endif
7013 cd      write (iout,*)
7014 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7015 cd     &   ' and',k,l
7016       itk=itortyp(itype(k))
7017       itl=itortyp(itype(l))
7018       itj=itortyp(itype(j))
7019       eello5_1=0.0d0
7020       eello5_2=0.0d0
7021       eello5_3=0.0d0
7022       eello5_4=0.0d0
7023 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7024 cd     &   eel5_3_num,eel5_4_num)
7025       do iii=1,2
7026         do kkk=1,5
7027           do lll=1,3
7028             derx(lll,kkk,iii)=0.0d0
7029           enddo
7030         enddo
7031       enddo
7032 cd      eij=facont_hb(jj,i)
7033 cd      ekl=facont_hb(kk,k)
7034 cd      ekont=eij*ekl
7035 cd      write (iout,*)'Contacts have occurred for peptide groups',
7036 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7037 cd      goto 1111
7038 C Contribution from the graph I.
7039 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7040 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7041       call transpose2(EUg(1,1,k),auxmat(1,1))
7042       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7043       vv(1)=pizda(1,1)-pizda(2,2)
7044       vv(2)=pizda(1,2)+pizda(2,1)
7045       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7046      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7047       if (calc_grad) then
7048 C Explicit gradient in virtual-dihedral angles.
7049       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7050      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7051      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7052       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7053       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7054       vv(1)=pizda(1,1)-pizda(2,2)
7055       vv(2)=pizda(1,2)+pizda(2,1)
7056       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7057      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7058      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7059       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7060       vv(1)=pizda(1,1)-pizda(2,2)
7061       vv(2)=pizda(1,2)+pizda(2,1)
7062       if (l.eq.j+1) then
7063         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7064      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7065      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7066       else
7067         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7068      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7069      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7070       endif
7071 C Cartesian gradient
7072       do iii=1,2
7073         do kkk=1,5
7074           do lll=1,3
7075             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7076      &        pizda(1,1))
7077             vv(1)=pizda(1,1)-pizda(2,2)
7078             vv(2)=pizda(1,2)+pizda(2,1)
7079             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7080      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7081      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7082           enddo
7083         enddo
7084       enddo
7085 c      goto 1112
7086       endif
7087 c1111  continue
7088 C Contribution from graph II
7089       call transpose2(EE(1,1,itk),auxmat(1,1))
7090       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7091       vv(1)=pizda(1,1)+pizda(2,2)
7092       vv(2)=pizda(2,1)-pizda(1,2)
7093       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7094      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7095       if (calc_grad) then
7096 C Explicit gradient in virtual-dihedral angles.
7097       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7098      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7099       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7100       vv(1)=pizda(1,1)+pizda(2,2)
7101       vv(2)=pizda(2,1)-pizda(1,2)
7102       if (l.eq.j+1) then
7103         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7104      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7105      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7106       else
7107         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7108      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7109      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7110       endif
7111 C Cartesian gradient
7112       do iii=1,2
7113         do kkk=1,5
7114           do lll=1,3
7115             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7116      &        pizda(1,1))
7117             vv(1)=pizda(1,1)+pizda(2,2)
7118             vv(2)=pizda(2,1)-pizda(1,2)
7119             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7120      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7121      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7122           enddo
7123         enddo
7124       enddo
7125 cd      goto 1112
7126       endif
7127 cd1111  continue
7128       if (l.eq.j+1) then
7129 cd        goto 1110
7130 C Parallel orientation
7131 C Contribution from graph III
7132         call transpose2(EUg(1,1,l),auxmat(1,1))
7133         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7134         vv(1)=pizda(1,1)-pizda(2,2)
7135         vv(2)=pizda(1,2)+pizda(2,1)
7136         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7137      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7138         if (calc_grad) then
7139 C Explicit gradient in virtual-dihedral angles.
7140         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7141      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7142      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7143         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7144         vv(1)=pizda(1,1)-pizda(2,2)
7145         vv(2)=pizda(1,2)+pizda(2,1)
7146         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7147      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7148      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7149         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7150         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7151         vv(1)=pizda(1,1)-pizda(2,2)
7152         vv(2)=pizda(1,2)+pizda(2,1)
7153         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7154      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7155      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7156 C Cartesian gradient
7157         do iii=1,2
7158           do kkk=1,5
7159             do lll=1,3
7160               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7161      &          pizda(1,1))
7162               vv(1)=pizda(1,1)-pizda(2,2)
7163               vv(2)=pizda(1,2)+pizda(2,1)
7164               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7165      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7166      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7167             enddo
7168           enddo
7169         enddo
7170 cd        goto 1112
7171         endif
7172 C Contribution from graph IV
7173 cd1110    continue
7174         call transpose2(EE(1,1,itl),auxmat(1,1))
7175         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7176         vv(1)=pizda(1,1)+pizda(2,2)
7177         vv(2)=pizda(2,1)-pizda(1,2)
7178         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7179      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7180         if (calc_grad) then
7181 C Explicit gradient in virtual-dihedral angles.
7182         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7183      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7184         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7185         vv(1)=pizda(1,1)+pizda(2,2)
7186         vv(2)=pizda(2,1)-pizda(1,2)
7187         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7188      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7189      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7190 C Cartesian gradient
7191         do iii=1,2
7192           do kkk=1,5
7193             do lll=1,3
7194               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7195      &          pizda(1,1))
7196               vv(1)=pizda(1,1)+pizda(2,2)
7197               vv(2)=pizda(2,1)-pizda(1,2)
7198               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7199      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7200      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7201             enddo
7202           enddo
7203         enddo
7204         endif
7205       else
7206 C Antiparallel orientation
7207 C Contribution from graph III
7208 c        goto 1110
7209         call transpose2(EUg(1,1,j),auxmat(1,1))
7210         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7211         vv(1)=pizda(1,1)-pizda(2,2)
7212         vv(2)=pizda(1,2)+pizda(2,1)
7213         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7214      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7215         if (calc_grad) then
7216 C Explicit gradient in virtual-dihedral angles.
7217         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7218      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7219      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7220         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7221         vv(1)=pizda(1,1)-pizda(2,2)
7222         vv(2)=pizda(1,2)+pizda(2,1)
7223         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7224      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7225      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7226         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7227         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7228         vv(1)=pizda(1,1)-pizda(2,2)
7229         vv(2)=pizda(1,2)+pizda(2,1)
7230         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7231      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7232      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7233 C Cartesian gradient
7234         do iii=1,2
7235           do kkk=1,5
7236             do lll=1,3
7237               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7238      &          pizda(1,1))
7239               vv(1)=pizda(1,1)-pizda(2,2)
7240               vv(2)=pizda(1,2)+pizda(2,1)
7241               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7242      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7243      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7244             enddo
7245           enddo
7246         enddo
7247 cd        goto 1112
7248         endif
7249 C Contribution from graph IV
7250 1110    continue
7251         call transpose2(EE(1,1,itj),auxmat(1,1))
7252         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7253         vv(1)=pizda(1,1)+pizda(2,2)
7254         vv(2)=pizda(2,1)-pizda(1,2)
7255         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7256      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7257         if (calc_grad) then
7258 C Explicit gradient in virtual-dihedral angles.
7259         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7260      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7261         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7262         vv(1)=pizda(1,1)+pizda(2,2)
7263         vv(2)=pizda(2,1)-pizda(1,2)
7264         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7265      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7266      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7267 C Cartesian gradient
7268         do iii=1,2
7269           do kkk=1,5
7270             do lll=1,3
7271               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7272      &          pizda(1,1))
7273               vv(1)=pizda(1,1)+pizda(2,2)
7274               vv(2)=pizda(2,1)-pizda(1,2)
7275               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7276      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7277      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7278             enddo
7279           enddo
7280         enddo
7281       endif
7282       endif
7283 1112  continue
7284       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7285 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7286 cd        write (2,*) 'ijkl',i,j,k,l
7287 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7288 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7289 cd      endif
7290 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7291 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7292 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7293 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7294       if (calc_grad) then
7295       if (j.lt.nres-1) then
7296         j1=j+1
7297         j2=j-1
7298       else
7299         j1=j-1
7300         j2=j-2
7301       endif
7302       if (l.lt.nres-1) then
7303         l1=l+1
7304         l2=l-1
7305       else
7306         l1=l-1
7307         l2=l-2
7308       endif
7309 cd      eij=1.0d0
7310 cd      ekl=1.0d0
7311 cd      ekont=1.0d0
7312 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7313       do ll=1,3
7314         ggg1(ll)=eel5*g_contij(ll,1)
7315         ggg2(ll)=eel5*g_contij(ll,2)
7316 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7317         ghalf=0.5d0*ggg1(ll)
7318 cd        ghalf=0.0d0
7319         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7320         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7321         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7322         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7323 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7324         ghalf=0.5d0*ggg2(ll)
7325 cd        ghalf=0.0d0
7326         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7327         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7328         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7329         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7330       enddo
7331 cd      goto 1112
7332       do m=i+1,j-1
7333         do ll=1,3
7334 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7335           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7336         enddo
7337       enddo
7338       do m=k+1,l-1
7339         do ll=1,3
7340 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7341           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7342         enddo
7343       enddo
7344 c1112  continue
7345       do m=i+2,j2
7346         do ll=1,3
7347           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7348         enddo
7349       enddo
7350       do m=k+2,l2
7351         do ll=1,3
7352           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7353         enddo
7354       enddo
7355 cd      do iii=1,nres-3
7356 cd        write (2,*) iii,g_corr5_loc(iii)
7357 cd      enddo
7358       endif
7359       eello5=ekont*eel5
7360 cd      write (2,*) 'ekont',ekont
7361 cd      write (iout,*) 'eello5',ekont*eel5
7362       return
7363       end
7364 c--------------------------------------------------------------------------
7365       double precision function eello6(i,j,k,l,jj,kk)
7366       implicit real*8 (a-h,o-z)
7367       include 'DIMENSIONS'
7368       include 'DIMENSIONS.ZSCOPT'
7369       include 'COMMON.IOUNITS'
7370       include 'COMMON.CHAIN'
7371       include 'COMMON.DERIV'
7372       include 'COMMON.INTERACT'
7373       include 'COMMON.CONTACTS'
7374       include 'COMMON.TORSION'
7375       include 'COMMON.VAR'
7376       include 'COMMON.GEO'
7377       include 'COMMON.FFIELD'
7378       double precision ggg1(3),ggg2(3)
7379 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7380 cd        eello6=0.0d0
7381 cd        return
7382 cd      endif
7383 cd      write (iout,*)
7384 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7385 cd     &   ' and',k,l
7386       eello6_1=0.0d0
7387       eello6_2=0.0d0
7388       eello6_3=0.0d0
7389       eello6_4=0.0d0
7390       eello6_5=0.0d0
7391       eello6_6=0.0d0
7392 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7393 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7394       do iii=1,2
7395         do kkk=1,5
7396           do lll=1,3
7397             derx(lll,kkk,iii)=0.0d0
7398           enddo
7399         enddo
7400       enddo
7401 cd      eij=facont_hb(jj,i)
7402 cd      ekl=facont_hb(kk,k)
7403 cd      ekont=eij*ekl
7404 cd      eij=1.0d0
7405 cd      ekl=1.0d0
7406 cd      ekont=1.0d0
7407       if (l.eq.j+1) then
7408         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7409         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7410         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7411         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7412         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7413         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7414       else
7415         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7416         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7417         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7418         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7419         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7420           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7421         else
7422           eello6_5=0.0d0
7423         endif
7424         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7425       endif
7426 C If turn contributions are considered, they will be handled separately.
7427       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7428 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7429 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7430 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7431 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7432 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7433 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7434 cd      goto 1112
7435       if (calc_grad) then
7436       if (j.lt.nres-1) then
7437         j1=j+1
7438         j2=j-1
7439       else
7440         j1=j-1
7441         j2=j-2
7442       endif
7443       if (l.lt.nres-1) then
7444         l1=l+1
7445         l2=l-1
7446       else
7447         l1=l-1
7448         l2=l-2
7449       endif
7450       do ll=1,3
7451         ggg1(ll)=eel6*g_contij(ll,1)
7452         ggg2(ll)=eel6*g_contij(ll,2)
7453 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7454         ghalf=0.5d0*ggg1(ll)
7455 cd        ghalf=0.0d0
7456         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7457         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7458         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7459         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7460         ghalf=0.5d0*ggg2(ll)
7461 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7462 cd        ghalf=0.0d0
7463         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7464         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7465         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7466         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7467       enddo
7468 cd      goto 1112
7469       do m=i+1,j-1
7470         do ll=1,3
7471 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7472           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7473         enddo
7474       enddo
7475       do m=k+1,l-1
7476         do ll=1,3
7477 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7478           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7479         enddo
7480       enddo
7481 1112  continue
7482       do m=i+2,j2
7483         do ll=1,3
7484           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7485         enddo
7486       enddo
7487       do m=k+2,l2
7488         do ll=1,3
7489           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7490         enddo
7491       enddo
7492 cd      do iii=1,nres-3
7493 cd        write (2,*) iii,g_corr6_loc(iii)
7494 cd      enddo
7495       endif
7496       eello6=ekont*eel6
7497 cd      write (2,*) 'ekont',ekont
7498 cd      write (iout,*) 'eello6',ekont*eel6
7499       return
7500       end
7501 c--------------------------------------------------------------------------
7502       double precision function eello6_graph1(i,j,k,l,imat,swap)
7503       implicit real*8 (a-h,o-z)
7504       include 'DIMENSIONS'
7505       include 'DIMENSIONS.ZSCOPT'
7506       include 'COMMON.IOUNITS'
7507       include 'COMMON.CHAIN'
7508       include 'COMMON.DERIV'
7509       include 'COMMON.INTERACT'
7510       include 'COMMON.CONTACTS'
7511       include 'COMMON.TORSION'
7512       include 'COMMON.VAR'
7513       include 'COMMON.GEO'
7514       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7515       logical swap
7516       logical lprn
7517       common /kutas/ lprn
7518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7519 C                                                                              C
7520 C      Parallel       Antiparallel                                             C
7521 C                                                                              C
7522 C          o             o                                                     C
7523 C         /l\           /j\                                                    C
7524 C        /   \         /   \                                                   C
7525 C       /| o |         | o |\                                                  C
7526 C     \ j|/k\|  /   \  |/k\|l /                                                C
7527 C      \ /   \ /     \ /   \ /                                                 C
7528 C       o     o       o     o                                                  C
7529 C       i             i                                                        C
7530 C                                                                              C
7531 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7532       itk=itortyp(itype(k))
7533       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7534       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7535       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7536       call transpose2(EUgC(1,1,k),auxmat(1,1))
7537       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7538       vv1(1)=pizda1(1,1)-pizda1(2,2)
7539       vv1(2)=pizda1(1,2)+pizda1(2,1)
7540       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7541       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7542       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7543       s5=scalar2(vv(1),Dtobr2(1,i))
7544 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7545       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7546       if (.not. calc_grad) return
7547       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7548      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7549      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7550      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7551      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7552      & +scalar2(vv(1),Dtobr2der(1,i)))
7553       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7554       vv1(1)=pizda1(1,1)-pizda1(2,2)
7555       vv1(2)=pizda1(1,2)+pizda1(2,1)
7556       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7557       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7558       if (l.eq.j+1) then
7559         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7560      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7561      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7562      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7563      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7564       else
7565         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7566      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7567      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7568      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7569      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7570       endif
7571       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7572       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7573       vv1(1)=pizda1(1,1)-pizda1(2,2)
7574       vv1(2)=pizda1(1,2)+pizda1(2,1)
7575       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7576      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7577      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7578      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7579       do iii=1,2
7580         if (swap) then
7581           ind=3-iii
7582         else
7583           ind=iii
7584         endif
7585         do kkk=1,5
7586           do lll=1,3
7587             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7588             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7589             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7590             call transpose2(EUgC(1,1,k),auxmat(1,1))
7591             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7592      &        pizda1(1,1))
7593             vv1(1)=pizda1(1,1)-pizda1(2,2)
7594             vv1(2)=pizda1(1,2)+pizda1(2,1)
7595             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7596             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7597      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7598             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7599      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7600             s5=scalar2(vv(1),Dtobr2(1,i))
7601             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7602           enddo
7603         enddo
7604       enddo
7605       return
7606       end
7607 c----------------------------------------------------------------------------
7608       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7609       implicit real*8 (a-h,o-z)
7610       include 'DIMENSIONS'
7611       include 'DIMENSIONS.ZSCOPT'
7612       include 'COMMON.IOUNITS'
7613       include 'COMMON.CHAIN'
7614       include 'COMMON.DERIV'
7615       include 'COMMON.INTERACT'
7616       include 'COMMON.CONTACTS'
7617       include 'COMMON.TORSION'
7618       include 'COMMON.VAR'
7619       include 'COMMON.GEO'
7620       logical swap
7621       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7622      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7623       logical lprn
7624       common /kutas/ lprn
7625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7626 C                                                                              C
7627 C      Parallel       Antiparallel                                             C
7628 C                                                                              C
7629 C          o             o                                                     C
7630 C     \   /l\           /j\   /                                                C
7631 C      \ /   \         /   \ /                                                 C
7632 C       o| o |         | o |o                                                  C
7633 C     \ j|/k\|      \  |/k\|l                                                  C
7634 C      \ /   \       \ /   \                                                   C
7635 C       o             o                                                        C
7636 C       i             i                                                        C
7637 C                                                                              C
7638 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7639 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7640 C AL 7/4/01 s1 would occur in the sixth-order moment,
7641 C           but not in a cluster cumulant
7642 #ifdef MOMENT
7643       s1=dip(1,jj,i)*dip(1,kk,k)
7644 #endif
7645       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7646       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7647       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7648       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7649       call transpose2(EUg(1,1,k),auxmat(1,1))
7650       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7651       vv(1)=pizda(1,1)-pizda(2,2)
7652       vv(2)=pizda(1,2)+pizda(2,1)
7653       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7654 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7655 #ifdef MOMENT
7656       eello6_graph2=-(s1+s2+s3+s4)
7657 #else
7658       eello6_graph2=-(s2+s3+s4)
7659 #endif
7660 c      eello6_graph2=-s3
7661       if (.not. calc_grad) return
7662 C Derivatives in gamma(i-1)
7663       if (i.gt.1) then
7664 #ifdef MOMENT
7665         s1=dipderg(1,jj,i)*dip(1,kk,k)
7666 #endif
7667         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7668         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7669         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7670         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7671 #ifdef MOMENT
7672         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7673 #else
7674         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7675 #endif
7676 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7677       endif
7678 C Derivatives in gamma(k-1)
7679 #ifdef MOMENT
7680       s1=dip(1,jj,i)*dipderg(1,kk,k)
7681 #endif
7682       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7683       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7684       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7685       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7686       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7687       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7688       vv(1)=pizda(1,1)-pizda(2,2)
7689       vv(2)=pizda(1,2)+pizda(2,1)
7690       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7691 #ifdef MOMENT
7692       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7693 #else
7694       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7695 #endif
7696 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7697 C Derivatives in gamma(j-1) or gamma(l-1)
7698       if (j.gt.1) then
7699 #ifdef MOMENT
7700         s1=dipderg(3,jj,i)*dip(1,kk,k)
7701 #endif
7702         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7703         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7704         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7705         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7706         vv(1)=pizda(1,1)-pizda(2,2)
7707         vv(2)=pizda(1,2)+pizda(2,1)
7708         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7709 #ifdef MOMENT
7710         if (swap) then
7711           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7712         else
7713           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7714         endif
7715 #endif
7716         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7717 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7718       endif
7719 C Derivatives in gamma(l-1) or gamma(j-1)
7720       if (l.gt.1) then
7721 #ifdef MOMENT
7722         s1=dip(1,jj,i)*dipderg(3,kk,k)
7723 #endif
7724         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7725         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7726         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7727         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7728         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7729         vv(1)=pizda(1,1)-pizda(2,2)
7730         vv(2)=pizda(1,2)+pizda(2,1)
7731         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7732 #ifdef MOMENT
7733         if (swap) then
7734           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7735         else
7736           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7737         endif
7738 #endif
7739         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7740 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7741       endif
7742 C Cartesian derivatives.
7743       if (lprn) then
7744         write (2,*) 'In eello6_graph2'
7745         do iii=1,2
7746           write (2,*) 'iii=',iii
7747           do kkk=1,5
7748             write (2,*) 'kkk=',kkk
7749             do jjj=1,2
7750               write (2,'(3(2f10.5),5x)')
7751      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7752             enddo
7753           enddo
7754         enddo
7755       endif
7756       do iii=1,2
7757         do kkk=1,5
7758           do lll=1,3
7759 #ifdef MOMENT
7760             if (iii.eq.1) then
7761               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7762             else
7763               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7764             endif
7765 #endif
7766             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7767      &        auxvec(1))
7768             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7769             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7770      &        auxvec(1))
7771             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7772             call transpose2(EUg(1,1,k),auxmat(1,1))
7773             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7774      &        pizda(1,1))
7775             vv(1)=pizda(1,1)-pizda(2,2)
7776             vv(2)=pizda(1,2)+pizda(2,1)
7777             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7778 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7779 #ifdef MOMENT
7780             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7781 #else
7782             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7783 #endif
7784             if (swap) then
7785               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7786             else
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7788             endif
7789           enddo
7790         enddo
7791       enddo
7792       return
7793       end
7794 c----------------------------------------------------------------------------
7795       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7796       implicit real*8 (a-h,o-z)
7797       include 'DIMENSIONS'
7798       include 'DIMENSIONS.ZSCOPT'
7799       include 'COMMON.IOUNITS'
7800       include 'COMMON.CHAIN'
7801       include 'COMMON.DERIV'
7802       include 'COMMON.INTERACT'
7803       include 'COMMON.CONTACTS'
7804       include 'COMMON.TORSION'
7805       include 'COMMON.VAR'
7806       include 'COMMON.GEO'
7807       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7808       logical swap
7809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7810 C                                                                              C
7811 C      Parallel       Antiparallel                                             C
7812 C                                                                              C
7813 C          o             o                                                     C
7814 C         /l\   /   \   /j\                                                    C
7815 C        /   \ /     \ /   \                                                   C
7816 C       /| o |o       o| o |\                                                  C
7817 C       j|/k\|  /      |/k\|l /                                                C
7818 C        /   \ /       /   \ /                                                 C
7819 C       /     o       /     o                                                  C
7820 C       i             i                                                        C
7821 C                                                                              C
7822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7823 C
7824 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7825 C           energy moment and not to the cluster cumulant.
7826       iti=itortyp(itype(i))
7827       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7828         itj1=itortyp(itype(j+1))
7829       else
7830         itj1=ntortyp+1
7831       endif
7832       itk=itortyp(itype(k))
7833       itk1=itortyp(itype(k+1))
7834       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7835         itl1=itortyp(itype(l+1))
7836       else
7837         itl1=ntortyp+1
7838       endif
7839 #ifdef MOMENT
7840       s1=dip(4,jj,i)*dip(4,kk,k)
7841 #endif
7842       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7843       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7844       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7845       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7846       call transpose2(EE(1,1,itk),auxmat(1,1))
7847       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7848       vv(1)=pizda(1,1)+pizda(2,2)
7849       vv(2)=pizda(2,1)-pizda(1,2)
7850       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7851 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7852 #ifdef MOMENT
7853       eello6_graph3=-(s1+s2+s3+s4)
7854 #else
7855       eello6_graph3=-(s2+s3+s4)
7856 #endif
7857 c      eello6_graph3=-s4
7858       if (.not. calc_grad) return
7859 C Derivatives in gamma(k-1)
7860       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7861       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7862       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7863       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7864 C Derivatives in gamma(l-1)
7865       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7866       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7867       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7868       vv(1)=pizda(1,1)+pizda(2,2)
7869       vv(2)=pizda(2,1)-pizda(1,2)
7870       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7871       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7872 C Cartesian derivatives.
7873       do iii=1,2
7874         do kkk=1,5
7875           do lll=1,3
7876 #ifdef MOMENT
7877             if (iii.eq.1) then
7878               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7879             else
7880               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7881             endif
7882 #endif
7883             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7884      &        auxvec(1))
7885             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7886             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7887      &        auxvec(1))
7888             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7889             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7890      &        pizda(1,1))
7891             vv(1)=pizda(1,1)+pizda(2,2)
7892             vv(2)=pizda(2,1)-pizda(1,2)
7893             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7894 #ifdef MOMENT
7895             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7896 #else
7897             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7898 #endif
7899             if (swap) then
7900               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7901             else
7902               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7903             endif
7904 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7905           enddo
7906         enddo
7907       enddo
7908       return
7909       end
7910 c----------------------------------------------------------------------------
7911       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7912       implicit real*8 (a-h,o-z)
7913       include 'DIMENSIONS'
7914       include 'DIMENSIONS.ZSCOPT'
7915       include 'COMMON.IOUNITS'
7916       include 'COMMON.CHAIN'
7917       include 'COMMON.DERIV'
7918       include 'COMMON.INTERACT'
7919       include 'COMMON.CONTACTS'
7920       include 'COMMON.TORSION'
7921       include 'COMMON.VAR'
7922       include 'COMMON.GEO'
7923       include 'COMMON.FFIELD'
7924       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7925      & auxvec1(2),auxmat1(2,2)
7926       logical swap
7927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7928 C                                                                              C
7929 C      Parallel       Antiparallel                                             C
7930 C                                                                              C
7931 C          o             o                                                     C
7932 C         /l\   /   \   /j\                                                    C
7933 C        /   \ /     \ /   \                                                   C
7934 C       /| o |o       o| o |\                                                  C
7935 C     \ j|/k\|      \  |/k\|l                                                  C
7936 C      \ /   \       \ /   \                                                   C
7937 C       o     \       o     \                                                  C
7938 C       i             i                                                        C
7939 C                                                                              C
7940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7941 C
7942 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7943 C           energy moment and not to the cluster cumulant.
7944 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7945       iti=itortyp(itype(i))
7946       itj=itortyp(itype(j))
7947       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7948         itj1=itortyp(itype(j+1))
7949       else
7950         itj1=ntortyp+1
7951       endif
7952       itk=itortyp(itype(k))
7953       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7954         itk1=itortyp(itype(k+1))
7955       else
7956         itk1=ntortyp+1
7957       endif
7958       itl=itortyp(itype(l))
7959       if (l.lt.nres-1) then
7960         itl1=itortyp(itype(l+1))
7961       else
7962         itl1=ntortyp+1
7963       endif
7964 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7965 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7966 cd     & ' itl',itl,' itl1',itl1
7967 #ifdef MOMENT
7968       if (imat.eq.1) then
7969         s1=dip(3,jj,i)*dip(3,kk,k)
7970       else
7971         s1=dip(2,jj,j)*dip(2,kk,l)
7972       endif
7973 #endif
7974       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7975       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7976       if (j.eq.l+1) then
7977         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7978         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7979       else
7980         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7981         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7982       endif
7983       call transpose2(EUg(1,1,k),auxmat(1,1))
7984       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7985       vv(1)=pizda(1,1)-pizda(2,2)
7986       vv(2)=pizda(2,1)+pizda(1,2)
7987       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7988 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7989 #ifdef MOMENT
7990       eello6_graph4=-(s1+s2+s3+s4)
7991 #else
7992       eello6_graph4=-(s2+s3+s4)
7993 #endif
7994       if (.not. calc_grad) return
7995 C Derivatives in gamma(i-1)
7996       if (i.gt.1) then
7997 #ifdef MOMENT
7998         if (imat.eq.1) then
7999           s1=dipderg(2,jj,i)*dip(3,kk,k)
8000         else
8001           s1=dipderg(4,jj,j)*dip(2,kk,l)
8002         endif
8003 #endif
8004         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8005         if (j.eq.l+1) then
8006           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8007           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8008         else
8009           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8010           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8011         endif
8012         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8013         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8014 cd          write (2,*) 'turn6 derivatives'
8015 #ifdef MOMENT
8016           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8017 #else
8018           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8019 #endif
8020         else
8021 #ifdef MOMENT
8022           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8023 #else
8024           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8025 #endif
8026         endif
8027       endif
8028 C Derivatives in gamma(k-1)
8029 #ifdef MOMENT
8030       if (imat.eq.1) then
8031         s1=dip(3,jj,i)*dipderg(2,kk,k)
8032       else
8033         s1=dip(2,jj,j)*dipderg(4,kk,l)
8034       endif
8035 #endif
8036       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8037       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8038       if (j.eq.l+1) then
8039         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8040         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8041       else
8042         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8043         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8044       endif
8045       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8046       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8047       vv(1)=pizda(1,1)-pizda(2,2)
8048       vv(2)=pizda(2,1)+pizda(1,2)
8049       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8050       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8051 #ifdef MOMENT
8052         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8053 #else
8054         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8055 #endif
8056       else
8057 #ifdef MOMENT
8058         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8059 #else
8060         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8061 #endif
8062       endif
8063 C Derivatives in gamma(j-1) or gamma(l-1)
8064       if (l.eq.j+1 .and. l.gt.1) then
8065         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8066         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8067         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8068         vv(1)=pizda(1,1)-pizda(2,2)
8069         vv(2)=pizda(2,1)+pizda(1,2)
8070         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8071         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8072       else if (j.gt.1) then
8073         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8074         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8075         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8076         vv(1)=pizda(1,1)-pizda(2,2)
8077         vv(2)=pizda(2,1)+pizda(1,2)
8078         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8079         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8080           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8081         else
8082           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8083         endif
8084       endif
8085 C Cartesian derivatives.
8086       do iii=1,2
8087         do kkk=1,5
8088           do lll=1,3
8089 #ifdef MOMENT
8090             if (iii.eq.1) then
8091               if (imat.eq.1) then
8092                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8093               else
8094                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8095               endif
8096             else
8097               if (imat.eq.1) then
8098                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8099               else
8100                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8101               endif
8102             endif
8103 #endif
8104             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8105      &        auxvec(1))
8106             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8107             if (j.eq.l+1) then
8108               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8109      &          b1(1,itj1),auxvec(1))
8110               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8111             else
8112               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8113      &          b1(1,itl1),auxvec(1))
8114               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8115             endif
8116             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8117      &        pizda(1,1))
8118             vv(1)=pizda(1,1)-pizda(2,2)
8119             vv(2)=pizda(2,1)+pizda(1,2)
8120             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8121             if (swap) then
8122               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8123 #ifdef MOMENT
8124                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8125      &             -(s1+s2+s4)
8126 #else
8127                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8128      &             -(s2+s4)
8129 #endif
8130                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8131               else
8132 #ifdef MOMENT
8133                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8134 #else
8135                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8136 #endif
8137                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8138               endif
8139             else
8140 #ifdef MOMENT
8141               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8142 #else
8143               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8144 #endif
8145               if (l.eq.j+1) then
8146                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8147               else
8148                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8149               endif
8150             endif
8151           enddo
8152         enddo
8153       enddo
8154       return
8155       end
8156 c----------------------------------------------------------------------------
8157       double precision function eello_turn6(i,jj,kk)
8158       implicit real*8 (a-h,o-z)
8159       include 'DIMENSIONS'
8160       include 'DIMENSIONS.ZSCOPT'
8161       include 'COMMON.IOUNITS'
8162       include 'COMMON.CHAIN'
8163       include 'COMMON.DERIV'
8164       include 'COMMON.INTERACT'
8165       include 'COMMON.CONTACTS'
8166       include 'COMMON.TORSION'
8167       include 'COMMON.VAR'
8168       include 'COMMON.GEO'
8169       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8170      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8171      &  ggg1(3),ggg2(3)
8172       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8173      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8174 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8175 C           the respective energy moment and not to the cluster cumulant.
8176       eello_turn6=0.0d0
8177       j=i+4
8178       k=i+1
8179       l=i+3
8180       iti=itortyp(itype(i))
8181       itk=itortyp(itype(k))
8182       itk1=itortyp(itype(k+1))
8183       itl=itortyp(itype(l))
8184       itj=itortyp(itype(j))
8185 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8186 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8187 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8188 cd        eello6=0.0d0
8189 cd        return
8190 cd      endif
8191 cd      write (iout,*)
8192 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8193 cd     &   ' and',k,l
8194 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8195       do iii=1,2
8196         do kkk=1,5
8197           do lll=1,3
8198             derx_turn(lll,kkk,iii)=0.0d0
8199           enddo
8200         enddo
8201       enddo
8202 cd      eij=1.0d0
8203 cd      ekl=1.0d0
8204 cd      ekont=1.0d0
8205       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8206 cd      eello6_5=0.0d0
8207 cd      write (2,*) 'eello6_5',eello6_5
8208 #ifdef MOMENT
8209       call transpose2(AEA(1,1,1),auxmat(1,1))
8210       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8211       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8212       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8213 #else
8214       s1 = 0.0d0
8215 #endif
8216       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8217       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8218       s2 = scalar2(b1(1,itk),vtemp1(1))
8219 #ifdef MOMENT
8220       call transpose2(AEA(1,1,2),atemp(1,1))
8221       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8222       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8223       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8224 #else
8225       s8=0.0d0
8226 #endif
8227       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8228       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8229       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8230 #ifdef MOMENT
8231       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8232       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8233       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8234       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8235       ss13 = scalar2(b1(1,itk),vtemp4(1))
8236       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8237 #else
8238       s13=0.0d0
8239 #endif
8240 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8241 c      s1=0.0d0
8242 c      s2=0.0d0
8243 c      s8=0.0d0
8244 c      s12=0.0d0
8245 c      s13=0.0d0
8246       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8247       if (calc_grad) then
8248 C Derivatives in gamma(i+2)
8249 #ifdef MOMENT
8250       call transpose2(AEA(1,1,1),auxmatd(1,1))
8251       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8252       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8253       call transpose2(AEAderg(1,1,2),atempd(1,1))
8254       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8255       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8256 #else
8257       s8d=0.0d0
8258 #endif
8259       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8260       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8261       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8262 c      s1d=0.0d0
8263 c      s2d=0.0d0
8264 c      s8d=0.0d0
8265 c      s12d=0.0d0
8266 c      s13d=0.0d0
8267       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8268 C Derivatives in gamma(i+3)
8269 #ifdef MOMENT
8270       call transpose2(AEA(1,1,1),auxmatd(1,1))
8271       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8272       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8273       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8274 #else
8275       s1d=0.0d0
8276 #endif
8277       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8278       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8279       s2d = scalar2(b1(1,itk),vtemp1d(1))
8280 #ifdef MOMENT
8281       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8282       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8283 #endif
8284       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8285 #ifdef MOMENT
8286       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8287       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8288       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8289 #else
8290       s13d=0.0d0
8291 #endif
8292 c      s1d=0.0d0
8293 c      s2d=0.0d0
8294 c      s8d=0.0d0
8295 c      s12d=0.0d0
8296 c      s13d=0.0d0
8297 #ifdef MOMENT
8298       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8299      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8300 #else
8301       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8302      &               -0.5d0*ekont*(s2d+s12d)
8303 #endif
8304 C Derivatives in gamma(i+4)
8305       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8306       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8307       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8308 #ifdef MOMENT
8309       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8310       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8311       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8312 #else
8313       s13d = 0.0d0
8314 #endif
8315 c      s1d=0.0d0
8316 c      s2d=0.0d0
8317 c      s8d=0.0d0
8318 C      s12d=0.0d0
8319 c      s13d=0.0d0
8320 #ifdef MOMENT
8321       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8322 #else
8323       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8324 #endif
8325 C Derivatives in gamma(i+5)
8326 #ifdef MOMENT
8327       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8328       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8329       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8330 #else
8331       s1d = 0.0d0
8332 #endif
8333       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8334       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8335       s2d = scalar2(b1(1,itk),vtemp1d(1))
8336 #ifdef MOMENT
8337       call transpose2(AEA(1,1,2),atempd(1,1))
8338       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8339       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8340 #else
8341       s8d = 0.0d0
8342 #endif
8343       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8344       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8345 #ifdef MOMENT
8346       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8347       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8348       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8349 #else
8350       s13d = 0.0d0
8351 #endif
8352 c      s1d=0.0d0
8353 c      s2d=0.0d0
8354 c      s8d=0.0d0
8355 c      s12d=0.0d0
8356 c      s13d=0.0d0
8357 #ifdef MOMENT
8358       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8359      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8360 #else
8361       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8362      &               -0.5d0*ekont*(s2d+s12d)
8363 #endif
8364 C Cartesian derivatives
8365       do iii=1,2
8366         do kkk=1,5
8367           do lll=1,3
8368 #ifdef MOMENT
8369             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8370             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8371             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8372 #else
8373             s1d = 0.0d0
8374 #endif
8375             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8376             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8377      &          vtemp1d(1))
8378             s2d = scalar2(b1(1,itk),vtemp1d(1))
8379 #ifdef MOMENT
8380             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8381             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8382             s8d = -(atempd(1,1)+atempd(2,2))*
8383      &           scalar2(cc(1,1,itl),vtemp2(1))
8384 #else
8385             s8d = 0.0d0
8386 #endif
8387             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8388      &           auxmatd(1,1))
8389             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8390             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8391 c      s1d=0.0d0
8392 c      s2d=0.0d0
8393 c      s8d=0.0d0
8394 c      s12d=0.0d0
8395 c      s13d=0.0d0
8396 #ifdef MOMENT
8397             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8398      &        - 0.5d0*(s1d+s2d)
8399 #else
8400             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8401      &        - 0.5d0*s2d
8402 #endif
8403 #ifdef MOMENT
8404             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8405      &        - 0.5d0*(s8d+s12d)
8406 #else
8407             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8408      &        - 0.5d0*s12d
8409 #endif
8410           enddo
8411         enddo
8412       enddo
8413 #ifdef MOMENT
8414       do kkk=1,5
8415         do lll=1,3
8416           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8417      &      achuj_tempd(1,1))
8418           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8419           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8420           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8421           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8422           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8423      &      vtemp4d(1))
8424           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8425           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8426           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8427         enddo
8428       enddo
8429 #endif
8430 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8431 cd     &  16*eel_turn6_num
8432 cd      goto 1112
8433       if (j.lt.nres-1) then
8434         j1=j+1
8435         j2=j-1
8436       else
8437         j1=j-1
8438         j2=j-2
8439       endif
8440       if (l.lt.nres-1) then
8441         l1=l+1
8442         l2=l-1
8443       else
8444         l1=l-1
8445         l2=l-2
8446       endif
8447       do ll=1,3
8448         ggg1(ll)=eel_turn6*g_contij(ll,1)
8449         ggg2(ll)=eel_turn6*g_contij(ll,2)
8450         ghalf=0.5d0*ggg1(ll)
8451 cd        ghalf=0.0d0
8452         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8453      &    +ekont*derx_turn(ll,2,1)
8454         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8455         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8456      &    +ekont*derx_turn(ll,4,1)
8457         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8458         ghalf=0.5d0*ggg2(ll)
8459 cd        ghalf=0.0d0
8460         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8461      &    +ekont*derx_turn(ll,2,2)
8462         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8463         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8464      &    +ekont*derx_turn(ll,4,2)
8465         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8466       enddo
8467 cd      goto 1112
8468       do m=i+1,j-1
8469         do ll=1,3
8470           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8471         enddo
8472       enddo
8473       do m=k+1,l-1
8474         do ll=1,3
8475           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8476         enddo
8477       enddo
8478 1112  continue
8479       do m=i+2,j2
8480         do ll=1,3
8481           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8482         enddo
8483       enddo
8484       do m=k+2,l2
8485         do ll=1,3
8486           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8487         enddo
8488       enddo
8489 cd      do iii=1,nres-3
8490 cd        write (2,*) iii,g_corr6_loc(iii)
8491 cd      enddo
8492       endif
8493       eello_turn6=ekont*eel_turn6
8494 cd      write (2,*) 'ekont',ekont
8495 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8496       return
8497       end
8498 crc-------------------------------------------------
8499       SUBROUTINE MATVEC2(A1,V1,V2)
8500       implicit real*8 (a-h,o-z)
8501       include 'DIMENSIONS'
8502       DIMENSION A1(2,2),V1(2),V2(2)
8503 c      DO 1 I=1,2
8504 c        VI=0.0
8505 c        DO 3 K=1,2
8506 c    3     VI=VI+A1(I,K)*V1(K)
8507 c        Vaux(I)=VI
8508 c    1 CONTINUE
8509
8510       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8511       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8512
8513       v2(1)=vaux1
8514       v2(2)=vaux2
8515       END
8516 C---------------------------------------
8517       SUBROUTINE MATMAT2(A1,A2,A3)
8518       implicit real*8 (a-h,o-z)
8519       include 'DIMENSIONS'
8520       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8521 c      DIMENSION AI3(2,2)
8522 c        DO  J=1,2
8523 c          A3IJ=0.0
8524 c          DO K=1,2
8525 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8526 c          enddo
8527 c          A3(I,J)=A3IJ
8528 c       enddo
8529 c      enddo
8530
8531       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8532       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8533       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8534       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8535
8536       A3(1,1)=AI3_11
8537       A3(2,1)=AI3_21
8538       A3(1,2)=AI3_12
8539       A3(2,2)=AI3_22
8540       END
8541
8542 c-------------------------------------------------------------------------
8543       double precision function scalar2(u,v)
8544       implicit none
8545       double precision u(2),v(2)
8546       double precision sc
8547       integer i
8548       scalar2=u(1)*v(1)+u(2)*v(2)
8549       return
8550       end
8551
8552 C-----------------------------------------------------------------------------
8553
8554       subroutine transpose2(a,at)
8555       implicit none
8556       double precision a(2,2),at(2,2)
8557       at(1,1)=a(1,1)
8558       at(1,2)=a(2,1)
8559       at(2,1)=a(1,2)
8560       at(2,2)=a(2,2)
8561       return
8562       end
8563 c--------------------------------------------------------------------------
8564       subroutine transpose(n,a,at)
8565       implicit none
8566       integer n,i,j
8567       double precision a(n,n),at(n,n)
8568       do i=1,n
8569         do j=1,n
8570           at(j,i)=a(i,j)
8571         enddo
8572       enddo
8573       return
8574       end
8575 C---------------------------------------------------------------------------
8576       subroutine prodmat3(a1,a2,kk,transp,prod)
8577       implicit none
8578       integer i,j
8579       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8580       logical transp
8581 crc      double precision auxmat(2,2),prod_(2,2)
8582
8583       if (transp) then
8584 crc        call transpose2(kk(1,1),auxmat(1,1))
8585 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8586 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8587
8588            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8589      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8590            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8591      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8592            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8593      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8594            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8595      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8596
8597       else
8598 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8599 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8600
8601            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8602      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8603            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8604      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8605            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8606      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8607            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8608      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8609
8610       endif
8611 c      call transpose2(a2(1,1),a2t(1,1))
8612
8613 crc      print *,transp
8614 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8615 crc      print *,((prod(i,j),i=1,2),j=1,2)
8616
8617       return
8618       end
8619 C-----------------------------------------------------------------------------
8620       double precision function scalar(u,v)
8621       implicit none
8622       double precision u(3),v(3)
8623       double precision sc
8624       integer i
8625       sc=0.0d0
8626       do i=1,3
8627         sc=sc+u(i)*v(i)
8628       enddo
8629       scalar=sc
8630       return
8631       end
8632 C-----------------------------------------------------------------------
8633       double precision function sscale(r)
8634       double precision r,gamm
8635       include "COMMON.SPLITELE"
8636       if(r.lt.r_cut-rlamb) then
8637         sscale=1.0d0
8638       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8639         gamm=(r-(r_cut-rlamb))/rlamb
8640         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8641       else
8642         sscale=0d0
8643       endif
8644       return
8645       end
8646 C-----------------------------------------------------------------------
8647 C-----------------------------------------------------------------------
8648       double precision function sscagrad(r)
8649       double precision r,gamm
8650       include "COMMON.SPLITELE"
8651       if(r.lt.r_cut-rlamb) then
8652         sscagrad=0.0d0
8653       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8654         gamm=(r-(r_cut-rlamb))/rlamb
8655         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8656       else
8657         sscagrad=0.0d0
8658       endif
8659       return
8660       end
8661 C-----------------------------------------------------------------------
8662 C-----------------------------------------------------------------------
8663       double precision function sscalelip(r)
8664       double precision r,gamm
8665       include "COMMON.SPLITELE"
8666 C      if(r.lt.r_cut-rlamb) then
8667 C        sscale=1.0d0
8668 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8669 C        gamm=(r-(r_cut-rlamb))/rlamb
8670         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8671 C      else
8672 C        sscale=0d0
8673 C      endif
8674       return
8675       end
8676 C-----------------------------------------------------------------------
8677       double precision function sscagradlip(r)
8678       double precision r,gamm
8679       include "COMMON.SPLITELE"
8680 C     if(r.lt.r_cut-rlamb) then
8681 C        sscagrad=0.0d0
8682 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8683 C        gamm=(r-(r_cut-rlamb))/rlamb
8684         sscagradlip=r*(6*r-6.0d0)
8685 C      else
8686 C        sscagrad=0.0d0
8687 C      endif
8688       return
8689       end
8690 c----------------------------------------------------------------------------
8691       double precision function sscale2(r,r_cut,r0,rlamb)
8692       implicit none
8693       double precision r,gamm,r_cut,r0,rlamb,rr
8694       rr = dabs(r-r0)
8695 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
8696 c      write (2,*) "rr",rr
8697       if(rr.lt.r_cut-rlamb) then
8698         sscale2=1.0d0
8699       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8700         gamm=(rr-(r_cut-rlamb))/rlamb
8701         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8702       else
8703         sscale2=0d0
8704       endif
8705       return
8706       end
8707 C-----------------------------------------------------------------------
8708       double precision function sscalgrad2(r,r_cut,r0,rlamb)
8709       implicit none
8710       double precision r,gamm,r_cut,r0,rlamb,rr
8711       rr = dabs(r-r0)
8712       if(rr.lt.r_cut-rlamb) then
8713         sscalgrad2=0.0d0
8714       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8715         gamm=(rr-(r_cut-rlamb))/rlamb
8716         if (r.ge.r0) then
8717           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
8718         else
8719           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
8720         endif
8721       else
8722         sscalgrad2=0.0d0
8723       endif
8724       return
8725       end
8726 c----------------------------------------------------------------------------
8727       subroutine e_saxs(Esaxs_constr)
8728       implicit none
8729       include 'DIMENSIONS'
8730       include 'DIMENSIONS.ZSCOPT'
8731       include 'DIMENSIONS.FREE'
8732 #ifdef MPI
8733       include "mpif.h"
8734       include "COMMON.SETUP"
8735       integer IERR
8736 #endif
8737       include 'COMMON.SBRIDGE'
8738       include 'COMMON.CHAIN'
8739       include 'COMMON.GEO'
8740       include 'COMMON.LOCAL'
8741       include 'COMMON.INTERACT'
8742       include 'COMMON.VAR'
8743       include 'COMMON.IOUNITS'
8744       include 'COMMON.DERIV'
8745       include 'COMMON.CONTROL'
8746       include 'COMMON.NAMES'
8747       include 'COMMON.FFIELD'
8748       include 'COMMON.LANGEVIN'
8749 c
8750       double precision Esaxs_constr
8751       integer i,iint,j,k,l
8752       double precision PgradC(maxSAXS,3,maxres),
8753      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
8754 #ifdef MPI
8755       double precision PgradC_(maxSAXS,3,maxres),
8756      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
8757 #endif
8758       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
8759      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
8760      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
8761      & auxX,auxX1,CACAgrad,Cnorm
8762       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
8763       double precision dist
8764       external dist
8765 c  SAXS restraint penalty function
8766 #ifdef DEBUG
8767       write(iout,*) "------- SAXS penalty function start -------"
8768       write (iout,*) "nsaxs",nsaxs
8769       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
8770       write (iout,*) "Psaxs"
8771       do i=1,nsaxs
8772         write (iout,'(i5,e15.5)') i, Psaxs(i)
8773       enddo
8774 #endif
8775       Esaxs_constr = 0.0d0
8776       do k=1,nsaxs
8777         Pcalc(k)=0.0d0
8778         do j=1,nres
8779           do l=1,3
8780             PgradC(k,l,j)=0.0d0
8781             PgradX(k,l,j)=0.0d0
8782           enddo
8783         enddo
8784       enddo
8785       do i=iatsc_s,iatsc_e
8786        if (itype(i).eq.ntyp1) cycle
8787        do iint=1,nint_gr(i)
8788          do j=istart(i,iint),iend(i,iint)
8789            if (itype(j).eq.ntyp1) cycle
8790 #ifdef ALLSAXS
8791            dijCACA=dist(i,j)
8792            dijCASC=dist(i,j+nres)
8793            dijSCCA=dist(i+nres,j)
8794            dijSCSC=dist(i+nres,j+nres)
8795            sigma2CACA=2.0d0/(pstok**2)
8796            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
8797            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
8798            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
8799            do k=1,nsaxs
8800              dk = distsaxs(k)
8801              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8802              if (itype(j).ne.10) then
8803              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
8804              else
8805              endif
8806              expCASC = 0.0d0
8807              if (itype(i).ne.10) then
8808              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
8809              else
8810              expSCCA = 0.0d0
8811              endif
8812              if (itype(i).ne.10 .and. itype(j).ne.10) then
8813              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
8814              else
8815              expSCSC = 0.0d0
8816              endif
8817              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
8818 #ifdef DEBUG
8819              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8820 #endif
8821              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8822              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
8823              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
8824              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
8825              do l=1,3
8826 c CA CA
8827                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8828                PgradC(k,l,i) = PgradC(k,l,i)-aux
8829                PgradC(k,l,j) = PgradC(k,l,j)+aux
8830 c CA SC
8831                if (itype(j).ne.10) then
8832                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
8833                PgradC(k,l,i) = PgradC(k,l,i)-aux
8834                PgradC(k,l,j) = PgradC(k,l,j)+aux
8835                PgradX(k,l,j) = PgradX(k,l,j)+aux
8836                endif
8837 c SC CA
8838                if (itype(i).ne.10) then
8839                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
8840                PgradX(k,l,i) = PgradX(k,l,i)-aux
8841                PgradC(k,l,i) = PgradC(k,l,i)-aux
8842                PgradC(k,l,j) = PgradC(k,l,j)+aux
8843                endif
8844 c SC SC
8845                if (itype(i).ne.10 .and. itype(j).ne.10) then
8846                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
8847                PgradC(k,l,i) = PgradC(k,l,i)-aux
8848                PgradC(k,l,j) = PgradC(k,l,j)+aux
8849                PgradX(k,l,i) = PgradX(k,l,i)-aux
8850                PgradX(k,l,j) = PgradX(k,l,j)+aux
8851                endif
8852              enddo ! l
8853            enddo ! k
8854 #else
8855            dijCACA=dist(i,j)
8856            sigma2CACA=scal_rad**2*0.25d0/
8857      &        (restok(itype(j))**2+restok(itype(i))**2)
8858
8859            IF (saxs_cutoff.eq.0) THEN
8860            do k=1,nsaxs
8861              dk = distsaxs(k)
8862              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8863              Pcalc(k) = Pcalc(k)+expCACA
8864              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8865              do l=1,3
8866                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8867                PgradC(k,l,i) = PgradC(k,l,i)-aux
8868                PgradC(k,l,j) = PgradC(k,l,j)+aux
8869              enddo ! l
8870            enddo ! k
8871            ELSE
8872            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
8873            do k=1,nsaxs
8874              dk = distsaxs(k)
8875 c             write (2,*) "ijk",i,j,k
8876              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
8877              if (sss2.eq.0.0d0) cycle
8878              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
8879              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
8880              Pcalc(k) = Pcalc(k)+expCACA
8881 #ifdef DEBUG
8882              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8883 #endif
8884              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
8885      &             ssgrad2*expCACA/sss2
8886              do l=1,3
8887 c CA CA
8888                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8889                PgradC(k,l,i) = PgradC(k,l,i)+aux
8890                PgradC(k,l,j) = PgradC(k,l,j)-aux
8891              enddo ! l
8892            enddo ! k
8893            ENDIF
8894 #endif
8895          enddo ! j
8896        enddo ! iint
8897       enddo ! i
8898 #ifdef MPI
8899       if (nfgtasks.gt.1) then
8900         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
8901      &    MPI_SUM,king,FG_COMM,IERR)
8902         if (fg_rank.eq.king) then
8903           do k=1,nsaxs
8904             Pcalc(k) = Pcalc_(k)
8905           enddo
8906         endif
8907         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
8908      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8909         if (fg_rank.eq.king) then
8910           do i=1,nres
8911             do l=1,3
8912               do k=1,nsaxs
8913                 PgradC(k,l,i) = PgradC_(k,l,i)
8914               enddo
8915             enddo
8916           enddo
8917         endif
8918 #ifdef ALLSAXS
8919         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
8920      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8921         if (fg_rank.eq.king) then
8922           do i=1,nres
8923             do l=1,3
8924               do k=1,nsaxs
8925                 PgradX(k,l,i) = PgradX_(k,l,i)
8926               enddo
8927             enddo
8928           enddo
8929         endif
8930 #endif
8931       endif
8932 #endif
8933 #ifdef MPI
8934       if (fg_rank.eq.king) then
8935 #endif
8936       Cnorm = 0.0d0
8937       do k=1,nsaxs
8938         Cnorm = Cnorm + Pcalc(k)
8939       enddo
8940       Esaxs_constr = dlog(Cnorm)-wsaxs0
8941       do k=1,nsaxs
8942         if (Pcalc(k).gt.0.0d0)
8943      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
8944 #ifdef DEBUG
8945         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
8946 #endif
8947       enddo
8948 #ifdef DEBUG
8949       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
8950 #endif
8951       do i=nnt,nct
8952         do l=1,3
8953           auxC=0.0d0
8954           auxC1=0.0d0
8955           auxX=0.0d0
8956           auxX1=0.d0
8957           do k=1,nsaxs
8958             if (Pcalc(k).gt.0)
8959      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
8960             auxC1 = auxC1+PgradC(k,l,i)
8961 #ifdef ALLSAXS
8962             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
8963             auxX1 = auxX1+PgradX(k,l,i)
8964 #endif
8965           enddo
8966           gsaxsC(l,i) = auxC - auxC1/Cnorm
8967 #ifdef ALLSAXS
8968           gsaxsX(l,i) = auxX - auxX1/Cnorm
8969 #endif
8970 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
8971 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
8972         enddo
8973       enddo
8974 #ifdef MPI
8975       endif
8976 #endif
8977       return
8978       end
8979 c----------------------------------------------------------------------------
8980       subroutine e_saxsC(Esaxs_constr)
8981       implicit none
8982       include 'DIMENSIONS'
8983       include 'DIMENSIONS.ZSCOPT'
8984       include 'DIMENSIONS.FREE'
8985 #ifdef MPI
8986       include "mpif.h"
8987       include "COMMON.SETUP"
8988       integer IERR
8989 #endif
8990       include 'COMMON.SBRIDGE'
8991       include 'COMMON.CHAIN'
8992       include 'COMMON.GEO'
8993       include 'COMMON.LOCAL'
8994       include 'COMMON.INTERACT'
8995       include 'COMMON.VAR'
8996       include 'COMMON.IOUNITS'
8997       include 'COMMON.DERIV'
8998       include 'COMMON.CONTROL'
8999       include 'COMMON.NAMES'
9000       include 'COMMON.FFIELD'
9001       include 'COMMON.LANGEVIN'
9002 c
9003       double precision Esaxs_constr
9004       integer i,iint,j,k,l
9005       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
9006 #ifdef MPI
9007       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9008 #endif
9009       double precision dk,dijCASPH,dijSCSPH,
9010      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9011      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9012      & auxX,auxX1,Cnorm
9013 c  SAXS restraint penalty function
9014 #ifdef DEBUG
9015       write(iout,*) "------- SAXS penalty function start -------"
9016       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9017      & " isaxs_end",isaxs_end
9018       write (iout,*) "nnt",nnt," ntc",nct
9019       do i=nnt,nct
9020         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9021      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9022       enddo
9023       do i=nnt,nct
9024         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9025       enddo
9026 #endif
9027       Esaxs_constr = 0.0d0
9028       logPtot=0.0d0
9029       do j=isaxs_start,isaxs_end
9030         Pcalc=0.0d0
9031         do i=1,nres
9032           do l=1,3
9033             PgradC(l,i)=0.0d0
9034             PgradX(l,i)=0.0d0
9035           enddo
9036         enddo
9037         do i=nnt,nct
9038           dijCASPH=0.0d0
9039           dijSCSPH=0.0d0
9040           do l=1,3
9041             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9042           enddo
9043           if (itype(i).ne.10) then
9044           do l=1,3
9045             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9046           enddo
9047           endif
9048           sigma2CA=2.0d0/pstok**2
9049           sigma2SC=4.0d0/restok(itype(i))**2
9050           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9051           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9052           Pcalc = Pcalc+expCASPH+expSCSPH
9053 #ifdef DEBUG
9054           write(*,*) "processor i j Pcalc",
9055      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
9056 #endif
9057           CASPHgrad = sigma2CA*expCASPH
9058           SCSPHgrad = sigma2SC*expSCSPH
9059           do l=1,3
9060             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9061             PgradX(l,i) = PgradX(l,i) + aux
9062             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9063           enddo ! l
9064         enddo ! i
9065         do i=nnt,nct
9066           do l=1,3
9067             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
9068             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
9069           enddo
9070         enddo
9071         logPtot = logPtot - dlog(Pcalc)
9072 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
9073 c     &    " logPtot",logPtot
9074       enddo ! j
9075 #ifdef MPI
9076       if (nfgtasks.gt.1) then
9077 c        write (iout,*) "logPtot before reduction",logPtot
9078         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9079      &    MPI_SUM,king,FG_COMM,IERR)
9080         logPtot = logPtot_
9081 c        write (iout,*) "logPtot after reduction",logPtot
9082         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9083      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9084         if (fg_rank.eq.king) then
9085           do i=1,nres
9086             do l=1,3
9087               gsaxsC(l,i) = gsaxsC_(l,i)
9088             enddo
9089           enddo
9090         endif
9091         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9092      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9093         if (fg_rank.eq.king) then
9094           do i=1,nres
9095             do l=1,3
9096               gsaxsX(l,i) = gsaxsX_(l,i)
9097             enddo
9098           enddo
9099         endif
9100       endif
9101 #endif
9102       Esaxs_constr = logPtot
9103       return
9104       end