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