source/wham/src-M-homology/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       else
 104          ecorr=0.0d0
 105          ecorr5=0.0d0
 106          ecorr6=0.0d0
 107          eturn6=0.0d0
 108       endif
 109       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 110          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 111       endif
 112
 113       write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 114       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 115         call e_saxs(Esaxs_constr)
 116         write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 117       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 118         call e_saxsC(Esaxs_constr)
 119 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 120       else
 121         Esaxs_constr = 0.0d0
 122       endif
 123
 124 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 125       if (constr_homology.ge.1) then
 126         call e_modeller(ehomology_constr)
 127       else
 128         ehomology_constr=0.0d0
 129       endif
 130
 131 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 132 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 133 #ifdef SPLITELE
 134       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 135      & +wvdwpp*evdw1
 136      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 137      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 138      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 139      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 140      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 141      & +wbond*estr+wsccor*fact(1)*esccor+wsaxs*esaxs_constr
 142 #else
 143       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 144      & +welec*fact(1)*(ees+evdw1)
 145      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 146      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 147      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 148      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 149      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 150      & +wbond*estr+wsccor*fact(1)*esccor+wsaxs*esaxs_constr
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(26)=esaxs_constr
 186 c detecting NaNQ
 187 #ifdef ISNAN
 188 #ifdef AIX
 189       if (isnan(etot).ne.0) energia(0)=1.0d+99
 190 #else
 191       if (isnan(etot)) energia(0)=1.0d+99
 192 #endif
 193 #else
 194       i=0
 195 #ifdef WINPGI
 196       idumm=proc_proc(etot,i)
 197 #else
 198       call proc_proc(etot,i)
 199 #endif
 200       if(i.eq.1)energia(0)=1.0d+99
 201 #endif
 202 #ifdef MPL
 203 c     endif
 204 #endif
 205 #define DEBUG
 206 #ifdef DEBUG
 207       call enerprint(energia,fact)
 208 #endif
 209 #undef DEBUG
 210       if (calc_grad) then
 211 C
 212 C Sum up the components of the Cartesian gradient.
 213 C
 214 #ifdef SPLITELE
 215       do i=1,nct
 216         do j=1,3
 217           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 218      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 219      &                wbond*gradb(j,i)+
 220      &                wstrain*ghpbc(j,i)+
 221      &                wcorr*fact(3)*gradcorr(j,i)+
 222      &                wel_loc*fact(2)*gel_loc(j,i)+
 223      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 224      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 225      &                wcorr5*fact(4)*gradcorr5(j,i)+
 226      &                wcorr6*fact(5)*gradcorr6(j,i)+
 227      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 228      &                wsccor*fact(2)*gsccorc(j,i)
 229      &               +wliptran*gliptranc(j,i)
 230           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 231      &                  wbond*gradbx(j,i)+
 232      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 233      &                  wsccor*fact(2)*gsccorx(j,i)
 234         enddo
 235 #else
 236       do i=1,nct
 237         do j=1,3
 238           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 239      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 240      &                wbond*gradb(j,i)+
 241      &                wcorr*fact(3)*gradcorr(j,i)+
 242      &                wel_loc*fact(2)*gel_loc(j,i)+
 243      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 244      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 245      &                wcorr5*fact(4)*gradcorr5(j,i)+
 246      &                wcorr6*fact(5)*gradcorr6(j,i)+
 247      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 248      &                wsccor*fact(2)*gsccorc(j,i)
 249      &               +wliptran*gliptranc(j,i)
 250           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 251      &                  wbond*gradbx(j,i)+
 252      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 253      &                  wsccor*fact(1)*gsccorx(j,i)
 254      &                 +wliptran*gliptranx(j,i)
 255         enddo
 256 #endif
 257       enddo
 258
 259
 260       do i=1,nres-3
 261         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 262      &   +wcorr5*fact(4)*g_corr5_loc(i)
 263      &   +wcorr6*fact(5)*g_corr6_loc(i)
 264      &   +wturn4*fact(3)*gel_loc_turn4(i)
 265      &   +wturn3*fact(2)*gel_loc_turn3(i)
 266      &   +wturn6*fact(5)*gel_loc_turn6(i)
 267      &   +wel_loc*fact(2)*gel_loc_loc(i)
 268 c     &   +wsccor*fact(1)*gsccor_loc(i)
 269 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 270       enddo
 271       endif
 272       if (dyn_ss) call dyn_set_nss
 273       return
 274       end
 275 C------------------------------------------------------------------------
 276       subroutine enerprint(energia,fact)
 277       implicit real*8 (a-h,o-z)
 278       include 'DIMENSIONS'
 279       include 'DIMENSIONS.ZSCOPT'
 280       include 'COMMON.IOUNITS'
 281       include 'COMMON.FFIELD'
 282       include 'COMMON.SBRIDGE'
 283       double precision energia(0:max_ene),fact(6)
 284       etot=energia(0)
 285       evdw=energia(1)+fact(6)*energia(21)
 286 #ifdef SCP14
 287       evdw2=energia(2)+energia(17)
 288 #else
 289       evdw2=energia(2)
 290 #endif
 291       ees=energia(3)
 292 #ifdef SPLITELE
 293       evdw1=energia(16)
 294 #endif
 295       ecorr=energia(4)
 296       ecorr5=energia(5)
 297       ecorr6=energia(6)
 298       eel_loc=energia(7)
 299       eello_turn3=energia(8)
 300       eello_turn4=energia(9)
 301       eello_turn6=energia(10)
 302       ebe=energia(11)
 303       escloc=energia(12)
 304       etors=energia(13)
 305       etors_d=energia(14)
 306       ehpb=energia(15)
 307       esccor=energia(19)
 308       edihcnstr=energia(20)
 309       estr=energia(18)
 310       ehomology_constr=energia(22)
 311       esaxs_constr=energia(26)
 312 #ifdef SPLITELE
 313       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 314      &  wvdwpp,
 315      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 316      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 317      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 318      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 319      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 320      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,
 321      &  esaxs_constr*wsaxs,ebr*nss,
 322      &  etot
 323    10 format (/'Virtual-chain energies:'//
 324      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 325      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 326      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 327      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 328      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 329      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 330      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 331      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 332      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 333      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 334      & ' (SS bridges & dist. cnstr.)'/
 335      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 337      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 338      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 339      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 340      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 341      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 342      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 343      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 344      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 345      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 346      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 347      & 'ETOT=  ',1pE16.6,' (total)')
 348 #else
 349       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 350      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 351      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 352      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 353      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 354      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 355      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs,ebr*nss,
 356      &  etot
 357    10 format (/'Virtual-chain energies:'//
 358      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 359      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 360      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 361      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 362      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 363      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 364      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 365      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 366      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 367      & ' (SS bridges & dist. cnstr.)'/
 368      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 369      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 370      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 372      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 373      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 374      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 375      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 376      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 377      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 378      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 379      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 380      & 'ETOT=  ',1pE16.6,' (total)')
 381 #endif
 382       return
 383       end
 384 C-----------------------------------------------------------------------
 385       subroutine elj(evdw,evdw_t)
 386 C
 387 C This subroutine calculates the interaction energy of nonbonded side chains
 388 C assuming the LJ potential of interaction.
 389 C
 390       implicit real*8 (a-h,o-z)
 391       include 'DIMENSIONS'
 392       include 'DIMENSIONS.ZSCOPT'
 393       include "DIMENSIONS.COMPAR"
 394       parameter (accur=1.0d-10)
 395       include 'COMMON.GEO'
 396       include 'COMMON.VAR'
 397       include 'COMMON.LOCAL'
 398       include 'COMMON.CHAIN'
 399       include 'COMMON.DERIV'
 400       include 'COMMON.INTERACT'
 401       include 'COMMON.TORSION'
 402       include 'COMMON.ENEPS'
 403       include 'COMMON.SBRIDGE'
 404       include 'COMMON.NAMES'
 405       include 'COMMON.IOUNITS'
 406       include 'COMMON.CONTACTS'
 407       dimension gg(3)
 408       integer icant
 409       external icant
 410 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 411       do i=1,210
 412         do j=1,2
 413           eneps_temp(j,i)=0.0d0
 414         enddo
 415       enddo
 416       evdw=0.0D0
 417       evdw_t=0.0d0
 418       do i=iatsc_s,iatsc_e
 419         itypi=iabs(itype(i))
 420         if (itypi.eq.ntyp1) cycle
 421         itypi1=iabs(itype(i+1))
 422         xi=c(1,nres+i)
 423         yi=c(2,nres+i)
 424         zi=c(3,nres+i)
 425 C Change 12/1/95
 426         num_conti=0
 427 C
 428 C Calculate SC interaction energy.
 429 C
 430         do iint=1,nint_gr(i)
 431 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 432 cd   &                  'iend=',iend(i,iint)
 433           do j=istart(i,iint),iend(i,iint)
 434             itypj=iabs(itype(j))
 435             if (itypj.eq.ntyp1) cycle
 436             xj=c(1,nres+j)-xi
 437             yj=c(2,nres+j)-yi
 438             zj=c(3,nres+j)-zi
 439 C Change 12/1/95 to calculate four-body interactions
 440             rij=xj*xj+yj*yj+zj*zj
 441             rrij=1.0D0/rij
 442 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 443             eps0ij=eps(itypi,itypj)
 444             fac=rrij**expon2
 445             e1=fac*fac*aa
 446             e2=fac*bb
 447             evdwij=e1+e2
 448             ij=icant(itypi,itypj)
 449             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 450             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 451 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 452 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 453 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 454 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 455 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 456 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 457             if (bb.gt.0.0d0) then
 458               evdw=evdw+evdwij
 459             else
 460               evdw_t=evdw_t+evdwij
 461             endif
 462             if (calc_grad) then
 463 C
 464 C Calculate the components of the gradient in DC and X
 465 C
 466             fac=-rrij*(e1+evdwij)
 467             gg(1)=xj*fac
 468             gg(2)=yj*fac
 469             gg(3)=zj*fac
 470             do k=1,3
 471               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 472               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 473             enddo
 474             do k=i,j-1
 475               do l=1,3
 476                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 477               enddo
 478             enddo
 479             endif
 480 C
 481 C 12/1/95, revised on 5/20/97
 482 C
 483 C Calculate the contact function. The ith column of the array JCONT will
 484 C contain the numbers of atoms that make contacts with the atom I (of numbers
 485 C greater than I). The arrays FACONT and GACONT will contain the values of
 486 C the contact function and its derivative.
 487 C
 488 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 489 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 490 C Uncomment next line, if the correlation interactions are contact function only
 491             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 492               rij=dsqrt(rij)
 493               sigij=sigma(itypi,itypj)
 494               r0ij=rs0(itypi,itypj)
 495 C
 496 C Check whether the SC's are not too far to make a contact.
 497 C
 498               rcut=1.5d0*r0ij
 499               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 500 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 501 C
 502               if (fcont.gt.0.0D0) then
 503 C If the SC-SC distance if close to sigma, apply spline.
 504 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 505 cAdam &             fcont1,fprimcont1)
 506 cAdam           fcont1=1.0d0-fcont1
 507 cAdam           if (fcont1.gt.0.0d0) then
 508 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 509 cAdam             fcont=fcont*fcont1
 510 cAdam           endif
 511 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 512 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 513 cga             do k=1,3
 514 cga               gg(k)=gg(k)*eps0ij
 515 cga             enddo
 516 cga             eps0ij=-evdwij*eps0ij
 517 C Uncomment for AL's type of SC correlation interactions.
 518 cadam           eps0ij=-evdwij
 519                 num_conti=num_conti+1
 520                 jcont(num_conti,i)=j
 521                 facont(num_conti,i)=fcont*eps0ij
 522                 fprimcont=eps0ij*fprimcont/rij
 523                 fcont=expon*fcont
 524 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 525 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 526 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 527 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 528                 gacont(1,num_conti,i)=-fprimcont*xj
 529                 gacont(2,num_conti,i)=-fprimcont*yj
 530                 gacont(3,num_conti,i)=-fprimcont*zj
 531 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 532 cd              write (iout,'(2i3,3f10.5)')
 533 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 534               endif
 535             endif
 536           enddo      ! j
 537         enddo        ! iint
 538 C Change 12/1/95
 539         num_cont(i)=num_conti
 540       enddo          ! i
 541       if (calc_grad) then
 542       do i=1,nct
 543         do j=1,3
 544           gvdwc(j,i)=expon*gvdwc(j,i)
 545           gvdwx(j,i)=expon*gvdwx(j,i)
 546         enddo
 547       enddo
 548       endif
 549 C******************************************************************************
 550 C
 551 C                              N O T E !!!
 552 C
 553 C To save time, the factor of EXPON has been extracted from ALL components
 554 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 555 C use!
 556 C
 557 C******************************************************************************
 558       return
 559       end
 560 C-----------------------------------------------------------------------------
 561       subroutine eljk(evdw,evdw_t)
 562 C
 563 C This subroutine calculates the interaction energy of nonbonded side chains
 564 C assuming the LJK potential of interaction.
 565 C
 566       implicit real*8 (a-h,o-z)
 567       include 'DIMENSIONS'
 568       include 'DIMENSIONS.ZSCOPT'
 569       include "DIMENSIONS.COMPAR"
 570       include 'COMMON.GEO'
 571       include 'COMMON.VAR'
 572       include 'COMMON.LOCAL'
 573       include 'COMMON.CHAIN'
 574       include 'COMMON.DERIV'
 575       include 'COMMON.INTERACT'
 576       include 'COMMON.ENEPS'
 577       include 'COMMON.IOUNITS'
 578       include 'COMMON.NAMES'
 579       dimension gg(3)
 580       logical scheck
 581       integer icant
 582       external icant
 583 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 584       do i=1,210
 585         do j=1,2
 586           eneps_temp(j,i)=0.0d0
 587         enddo
 588       enddo
 589       evdw=0.0D0
 590       evdw_t=0.0d0
 591       do i=iatsc_s,iatsc_e
 592         itypi=iabs(itype(i))
 593         if (itypi.eq.ntyp1) cycle
 594         itypi1=iabs(itype(i+1))
 595         xi=c(1,nres+i)
 596         yi=c(2,nres+i)
 597         zi=c(3,nres+i)
 598 C
 599 C Calculate SC interaction energy.
 600 C
 601         do iint=1,nint_gr(i)
 602           do j=istart(i,iint),iend(i,iint)
 603             itypj=iabs(itype(j))
 604             if (itypj.eq.ntyp1) cycle
 605             xj=c(1,nres+j)-xi
 606             yj=c(2,nres+j)-yi
 607             zj=c(3,nres+j)-zi
 608             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 609             fac_augm=rrij**expon
 610             e_augm=augm(itypi,itypj)*fac_augm
 611             r_inv_ij=dsqrt(rrij)
 612             rij=1.0D0/r_inv_ij
 613             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 614             fac=r_shift_inv**expon
 615             e1=fac*fac*aa
 616             e2=fac*bb
 617             evdwij=e_augm+e1+e2
 618             ij=icant(itypi,itypj)
 619             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 620      &        /dabs(eps(itypi,itypj))
 621             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 622 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 623 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 624 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 625 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 626 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 627 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 628 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 629             if (bb.gt.0.0d0) then
 630               evdw=evdw+evdwij
 631             else
 632               evdw_t=evdw_t+evdwij
 633             endif
 634             if (calc_grad) then
 635 C
 636 C Calculate the components of the gradient in DC and X
 637 C
 638             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 639             gg(1)=xj*fac
 640             gg(2)=yj*fac
 641             gg(3)=zj*fac
 642             do k=1,3
 643               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 644               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 645             enddo
 646             do k=i,j-1
 647               do l=1,3
 648                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 649               enddo
 650             enddo
 651             endif
 652           enddo      ! j
 653         enddo        ! iint
 654       enddo          ! i
 655       if (calc_grad) then
 656       do i=1,nct
 657         do j=1,3
 658           gvdwc(j,i)=expon*gvdwc(j,i)
 659           gvdwx(j,i)=expon*gvdwx(j,i)
 660         enddo
 661       enddo
 662       endif
 663       return
 664       end
 665 C-----------------------------------------------------------------------------
 666       subroutine ebp(evdw,evdw_t)
 667 C
 668 C This subroutine calculates the interaction energy of nonbonded side chains
 669 C assuming the Berne-Pechukas potential of interaction.
 670 C
 671       implicit real*8 (a-h,o-z)
 672       include 'DIMENSIONS'
 673       include 'DIMENSIONS.ZSCOPT'
 674       include "DIMENSIONS.COMPAR"
 675       include 'COMMON.GEO'
 676       include 'COMMON.VAR'
 677       include 'COMMON.LOCAL'
 678       include 'COMMON.CHAIN'
 679       include 'COMMON.DERIV'
 680       include 'COMMON.NAMES'
 681       include 'COMMON.INTERACT'
 682       include 'COMMON.ENEPS'
 683       include 'COMMON.IOUNITS'
 684       include 'COMMON.CALC'
 685       common /srutu/ icall
 686 c     double precision rrsave(maxdim)
 687       logical lprn
 688       integer icant
 689       external icant
 690       do i=1,210
 691         do j=1,2
 692           eneps_temp(j,i)=0.0d0
 693         enddo
 694       enddo
 695       evdw=0.0D0
 696       evdw_t=0.0d0
 697 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 698 c     if (icall.eq.0) then
 699 c       lprn=.true.
 700 c     else
 701         lprn=.false.
 702 c     endif
 703       ind=0
 704       do i=iatsc_s,iatsc_e
 705         itypi=iabs(itype(i))
 706         if (itypi.eq.ntyp1) cycle
 707         itypi1=iabs(itype(i+1))
 708         xi=c(1,nres+i)
 709         yi=c(2,nres+i)
 710         zi=c(3,nres+i)
 711         dxi=dc_norm(1,nres+i)
 712         dyi=dc_norm(2,nres+i)
 713         dzi=dc_norm(3,nres+i)
 714         dsci_inv=vbld_inv(i+nres)
 715 C
 716 C Calculate SC interaction energy.
 717 C
 718         do iint=1,nint_gr(i)
 719           do j=istart(i,iint),iend(i,iint)
 720             ind=ind+1
 721             itypj=iabs(itype(j))
 722             if (itypj.eq.ntyp1) cycle
 723             dscj_inv=vbld_inv(j+nres)
 724             chi1=chi(itypi,itypj)
 725             chi2=chi(itypj,itypi)
 726             chi12=chi1*chi2
 727             chip1=chip(itypi)
 728             chip2=chip(itypj)
 729             chip12=chip1*chip2
 730             alf1=alp(itypi)
 731             alf2=alp(itypj)
 732             alf12=0.5D0*(alf1+alf2)
 733 C For diagnostics only!!!
 734 c           chi1=0.0D0
 735 c           chi2=0.0D0
 736 c           chi12=0.0D0
 737 c           chip1=0.0D0
 738 c           chip2=0.0D0
 739 c           chip12=0.0D0
 740 c           alf1=0.0D0
 741 c           alf2=0.0D0
 742 c           alf12=0.0D0
 743             xj=c(1,nres+j)-xi
 744             yj=c(2,nres+j)-yi
 745             zj=c(3,nres+j)-zi
 746             dxj=dc_norm(1,nres+j)
 747             dyj=dc_norm(2,nres+j)
 748             dzj=dc_norm(3,nres+j)
 749             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 750 cd          if (icall.eq.0) then
 751 cd            rrsave(ind)=rrij
 752 cd          else
 753 cd            rrij=rrsave(ind)
 754 cd          endif
 755             rij=dsqrt(rrij)
 756 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 757             call sc_angular
 758 C Calculate whole angle-dependent part of epsilon and contributions
 759 C to its derivatives
 760             fac=(rrij*sigsq)**expon2
 761             e1=fac*fac*aa
 762             e2=fac*bb
 763             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 764             eps2der=evdwij*eps3rt
 765             eps3der=evdwij*eps2rt
 766             evdwij=evdwij*eps2rt*eps3rt
 767             ij=icant(itypi,itypj)
 768             aux=eps1*eps2rt**2*eps3rt**2
 769             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 770      &        /dabs(eps(itypi,itypj))
 771             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 772             if (bb.gt.0.0d0) then
 773               evdw=evdw+evdwij
 774             else
 775               evdw_t=evdw_t+evdwij
 776             endif
 777             if (calc_grad) then
 778             if (lprn) then
 779             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 780             epsi=bb**2/aa
 781             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 782      &        restyp(itypi),i,restyp(itypj),j,
 783      &        epsi,sigm,chi1,chi2,chip1,chip2,
 784      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 785      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 786      &        evdwij
 787             endif
 788 C Calculate gradient components.
 789             e1=e1*eps1*eps2rt**2*eps3rt**2
 790             fac=-expon*(e1+evdwij)
 791             sigder=fac/sigsq
 792             fac=rrij*fac
 793 C Calculate radial part of the gradient
 794             gg(1)=xj*fac
 795             gg(2)=yj*fac
 796             gg(3)=zj*fac
 797 C Calculate the angular part of the gradient and sum add the contributions
 798 C to the appropriate components of the Cartesian gradient.
 799             call sc_grad
 800             endif
 801           enddo      ! j
 802         enddo        ! iint
 803       enddo          ! i
 804 c     stop
 805       return
 806       end
 807 C-----------------------------------------------------------------------------
 808       subroutine egb(evdw,evdw_t)
 809 C
 810 C This subroutine calculates the interaction energy of nonbonded side chains
 811 C assuming the Gay-Berne potential of interaction.
 812 C
 813       implicit real*8 (a-h,o-z)
 814       include 'DIMENSIONS'
 815       include 'DIMENSIONS.ZSCOPT'
 816       include "DIMENSIONS.COMPAR"
 817       include 'COMMON.GEO'
 818       include 'COMMON.VAR'
 819       include 'COMMON.LOCAL'
 820       include 'COMMON.CHAIN'
 821       include 'COMMON.DERIV'
 822       include 'COMMON.NAMES'
 823       include 'COMMON.INTERACT'
 824       include 'COMMON.ENEPS'
 825       include 'COMMON.IOUNITS'
 826       include 'COMMON.CALC'
 827       include 'COMMON.SBRIDGE'
 828       logical lprn
 829       common /srutu/icall
 830       integer icant,xshift,yshift,zshift
 831       external icant
 832       do i=1,210
 833         do j=1,2
 834           eneps_temp(j,i)=0.0d0
 835         enddo
 836       enddo
 837 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 838       evdw=0.0D0
 839       evdw_t=0.0d0
 840       lprn=.false.
 841 c      if (icall.gt.0) lprn=.true.
 842       ind=0
 843       do i=iatsc_s,iatsc_e
 844         itypi=iabs(itype(i))
 845         if (itypi.eq.ntyp1) cycle
 846         itypi1=iabs(itype(i+1))
 847         xi=c(1,nres+i)
 848         yi=c(2,nres+i)
 849         zi=c(3,nres+i)
 850 C returning the ith atom to box
 851           xi=mod(xi,boxxsize)
 852           if (xi.lt.0) xi=xi+boxxsize
 853           yi=mod(yi,boxysize)
 854           if (yi.lt.0) yi=yi+boxysize
 855           zi=mod(zi,boxzsize)
 856           if (zi.lt.0) zi=zi+boxzsize
 857        if ((zi.gt.bordlipbot)
 858      &.and.(zi.lt.bordliptop)) then
 859 C the energy transfer exist
 860         if (zi.lt.buflipbot) then
 861 C what fraction I am in
 862          fracinbuf=1.0d0-
 863      &        ((zi-bordlipbot)/lipbufthick)
 864 C lipbufthick is thickenes of lipid buffore
 865          sslipi=sscalelip(fracinbuf)
 866          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 867         elseif (zi.gt.bufliptop) then
 868          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 869          sslipi=sscalelip(fracinbuf)
 870          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 871         else
 872          sslipi=1.0d0
 873          ssgradlipi=0.0
 874         endif
 875        else
 876          sslipi=0.0d0
 877          ssgradlipi=0.0
 878        endif
 879
 880         dxi=dc_norm(1,nres+i)
 881         dyi=dc_norm(2,nres+i)
 882         dzi=dc_norm(3,nres+i)
 883         dsci_inv=vbld_inv(i+nres)
 884 C
 885 C Calculate SC interaction energy.
 886 C
 887         do iint=1,nint_gr(i)
 888           do j=istart(i,iint),iend(i,iint)
 889             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 890               call dyn_ssbond_ene(i,j,evdwij)
 891               evdw=evdw+evdwij
 892 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 893 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 894 C triple bond artifac removal
 895              do k=j+1,iend(i,iint)
 896 C search over all next residues
 897               if (dyn_ss_mask(k)) then
 898 C check if they are cysteins
 899 C              write(iout,*) 'k=',k
 900               call triple_ssbond_ene(i,j,k,evdwij)
 901 C call the energy function that removes the artifical triple disulfide
 902 C bond the soubroutine is located in ssMD.F
 903               evdw=evdw+evdwij
 904 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 905 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 906               endif!dyn_ss_mask(k)
 907              enddo! k
 908             ELSE
 909             ind=ind+1
 910             itypj=iabs(itype(j))
 911             if (itypj.eq.ntyp1) cycle
 912             dscj_inv=vbld_inv(j+nres)
 913             sig0ij=sigma(itypi,itypj)
 914             chi1=chi(itypi,itypj)
 915             chi2=chi(itypj,itypi)
 916             chi12=chi1*chi2
 917             chip1=chip(itypi)
 918             chip2=chip(itypj)
 919             chip12=chip1*chip2
 920             alf1=alp(itypi)
 921             alf2=alp(itypj)
 922             alf12=0.5D0*(alf1+alf2)
 923 C For diagnostics only!!!
 924 c           chi1=0.0D0
 925 c           chi2=0.0D0
 926 c           chi12=0.0D0
 927 c           chip1=0.0D0
 928 c           chip2=0.0D0
 929 c           chip12=0.0D0
 930 c           alf1=0.0D0
 931 c           alf2=0.0D0
 932 c           alf12=0.0D0
 933             xj=c(1,nres+j)
 934             yj=c(2,nres+j)
 935             zj=c(3,nres+j)
 936 C returning jth atom to box
 937           xj=mod(xj,boxxsize)
 938           if (xj.lt.0) xj=xj+boxxsize
 939           yj=mod(yj,boxysize)
 940           if (yj.lt.0) yj=yj+boxysize
 941           zj=mod(zj,boxzsize)
 942           if (zj.lt.0) zj=zj+boxzsize
 943        if ((zj.gt.bordlipbot)
 944      &.and.(zj.lt.bordliptop)) then
 945 C the energy transfer exist
 946         if (zj.lt.buflipbot) then
 947 C what fraction I am in
 948          fracinbuf=1.0d0-
 949      &        ((zj-bordlipbot)/lipbufthick)
 950 C lipbufthick is thickenes of lipid buffore
 951          sslipj=sscalelip(fracinbuf)
 952          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 953         elseif (zj.gt.bufliptop) then
 954          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 955          sslipj=sscalelip(fracinbuf)
 956          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 957         else
 958          sslipj=1.0d0
 959          ssgradlipj=0.0
 960         endif
 961        else
 962          sslipj=0.0d0
 963          ssgradlipj=0.0
 964        endif
 965       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 966      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 967       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 968      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 969 C       if (aa.ne.aa_aq(itypi,itypj)) then
 970
 971 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
 972 C     & bb_aq(itypi,itypj)-bb,
 973 C     & sslipi,sslipj
 974 C         endif
 975
 976 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 977 C checking the distance
 978       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 979       xj_safe=xj
 980       yj_safe=yj
 981       zj_safe=zj
 982       subchap=0
 983 C finding the closest
 984       do xshift=-1,1
 985       do yshift=-1,1
 986       do zshift=-1,1
 987           xj=xj_safe+xshift*boxxsize
 988           yj=yj_safe+yshift*boxysize
 989           zj=zj_safe+zshift*boxzsize
 990           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 991           if(dist_temp.lt.dist_init) then
 992             dist_init=dist_temp
 993             xj_temp=xj
 994             yj_temp=yj
 995             zj_temp=zj
 996             subchap=1
 997           endif
 998        enddo
 999        enddo
1000        enddo
1001        if (subchap.eq.1) then
1002           xj=xj_temp-xi
1003           yj=yj_temp-yi
1004           zj=zj_temp-zi
1005        else
1006           xj=xj_safe-xi
1007           yj=yj_safe-yi
1008           zj=zj_safe-zi
1009        endif
1010
1011             dxj=dc_norm(1,nres+j)
1012             dyj=dc_norm(2,nres+j)
1013             dzj=dc_norm(3,nres+j)
1014 c            write (iout,*) i,j,xj,yj,zj
1015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1016             rij=dsqrt(rrij)
1017             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1018             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1019             if (sss.le.0.0) cycle
1020 C Calculate angle-dependent terms of energy and contributions to their
1021 C derivatives.
1022
1023             call sc_angular
1024             sigsq=1.0D0/sigsq
1025             sig=sig0ij*dsqrt(sigsq)
1026             rij_shift=1.0D0/rij-sig+sig0ij
1027 C I hate to put IF's in the loops, but here don't have another choice!!!!
1028             if (rij_shift.le.0.0D0) then
1029               evdw=1.0D20
1030               return
1031             endif
1032             sigder=-sig*sigsq
1033 c---------------------------------------------------------------
1034             rij_shift=1.0D0/rij_shift
1035             fac=rij_shift**expon
1036             e1=fac*fac*aa
1037             e2=fac*bb
1038             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1039             eps2der=evdwij*eps3rt
1040             eps3der=evdwij*eps2rt
1041             evdwij=evdwij*eps2rt*eps3rt
1042             if (bb.gt.0) then
1043               evdw=evdw+evdwij*sss
1044             else
1045               evdw_t=evdw_t+evdwij*sss
1046             endif
1047             ij=icant(itypi,itypj)
1048             aux=eps1*eps2rt**2*eps3rt**2
1049             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1050      &        /dabs(eps(itypi,itypj))
1051             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1052 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1053 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1054 c     &         aux*e2/eps(itypi,itypj)
1055 c            if (lprn) then
1056             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1057             epsi=bb**2/aa
1058 C#define DEBUG
1059 #ifdef DEBUG
1060             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1061      &        restyp(itypi),i,restyp(itypj),j,
1062      &        epsi,sigm,chi1,chi2,chip1,chip2,
1063      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1064      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1065      &        evdwij
1066              write (iout,*) "partial sum", evdw, evdw_t
1067 #endif
1068 C#undef DEBUG
1069 c            endif
1070             if (calc_grad) then
1071 C Calculate gradient components.
1072             e1=e1*eps1*eps2rt**2*eps3rt**2
1073             fac=-expon*(e1+evdwij)*rij_shift
1074             sigder=fac*sigder
1075             fac=rij*fac
1076             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1077 C Calculate the radial part of the gradient
1078             gg(1)=xj*fac
1079             gg(2)=yj*fac
1080             gg(3)=zj*fac
1081 C Calculate angular part of the gradient.
1082             call sc_grad
1083             endif
1084 C            write(iout,*)  "partial sum", evdw, evdw_t
1085             ENDIF    ! dyn_ss
1086           enddo      ! j
1087         enddo        ! iint
1088       enddo          ! i
1089       return
1090       end
1091 C-----------------------------------------------------------------------------
1092       subroutine egbv(evdw,evdw_t)
1093 C
1094 C This subroutine calculates the interaction energy of nonbonded side chains
1095 C assuming the Gay-Berne-Vorobjev potential of interaction.
1096 C
1097       implicit real*8 (a-h,o-z)
1098       include 'DIMENSIONS'
1099       include 'DIMENSIONS.ZSCOPT'
1100       include "DIMENSIONS.COMPAR"
1101       include 'COMMON.GEO'
1102       include 'COMMON.VAR'
1103       include 'COMMON.LOCAL'
1104       include 'COMMON.CHAIN'
1105       include 'COMMON.DERIV'
1106       include 'COMMON.NAMES'
1107       include 'COMMON.INTERACT'
1108       include 'COMMON.ENEPS'
1109       include 'COMMON.IOUNITS'
1110       include 'COMMON.CALC'
1111       common /srutu/ icall
1112       logical lprn
1113       integer icant
1114       external icant
1115       do i=1,210
1116         do j=1,2
1117           eneps_temp(j,i)=0.0d0
1118         enddo
1119       enddo
1120       evdw=0.0D0
1121       evdw_t=0.0d0
1122 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1123       evdw=0.0D0
1124       lprn=.false.
1125 c      if (icall.gt.0) lprn=.true.
1126       ind=0
1127       do i=iatsc_s,iatsc_e
1128         itypi=iabs(itype(i))
1129         if (itypi.eq.ntyp1) cycle
1130         itypi1=iabs(itype(i+1))
1131         xi=c(1,nres+i)
1132         yi=c(2,nres+i)
1133         zi=c(3,nres+i)
1134         dxi=dc_norm(1,nres+i)
1135         dyi=dc_norm(2,nres+i)
1136         dzi=dc_norm(3,nres+i)
1137         dsci_inv=vbld_inv(i+nres)
1138 C
1139 C Calculate SC interaction energy.
1140 C
1141         do iint=1,nint_gr(i)
1142           do j=istart(i,iint),iend(i,iint)
1143             ind=ind+1
1144             itypj=iabs(itype(j))
1145             if (itypj.eq.ntyp1) cycle
1146             dscj_inv=vbld_inv(j+nres)
1147             sig0ij=sigma(itypi,itypj)
1148             r0ij=r0(itypi,itypj)
1149             chi1=chi(itypi,itypj)
1150             chi2=chi(itypj,itypi)
1151             chi12=chi1*chi2
1152             chip1=chip(itypi)
1153             chip2=chip(itypj)
1154             chip12=chip1*chip2
1155             alf1=alp(itypi)
1156             alf2=alp(itypj)
1157             alf12=0.5D0*(alf1+alf2)
1158 C For diagnostics only!!!
1159 c           chi1=0.0D0
1160 c           chi2=0.0D0
1161 c           chi12=0.0D0
1162 c           chip1=0.0D0
1163 c           chip2=0.0D0
1164 c           chip12=0.0D0
1165 c           alf1=0.0D0
1166 c           alf2=0.0D0
1167 c           alf12=0.0D0
1168             xj=c(1,nres+j)-xi
1169             yj=c(2,nres+j)-yi
1170             zj=c(3,nres+j)-zi
1171             dxj=dc_norm(1,nres+j)
1172             dyj=dc_norm(2,nres+j)
1173             dzj=dc_norm(3,nres+j)
1174             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1175             rij=dsqrt(rrij)
1176 C Calculate angle-dependent terms of energy and contributions to their
1177 C derivatives.
1178             call sc_angular
1179             sigsq=1.0D0/sigsq
1180             sig=sig0ij*dsqrt(sigsq)
1181             rij_shift=1.0D0/rij-sig+r0ij
1182 C I hate to put IF's in the loops, but here don't have another choice!!!!
1183             if (rij_shift.le.0.0D0) then
1184               evdw=1.0D20
1185               return
1186             endif
1187             sigder=-sig*sigsq
1188 c---------------------------------------------------------------
1189             rij_shift=1.0D0/rij_shift
1190             fac=rij_shift**expon
1191             e1=fac*fac*aa
1192             e2=fac*bb
1193             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1194             eps2der=evdwij*eps3rt
1195             eps3der=evdwij*eps2rt
1196             fac_augm=rrij**expon
1197             e_augm=augm(itypi,itypj)*fac_augm
1198             evdwij=evdwij*eps2rt*eps3rt
1199             if (bb.gt.0.0d0) then
1200               evdw=evdw+evdwij+e_augm
1201             else
1202               evdw_t=evdw_t+evdwij+e_augm
1203             endif
1204             ij=icant(itypi,itypj)
1205             aux=eps1*eps2rt**2*eps3rt**2
1206             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1207      &        /dabs(eps(itypi,itypj))
1208             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1209 c            eneps_temp(ij)=eneps_temp(ij)
1210 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1211 c            if (lprn) then
1212 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1213 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1214 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1215 c     &        restyp(itypi),i,restyp(itypj),j,
1216 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1217 c     &        chi1,chi2,chip1,chip2,
1218 c     &        eps1,eps2rt**2,eps3rt**2,
1219 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1220 c     &        evdwij+e_augm
1221 c            endif
1222             if (calc_grad) then
1223 C Calculate gradient components.
1224             e1=e1*eps1*eps2rt**2*eps3rt**2
1225             fac=-expon*(e1+evdwij)*rij_shift
1226             sigder=fac*sigder
1227             fac=rij*fac-2*expon*rrij*e_augm
1228 C Calculate the radial part of the gradient
1229             gg(1)=xj*fac
1230             gg(2)=yj*fac
1231             gg(3)=zj*fac
1232 C Calculate angular part of the gradient.
1233             call sc_grad
1234             endif
1235           enddo      ! j
1236         enddo        ! iint
1237       enddo          ! i
1238       return
1239       end
1240 C-----------------------------------------------------------------------------
1241       subroutine sc_angular
1242 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1243 C om12. Called by ebp, egb, and egbv.
1244       implicit none
1245       include 'COMMON.CALC'
1246       erij(1)=xj*rij
1247       erij(2)=yj*rij
1248       erij(3)=zj*rij
1249       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1250       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1251       om12=dxi*dxj+dyi*dyj+dzi*dzj
1252       chiom12=chi12*om12
1253 C Calculate eps1(om12) and its derivative in om12
1254       faceps1=1.0D0-om12*chiom12
1255       faceps1_inv=1.0D0/faceps1
1256       eps1=dsqrt(faceps1_inv)
1257 C Following variable is eps1*deps1/dom12
1258       eps1_om12=faceps1_inv*chiom12
1259 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1260 C and om12.
1261       om1om2=om1*om2
1262       chiom1=chi1*om1
1263       chiom2=chi2*om2
1264       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1265       sigsq=1.0D0-facsig*faceps1_inv
1266       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1267       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1268       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1269 C Calculate eps2 and its derivatives in om1, om2, and om12.
1270       chipom1=chip1*om1
1271       chipom2=chip2*om2
1272       chipom12=chip12*om12
1273       facp=1.0D0-om12*chipom12
1274       facp_inv=1.0D0/facp
1275       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1276 C Following variable is the square root of eps2
1277       eps2rt=1.0D0-facp1*facp_inv
1278 C Following three variables are the derivatives of the square root of eps
1279 C in om1, om2, and om12.
1280       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1281       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1282       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1283 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1284       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1285 C Calculate whole angle-dependent part of epsilon and contributions
1286 C to its derivatives
1287       return
1288       end
1289 C----------------------------------------------------------------------------
1290       subroutine sc_grad
1291       implicit real*8 (a-h,o-z)
1292       include 'DIMENSIONS'
1293       include 'DIMENSIONS.ZSCOPT'
1294       include 'COMMON.CHAIN'
1295       include 'COMMON.DERIV'
1296       include 'COMMON.CALC'
1297       double precision dcosom1(3),dcosom2(3)
1298       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1299       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1300       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1301      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1302       do k=1,3
1303         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1304         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1305       enddo
1306       do k=1,3
1307         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1308       enddo
1309       do k=1,3
1310         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1311      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1312      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1313         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1314      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1315      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1316       enddo
1317 C
1318 C Calculate the components of the gradient in DC and X
1319 C
1320       do k=i,j-1
1321         do l=1,3
1322           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1323         enddo
1324       enddo
1325       return
1326       end
1327 c------------------------------------------------------------------------------
1328       subroutine vec_and_deriv
1329       implicit real*8 (a-h,o-z)
1330       include 'DIMENSIONS'
1331       include 'DIMENSIONS.ZSCOPT'
1332       include 'COMMON.IOUNITS'
1333       include 'COMMON.GEO'
1334       include 'COMMON.VAR'
1335       include 'COMMON.LOCAL'
1336       include 'COMMON.CHAIN'
1337       include 'COMMON.VECTORS'
1338       include 'COMMON.DERIV'
1339       include 'COMMON.INTERACT'
1340       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1341 C Compute the local reference systems. For reference system (i), the
1342 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1343 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1344       do i=1,nres-1
1345 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1346           if (i.eq.nres-1) then
1347 C Case of the last full residue
1348 C Compute the Z-axis
1349             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1350             costh=dcos(pi-theta(nres))
1351             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1352             do k=1,3
1353               uz(k,i)=fac*uz(k,i)
1354             enddo
1355             if (calc_grad) then
1356 C Compute the derivatives of uz
1357             uzder(1,1,1)= 0.0d0
1358             uzder(2,1,1)=-dc_norm(3,i-1)
1359             uzder(3,1,1)= dc_norm(2,i-1)
1360             uzder(1,2,1)= dc_norm(3,i-1)
1361             uzder(2,2,1)= 0.0d0
1362             uzder(3,2,1)=-dc_norm(1,i-1)
1363             uzder(1,3,1)=-dc_norm(2,i-1)
1364             uzder(2,3,1)= dc_norm(1,i-1)
1365             uzder(3,3,1)= 0.0d0
1366             uzder(1,1,2)= 0.0d0
1367             uzder(2,1,2)= dc_norm(3,i)
1368             uzder(3,1,2)=-dc_norm(2,i)
1369             uzder(1,2,2)=-dc_norm(3,i)
1370             uzder(2,2,2)= 0.0d0
1371             uzder(3,2,2)= dc_norm(1,i)
1372             uzder(1,3,2)= dc_norm(2,i)
1373             uzder(2,3,2)=-dc_norm(1,i)
1374             uzder(3,3,2)= 0.0d0
1375             endif
1376 C Compute the Y-axis
1377             facy=fac
1378             do k=1,3
1379               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1380             enddo
1381             if (calc_grad) then
1382 C Compute the derivatives of uy
1383             do j=1,3
1384               do k=1,3
1385                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1386      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1387                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1388               enddo
1389               uyder(j,j,1)=uyder(j,j,1)-costh
1390               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1391             enddo
1392             do j=1,2
1393               do k=1,3
1394                 do l=1,3
1395                   uygrad(l,k,j,i)=uyder(l,k,j)
1396                   uzgrad(l,k,j,i)=uzder(l,k,j)
1397                 enddo
1398               enddo
1399             enddo
1400             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1401             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1402             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1403             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1404             endif
1405           else
1406 C Other residues
1407 C Compute the Z-axis
1408             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1409             costh=dcos(pi-theta(i+2))
1410             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1411             do k=1,3
1412               uz(k,i)=fac*uz(k,i)
1413             enddo
1414             if (calc_grad) then
1415 C Compute the derivatives of uz
1416             uzder(1,1,1)= 0.0d0
1417             uzder(2,1,1)=-dc_norm(3,i+1)
1418             uzder(3,1,1)= dc_norm(2,i+1)
1419             uzder(1,2,1)= dc_norm(3,i+1)
1420             uzder(2,2,1)= 0.0d0
1421             uzder(3,2,1)=-dc_norm(1,i+1)
1422             uzder(1,3,1)=-dc_norm(2,i+1)
1423             uzder(2,3,1)= dc_norm(1,i+1)
1424             uzder(3,3,1)= 0.0d0
1425             uzder(1,1,2)= 0.0d0
1426             uzder(2,1,2)= dc_norm(3,i)
1427             uzder(3,1,2)=-dc_norm(2,i)
1428             uzder(1,2,2)=-dc_norm(3,i)
1429             uzder(2,2,2)= 0.0d0
1430             uzder(3,2,2)= dc_norm(1,i)
1431             uzder(1,3,2)= dc_norm(2,i)
1432             uzder(2,3,2)=-dc_norm(1,i)
1433             uzder(3,3,2)= 0.0d0
1434             endif
1435 C Compute the Y-axis
1436             facy=fac
1437             do k=1,3
1438               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1439             enddo
1440             if (calc_grad) then
1441 C Compute the derivatives of uy
1442             do j=1,3
1443               do k=1,3
1444                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1445      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1446                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1447               enddo
1448               uyder(j,j,1)=uyder(j,j,1)-costh
1449               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           endif
1464           endif
1465       enddo
1466       if (calc_grad) then
1467       do i=1,nres-1
1468         vbld_inv_temp(1)=vbld_inv(i+1)
1469         if (i.lt.nres-1) then
1470           vbld_inv_temp(2)=vbld_inv(i+2)
1471         else
1472           vbld_inv_temp(2)=vbld_inv(i)
1473         endif
1474         do j=1,2
1475           do k=1,3
1476             do l=1,3
1477               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1478               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1479             enddo
1480           enddo
1481         enddo
1482       enddo
1483       endif
1484       return
1485       end
1486 C-----------------------------------------------------------------------------
1487       subroutine vec_and_deriv_test
1488       implicit real*8 (a-h,o-z)
1489       include 'DIMENSIONS'
1490       include 'DIMENSIONS.ZSCOPT'
1491       include 'COMMON.IOUNITS'
1492       include 'COMMON.GEO'
1493       include 'COMMON.VAR'
1494       include 'COMMON.LOCAL'
1495       include 'COMMON.CHAIN'
1496       include 'COMMON.VECTORS'
1497       dimension uyder(3,3,2),uzder(3,3,2)
1498 C Compute the local reference systems. For reference system (i), the
1499 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1500 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1501       do i=1,nres-1
1502           if (i.eq.nres-1) then
1503 C Case of the last full residue
1504 C Compute the Z-axis
1505             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1506             costh=dcos(pi-theta(nres))
1507             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1508 c            write (iout,*) 'fac',fac,
1509 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1510             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1511             do k=1,3
1512               uz(k,i)=fac*uz(k,i)
1513             enddo
1514 C Compute the derivatives of uz
1515             uzder(1,1,1)= 0.0d0
1516             uzder(2,1,1)=-dc_norm(3,i-1)
1517             uzder(3,1,1)= dc_norm(2,i-1)
1518             uzder(1,2,1)= dc_norm(3,i-1)
1519             uzder(2,2,1)= 0.0d0
1520             uzder(3,2,1)=-dc_norm(1,i-1)
1521             uzder(1,3,1)=-dc_norm(2,i-1)
1522             uzder(2,3,1)= dc_norm(1,i-1)
1523             uzder(3,3,1)= 0.0d0
1524             uzder(1,1,2)= 0.0d0
1525             uzder(2,1,2)= dc_norm(3,i)
1526             uzder(3,1,2)=-dc_norm(2,i)
1527             uzder(1,2,2)=-dc_norm(3,i)
1528             uzder(2,2,2)= 0.0d0
1529             uzder(3,2,2)= dc_norm(1,i)
1530             uzder(1,3,2)= dc_norm(2,i)
1531             uzder(2,3,2)=-dc_norm(1,i)
1532             uzder(3,3,2)= 0.0d0
1533 C Compute the Y-axis
1534             do k=1,3
1535               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1536             enddo
1537             facy=fac
1538             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1539      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1540      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1541             do k=1,3
1542 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1543               uy(k,i)=
1544 c     &        facy*(
1545      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1546      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1547 c     &        )
1548             enddo
1549 c            write (iout,*) 'facy',facy,
1550 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1551             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1552             do k=1,3
1553               uy(k,i)=facy*uy(k,i)
1554             enddo
1555 C Compute the derivatives of uy
1556             do j=1,3
1557               do k=1,3
1558                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1559      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1560                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1561               enddo
1562 c              uyder(j,j,1)=uyder(j,j,1)-costh
1563 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1564               uyder(j,j,1)=uyder(j,j,1)
1565      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1566               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1567      &          +uyder(j,j,2)
1568             enddo
1569             do j=1,2
1570               do k=1,3
1571                 do l=1,3
1572                   uygrad(l,k,j,i)=uyder(l,k,j)
1573                   uzgrad(l,k,j,i)=uzder(l,k,j)
1574                 enddo
1575               enddo
1576             enddo
1577             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1578             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1579             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1580             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1581           else
1582 C Other residues
1583 C Compute the Z-axis
1584             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1585             costh=dcos(pi-theta(i+2))
1586             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1587             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1588             do k=1,3
1589               uz(k,i)=fac*uz(k,i)
1590             enddo
1591 C Compute the derivatives of uz
1592             uzder(1,1,1)= 0.0d0
1593             uzder(2,1,1)=-dc_norm(3,i+1)
1594             uzder(3,1,1)= dc_norm(2,i+1)
1595             uzder(1,2,1)= dc_norm(3,i+1)
1596             uzder(2,2,1)= 0.0d0
1597             uzder(3,2,1)=-dc_norm(1,i+1)
1598             uzder(1,3,1)=-dc_norm(2,i+1)
1599             uzder(2,3,1)= dc_norm(1,i+1)
1600             uzder(3,3,1)= 0.0d0
1601             uzder(1,1,2)= 0.0d0
1602             uzder(2,1,2)= dc_norm(3,i)
1603             uzder(3,1,2)=-dc_norm(2,i)
1604             uzder(1,2,2)=-dc_norm(3,i)
1605             uzder(2,2,2)= 0.0d0
1606             uzder(3,2,2)= dc_norm(1,i)
1607             uzder(1,3,2)= dc_norm(2,i)
1608             uzder(2,3,2)=-dc_norm(1,i)
1609             uzder(3,3,2)= 0.0d0
1610 C Compute the Y-axis
1611             facy=fac
1612             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1613      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1614      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1615             do k=1,3
1616 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1617               uy(k,i)=
1618 c     &        facy*(
1619      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1620      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1621 c     &        )
1622             enddo
1623 c            write (iout,*) 'facy',facy,
1624 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1625             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1626             do k=1,3
1627               uy(k,i)=facy*uy(k,i)
1628             enddo
1629 C Compute the derivatives of uy
1630             do j=1,3
1631               do k=1,3
1632                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1633      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1634                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1635               enddo
1636 c              uyder(j,j,1)=uyder(j,j,1)-costh
1637 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1638               uyder(j,j,1)=uyder(j,j,1)
1639      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1640               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1641      &          +uyder(j,j,2)
1642             enddo
1643             do j=1,2
1644               do k=1,3
1645                 do l=1,3
1646                   uygrad(l,k,j,i)=uyder(l,k,j)
1647                   uzgrad(l,k,j,i)=uzder(l,k,j)
1648                 enddo
1649               enddo
1650             enddo
1651             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1652             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1653             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1654             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1655           endif
1656       enddo
1657       do i=1,nres-1
1658         do j=1,2
1659           do k=1,3
1660             do l=1,3
1661               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1662               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1663             enddo
1664           enddo
1665         enddo
1666       enddo
1667       return
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine check_vecgrad
1671       implicit real*8 (a-h,o-z)
1672       include 'DIMENSIONS'
1673       include 'DIMENSIONS.ZSCOPT'
1674       include 'COMMON.IOUNITS'
1675       include 'COMMON.GEO'
1676       include 'COMMON.VAR'
1677       include 'COMMON.LOCAL'
1678       include 'COMMON.CHAIN'
1679       include 'COMMON.VECTORS'
1680       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1681       dimension uyt(3,maxres),uzt(3,maxres)
1682       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1683       double precision delta /1.0d-7/
1684       call vec_and_deriv
1685 cd      do i=1,nres
1686 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1687 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1688 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1689 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1690 cd     &     (dc_norm(if90,i),if90=1,3)
1691 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1692 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1693 cd          write(iout,'(a)')
1694 cd      enddo
1695       do i=1,nres
1696         do j=1,2
1697           do k=1,3
1698             do l=1,3
1699               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1700               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1701             enddo
1702           enddo
1703         enddo
1704       enddo
1705       call vec_and_deriv
1706       do i=1,nres
1707         do j=1,3
1708           uyt(j,i)=uy(j,i)
1709           uzt(j,i)=uz(j,i)
1710         enddo
1711       enddo
1712       do i=1,nres
1713 cd        write (iout,*) 'i=',i
1714         do k=1,3
1715           erij(k)=dc_norm(k,i)
1716         enddo
1717         do j=1,3
1718           do k=1,3
1719             dc_norm(k,i)=erij(k)
1720           enddo
1721           dc_norm(j,i)=dc_norm(j,i)+delta
1722 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1723 c          do k=1,3
1724 c            dc_norm(k,i)=dc_norm(k,i)/fac
1725 c          enddo
1726 c          write (iout,*) (dc_norm(k,i),k=1,3)
1727 c          write (iout,*) (erij(k),k=1,3)
1728           call vec_and_deriv
1729           do k=1,3
1730             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1731             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1732             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1733             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1734           enddo
1735 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1736 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1737 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1738         enddo
1739         do k=1,3
1740           dc_norm(k,i)=erij(k)
1741         enddo
1742 cd        do k=1,3
1743 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1744 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1745 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1746 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1747 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1748 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1749 cd          write (iout,'(a)')
1750 cd        enddo
1751       enddo
1752       return
1753       end
1754 C--------------------------------------------------------------------------
1755       subroutine set_matrices
1756       implicit real*8 (a-h,o-z)
1757       include 'DIMENSIONS'
1758       include 'DIMENSIONS.ZSCOPT'
1759       include 'COMMON.IOUNITS'
1760       include 'COMMON.GEO'
1761       include 'COMMON.VAR'
1762       include 'COMMON.LOCAL'
1763       include 'COMMON.CHAIN'
1764       include 'COMMON.DERIV'
1765       include 'COMMON.INTERACT'
1766       include 'COMMON.CONTACTS'
1767       include 'COMMON.TORSION'
1768       include 'COMMON.VECTORS'
1769       include 'COMMON.FFIELD'
1770       double precision auxvec(2),auxmat(2,2)
1771 C
1772 C Compute the virtual-bond-torsional-angle dependent quantities needed
1773 C to calculate the el-loc multibody terms of various order.
1774 C
1775       do i=3,nres+1
1776         if (i .lt. nres+1) then
1777           sin1=dsin(phi(i))
1778           cos1=dcos(phi(i))
1779           sintab(i-2)=sin1
1780           costab(i-2)=cos1
1781           obrot(1,i-2)=cos1
1782           obrot(2,i-2)=sin1
1783           sin2=dsin(2*phi(i))
1784           cos2=dcos(2*phi(i))
1785           sintab2(i-2)=sin2
1786           costab2(i-2)=cos2
1787           obrot2(1,i-2)=cos2
1788           obrot2(2,i-2)=sin2
1789           Ug(1,1,i-2)=-cos1
1790           Ug(1,2,i-2)=-sin1
1791           Ug(2,1,i-2)=-sin1
1792           Ug(2,2,i-2)= cos1
1793           Ug2(1,1,i-2)=-cos2
1794           Ug2(1,2,i-2)=-sin2
1795           Ug2(2,1,i-2)=-sin2
1796           Ug2(2,2,i-2)= cos2
1797         else
1798           costab(i-2)=1.0d0
1799           sintab(i-2)=0.0d0
1800           obrot(1,i-2)=1.0d0
1801           obrot(2,i-2)=0.0d0
1802           obrot2(1,i-2)=0.0d0
1803           obrot2(2,i-2)=0.0d0
1804           Ug(1,1,i-2)=1.0d0
1805           Ug(1,2,i-2)=0.0d0
1806           Ug(2,1,i-2)=0.0d0
1807           Ug(2,2,i-2)=1.0d0
1808           Ug2(1,1,i-2)=0.0d0
1809           Ug2(1,2,i-2)=0.0d0
1810           Ug2(2,1,i-2)=0.0d0
1811           Ug2(2,2,i-2)=0.0d0
1812         endif
1813         if (i .gt. 3 .and. i .lt. nres+1) then
1814           obrot_der(1,i-2)=-sin1
1815           obrot_der(2,i-2)= cos1
1816           Ugder(1,1,i-2)= sin1
1817           Ugder(1,2,i-2)=-cos1
1818           Ugder(2,1,i-2)=-cos1
1819           Ugder(2,2,i-2)=-sin1
1820           dwacos2=cos2+cos2
1821           dwasin2=sin2+sin2
1822           obrot2_der(1,i-2)=-dwasin2
1823           obrot2_der(2,i-2)= dwacos2
1824           Ug2der(1,1,i-2)= dwasin2
1825           Ug2der(1,2,i-2)=-dwacos2
1826           Ug2der(2,1,i-2)=-dwacos2
1827           Ug2der(2,2,i-2)=-dwasin2
1828         else
1829           obrot_der(1,i-2)=0.0d0
1830           obrot_der(2,i-2)=0.0d0
1831           Ugder(1,1,i-2)=0.0d0
1832           Ugder(1,2,i-2)=0.0d0
1833           Ugder(2,1,i-2)=0.0d0
1834           Ugder(2,2,i-2)=0.0d0
1835           obrot2_der(1,i-2)=0.0d0
1836           obrot2_der(2,i-2)=0.0d0
1837           Ug2der(1,1,i-2)=0.0d0
1838           Ug2der(1,2,i-2)=0.0d0
1839           Ug2der(2,1,i-2)=0.0d0
1840           Ug2der(2,2,i-2)=0.0d0
1841         endif
1842         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1843           if (itype(i-2).le.ntyp) then
1844             iti = itortyp(itype(i-2))
1845           else
1846             iti=ntortyp+1
1847           endif
1848         else
1849           iti=ntortyp+1
1850         endif
1851         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1852           if (itype(i-1).le.ntyp) then
1853             iti1 = itortyp(itype(i-1))
1854           else
1855             iti1=ntortyp+1
1856           endif
1857         else
1858           iti1=ntortyp+1
1859         endif
1860 cd        write (iout,*) '*******i',i,' iti1',iti
1861 cd        write (iout,*) 'b1',b1(:,iti)
1862 cd        write (iout,*) 'b2',b2(:,iti)
1863 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1864 c        print *,"itilde1 i iti iti1",i,iti,iti1
1865         if (i .gt. iatel_s+2) then
1866           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1867           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1868           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1869           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1870           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1871           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1872           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1873         else
1874           do k=1,2
1875             Ub2(k,i-2)=0.0d0
1876             Ctobr(k,i-2)=0.0d0
1877             Dtobr2(k,i-2)=0.0d0
1878             do l=1,2
1879               EUg(l,k,i-2)=0.0d0
1880               CUg(l,k,i-2)=0.0d0
1881               DUg(l,k,i-2)=0.0d0
1882               DtUg2(l,k,i-2)=0.0d0
1883             enddo
1884           enddo
1885         endif
1886 c        print *,"itilde2 i iti iti1",i,iti,iti1
1887         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1888         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1889         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1890         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1891         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1892         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1893         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1894 c        print *,"itilde3 i iti iti1",i,iti,iti1
1895         do k=1,2
1896           muder(k,i-2)=Ub2der(k,i-2)
1897         enddo
1898         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1899           if (itype(i-1).le.ntyp) then
1900             iti1 = itortyp(itype(i-1))
1901           else
1902             iti1=ntortyp+1
1903           endif
1904         else
1905           iti1=ntortyp+1
1906         endif
1907         do k=1,2
1908           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1909         enddo
1910 C Vectors and matrices dependent on a single virtual-bond dihedral.
1911         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1912         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1913         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1914         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1915         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1916         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1917         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1918         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1919         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1920 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1921 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1922       enddo
1923 C Matrices dependent on two consecutive virtual-bond dihedrals.
1924 C The order of matrices is from left to right.
1925       do i=2,nres-1
1926         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1927         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1928         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1929         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1930         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1931         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1932         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1933         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1934       enddo
1935 cd      do i=1,nres
1936 cd        iti = itortyp(itype(i))
1937 cd        write (iout,*) i
1938 cd        do j=1,2
1939 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1940 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1941 cd        enddo
1942 cd      enddo
1943       return
1944       end
1945 C--------------------------------------------------------------------------
1946       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1947 C
1948 C This subroutine calculates the average interaction energy and its gradient
1949 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1950 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1951 C The potential depends both on the distance of peptide-group centers and on
1952 C the orientation of the CA-CA virtual bonds.
1953 C
1954       implicit real*8 (a-h,o-z)
1955       include 'DIMENSIONS'
1956       include 'DIMENSIONS.ZSCOPT'
1957       include 'DIMENSIONS.FREE'
1958       include 'COMMON.CONTROL'
1959       include 'COMMON.IOUNITS'
1960       include 'COMMON.GEO'
1961       include 'COMMON.VAR'
1962       include 'COMMON.LOCAL'
1963       include 'COMMON.CHAIN'
1964       include 'COMMON.DERIV'
1965       include 'COMMON.INTERACT'
1966       include 'COMMON.CONTACTS'
1967       include 'COMMON.TORSION'
1968       include 'COMMON.VECTORS'
1969       include 'COMMON.FFIELD'
1970       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1971      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1972       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1973      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1974       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1975 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1976       double precision scal_el /0.5d0/
1977 C 12/13/98
1978 C 13-go grudnia roku pamietnego...
1979       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1980      &                   0.0d0,1.0d0,0.0d0,
1981      &                   0.0d0,0.0d0,1.0d0/
1982 cd      write(iout,*) 'In EELEC'
1983 cd      do i=1,nloctyp
1984 cd        write(iout,*) 'Type',i
1985 cd        write(iout,*) 'B1',B1(:,i)
1986 cd        write(iout,*) 'B2',B2(:,i)
1987 cd        write(iout,*) 'CC',CC(:,:,i)
1988 cd        write(iout,*) 'DD',DD(:,:,i)
1989 cd        write(iout,*) 'EE',EE(:,:,i)
1990 cd      enddo
1991 cd      call check_vecgrad
1992 cd      stop
1993       if (icheckgrad.eq.1) then
1994         do i=1,nres-1
1995           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1996           do k=1,3
1997             dc_norm(k,i)=dc(k,i)*fac
1998           enddo
1999 c          write (iout,*) 'i',i,' fac',fac
2000         enddo
2001       endif
2002       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2003      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2004      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2005 cd      if (wel_loc.gt.0.0d0) then
2006         if (icheckgrad.eq.1) then
2007         call vec_and_deriv_test
2008         else
2009         call vec_and_deriv
2010         endif
2011         call set_matrices
2012       endif
2013 cd      do i=1,nres-1
2014 cd        write (iout,*) 'i=',i
2015 cd        do k=1,3
2016 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2017 cd        enddo
2018 cd        do k=1,3
2019 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2020 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2021 cd        enddo
2022 cd      enddo
2023       num_conti_hb=0
2024       ees=0.0D0
2025       evdw1=0.0D0
2026       eel_loc=0.0d0
2027       eello_turn3=0.0d0
2028       eello_turn4=0.0d0
2029       ind=0
2030       do i=1,nres
2031         num_cont_hb(i)=0
2032       enddo
2033 cd      print '(a)','Enter EELEC'
2034 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2035       do i=1,nres
2036         gel_loc_loc(i)=0.0d0
2037         gcorr_loc(i)=0.0d0
2038       enddo
2039       do i=iatel_s,iatel_e
2040 cAna           if (i.le.1) cycle
2041            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2042 cAna     &  .or. ((i+2).gt.nres)
2043 cAna     &  .or. ((i-1).le.0)
2044 cAna     &  .or. itype(i+2).eq.ntyp1
2045 cAna     &  .or. itype(i-1).eq.ntyp1
2046      &) cycle
2047 C         endif
2048         if (itel(i).eq.0) goto 1215
2049         dxi=dc(1,i)
2050         dyi=dc(2,i)
2051         dzi=dc(3,i)
2052         dx_normi=dc_norm(1,i)
2053         dy_normi=dc_norm(2,i)
2054         dz_normi=dc_norm(3,i)
2055         xmedi=c(1,i)+0.5d0*dxi
2056         ymedi=c(2,i)+0.5d0*dyi
2057         zmedi=c(3,i)+0.5d0*dzi
2058           xmedi=mod(xmedi,boxxsize)
2059           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2060           ymedi=mod(ymedi,boxysize)
2061           if (ymedi.lt.0) ymedi=ymedi+boxysize
2062           zmedi=mod(zmedi,boxzsize)
2063           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2064         num_conti=0
2065 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2066         do j=ielstart(i),ielend(i)
2067 cAna          if (j.le.1) cycle
2068           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2069 cAna     & .or.((j+2).gt.nres)
2070 cAna     & .or.((j-1).le.0)
2071 cAna     & .or.itype(j+2).eq.ntyp1
2072 cAna     & .or.itype(j-1).eq.ntyp1
2073      &) cycle
2074           if (itel(j).eq.0) goto 1216
2075           ind=ind+1
2076           iteli=itel(i)
2077           itelj=itel(j)
2078           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2079           aaa=app(iteli,itelj)
2080           bbb=bpp(iteli,itelj)
2081 C Diagnostics only!!!
2082 c         aaa=0.0D0
2083 c         bbb=0.0D0
2084 c         ael6i=0.0D0
2085 c         ael3i=0.0D0
2086 C End diagnostics
2087           ael6i=ael6(iteli,itelj)
2088           ael3i=ael3(iteli,itelj)
2089           dxj=dc(1,j)
2090           dyj=dc(2,j)
2091           dzj=dc(3,j)
2092           dx_normj=dc_norm(1,j)
2093           dy_normj=dc_norm(2,j)
2094           dz_normj=dc_norm(3,j)
2095           xj=c(1,j)+0.5D0*dxj
2096           yj=c(2,j)+0.5D0*dyj
2097           zj=c(3,j)+0.5D0*dzj
2098          xj=mod(xj,boxxsize)
2099           if (xj.lt.0) xj=xj+boxxsize
2100           yj=mod(yj,boxysize)
2101           if (yj.lt.0) yj=yj+boxysize
2102           zj=mod(zj,boxzsize)
2103           if (zj.lt.0) zj=zj+boxzsize
2104       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2105       xj_safe=xj
2106       yj_safe=yj
2107       zj_safe=zj
2108       isubchap=0
2109       do xshift=-1,1
2110       do yshift=-1,1
2111       do zshift=-1,1
2112           xj=xj_safe+xshift*boxxsize
2113           yj=yj_safe+yshift*boxysize
2114           zj=zj_safe+zshift*boxzsize
2115           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2116           if(dist_temp.lt.dist_init) then
2117             dist_init=dist_temp
2118             xj_temp=xj
2119             yj_temp=yj
2120             zj_temp=zj
2121             isubchap=1
2122           endif
2123        enddo
2124        enddo
2125        enddo
2126        if (isubchap.eq.1) then
2127           xj=xj_temp-xmedi
2128           yj=yj_temp-ymedi
2129           zj=zj_temp-zmedi
2130        else
2131           xj=xj_safe-xmedi
2132           yj=yj_safe-ymedi
2133           zj=zj_safe-zmedi
2134        endif
2135           rij=xj*xj+yj*yj+zj*zj
2136             sss=sscale(sqrt(rij))
2137             sssgrad=sscagrad(sqrt(rij))
2138           rrmij=1.0D0/rij
2139           rij=dsqrt(rij)
2140           rmij=1.0D0/rij
2141           r3ij=rrmij*rmij
2142           r6ij=r3ij*r3ij
2143           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2144           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2145           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2146           fac=cosa-3.0D0*cosb*cosg
2147           ev1=aaa*r6ij*r6ij
2148 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2149           if (j.eq.i+2) ev1=scal_el*ev1
2150           ev2=bbb*r6ij
2151           fac3=ael6i*r6ij
2152           fac4=ael3i*r3ij
2153           evdwij=ev1+ev2
2154           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2155           el2=fac4*fac
2156           eesij=el1+el2
2157 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2158 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2159           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2160           ees=ees+eesij
2161           evdw1=evdw1+evdwij*sss
2162 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2163 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2164 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2165 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2166 C
2167 C Calculate contributions to the Cartesian gradient.
2168 C
2169 #ifdef SPLITELE
2170           facvdw=-6*rrmij*(ev1+evdwij)*sss
2171           facel=-3*rrmij*(el1+eesij)
2172           fac1=fac
2173           erij(1)=xj*rmij
2174           erij(2)=yj*rmij
2175           erij(3)=zj*rmij
2176           if (calc_grad) then
2177 *
2178 * Radial derivatives. First process both termini of the fragment (i,j)
2179 *
2180           ggg(1)=facel*xj
2181           ggg(2)=facel*yj
2182           ggg(3)=facel*zj
2183           do k=1,3
2184             ghalf=0.5D0*ggg(k)
2185             gelc(k,i)=gelc(k,i)+ghalf
2186             gelc(k,j)=gelc(k,j)+ghalf
2187           enddo
2188 *
2189 * Loop over residues i+1 thru j-1.
2190 *
2191           do k=i+1,j-1
2192             do l=1,3
2193               gelc(l,k)=gelc(l,k)+ggg(l)
2194             enddo
2195           enddo
2196           ggg(1)=facvdw*xj
2197           ggg(2)=facvdw*yj
2198           ggg(3)=facvdw*zj
2199           do k=1,3
2200             ghalf=0.5D0*ggg(k)
2201             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2202             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2203           enddo
2204 *
2205 * Loop over residues i+1 thru j-1.
2206 *
2207           do k=i+1,j-1
2208             do l=1,3
2209               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2210             enddo
2211           enddo
2212 #else
2213           facvdw=ev1+evdwij
2214           facel=el1+eesij
2215           fac1=fac
2216           fac=-3*rrmij*(facvdw+facvdw+facel)
2217           erij(1)=xj*rmij
2218           erij(2)=yj*rmij
2219           erij(3)=zj*rmij
2220           if (calc_grad) then
2221 *
2222 * Radial derivatives. First process both termini of the fragment (i,j)
2223 *
2224           ggg(1)=fac*xj
2225           ggg(2)=fac*yj
2226           ggg(3)=fac*zj
2227           do k=1,3
2228             ghalf=0.5D0*ggg(k)
2229             gelc(k,i)=gelc(k,i)+ghalf
2230             gelc(k,j)=gelc(k,j)+ghalf
2231           enddo
2232 *
2233 * Loop over residues i+1 thru j-1.
2234 *
2235           do k=i+1,j-1
2236             do l=1,3
2237               gelc(l,k)=gelc(l,k)+ggg(l)
2238             enddo
2239           enddo
2240 #endif
2241 *
2242 * Angular part
2243 *
2244           ecosa=2.0D0*fac3*fac1+fac4
2245           fac4=-3.0D0*fac4
2246           fac3=-6.0D0*fac3
2247           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2248           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2249           do k=1,3
2250             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2251             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2252           enddo
2253 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2254 cd   &          (dcosg(k),k=1,3)
2255           do k=1,3
2256             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2257           enddo
2258           do k=1,3
2259             ghalf=0.5D0*ggg(k)
2260             gelc(k,i)=gelc(k,i)+ghalf
2261      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2262      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2263             gelc(k,j)=gelc(k,j)+ghalf
2264      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2265      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2266           enddo
2267           do k=i+1,j-1
2268             do l=1,3
2269               gelc(l,k)=gelc(l,k)+ggg(l)
2270             enddo
2271           enddo
2272           endif
2273
2274           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2275      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2276      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2277 C
2278 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2279 C   energy of a peptide unit is assumed in the form of a second-order
2280 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2281 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2282 C   are computed for EVERY pair of non-contiguous peptide groups.
2283 C
2284           if (j.lt.nres-1) then
2285             j1=j+1
2286             j2=j-1
2287           else
2288             j1=j-1
2289             j2=j-2
2290           endif
2291           kkk=0
2292           do k=1,2
2293             do l=1,2
2294               kkk=kkk+1
2295               muij(kkk)=mu(k,i)*mu(l,j)
2296             enddo
2297           enddo
2298 cd         write (iout,*) 'EELEC: i',i,' j',j
2299 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2300 cd          write(iout,*) 'muij',muij
2301           ury=scalar(uy(1,i),erij)
2302           urz=scalar(uz(1,i),erij)
2303           vry=scalar(uy(1,j),erij)
2304           vrz=scalar(uz(1,j),erij)
2305           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2306           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2307           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2308           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2309 C For diagnostics only
2310 cd          a22=1.0d0
2311 cd          a23=1.0d0
2312 cd          a32=1.0d0
2313 cd          a33=1.0d0
2314           fac=dsqrt(-ael6i)*r3ij
2315 cd          write (2,*) 'fac=',fac
2316 C For diagnostics only
2317 cd          fac=1.0d0
2318           a22=a22*fac
2319           a23=a23*fac
2320           a32=a32*fac
2321           a33=a33*fac
2322 cd          write (iout,'(4i5,4f10.5)')
2323 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2324 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2325 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2326 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2327 cd          write (iout,'(4f10.5)')
2328 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2329 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2330 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2331 cd           write (iout,'(2i3,9f10.5/)') i,j,
2332 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2333           if (calc_grad) then
2334 C Derivatives of the elements of A in virtual-bond vectors
2335           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2336 cd          do k=1,3
2337 cd            do l=1,3
2338 cd              erder(k,l)=0.0d0
2339 cd            enddo
2340 cd          enddo
2341           do k=1,3
2342             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2343             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2344             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2345             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2346             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2347             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2348             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2349             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2350             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2351             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2352             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2353             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2354           enddo
2355 cd          do k=1,3
2356 cd            do l=1,3
2357 cd              uryg(k,l)=0.0d0
2358 cd              urzg(k,l)=0.0d0
2359 cd              vryg(k,l)=0.0d0
2360 cd              vrzg(k,l)=0.0d0
2361 cd            enddo
2362 cd          enddo
2363 C Compute radial contributions to the gradient
2364           facr=-3.0d0*rrmij
2365           a22der=a22*facr
2366           a23der=a23*facr
2367           a32der=a32*facr
2368           a33der=a33*facr
2369 cd          a22der=0.0d0
2370 cd          a23der=0.0d0
2371 cd          a32der=0.0d0
2372 cd          a33der=0.0d0
2373           agg(1,1)=a22der*xj
2374           agg(2,1)=a22der*yj
2375           agg(3,1)=a22der*zj
2376           agg(1,2)=a23der*xj
2377           agg(2,2)=a23der*yj
2378           agg(3,2)=a23der*zj
2379           agg(1,3)=a32der*xj
2380           agg(2,3)=a32der*yj
2381           agg(3,3)=a32der*zj
2382           agg(1,4)=a33der*xj
2383           agg(2,4)=a33der*yj
2384           agg(3,4)=a33der*zj
2385 C Add the contributions coming from er
2386           fac3=-3.0d0*fac
2387           do k=1,3
2388             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2389             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2390             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2391             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2392           enddo
2393           do k=1,3
2394 C Derivatives in DC(i)
2395             ghalf1=0.5d0*agg(k,1)
2396             ghalf2=0.5d0*agg(k,2)
2397             ghalf3=0.5d0*agg(k,3)
2398             ghalf4=0.5d0*agg(k,4)
2399             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2400      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2401             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2402      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2403             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2404      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2405             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2406      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2407 C Derivatives in DC(i+1)
2408             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2409      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2410             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2411      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2412             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2413      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2414             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2415      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2416 C Derivatives in DC(j)
2417             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2418      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2419             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2420      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2421             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2422      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2423             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2424      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2425 C Derivatives in DC(j+1) or DC(nres-1)
2426             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2427      &      -3.0d0*vryg(k,3)*ury)
2428             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2429      &      -3.0d0*vrzg(k,3)*ury)
2430             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2431      &      -3.0d0*vryg(k,3)*urz)
2432             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2433      &      -3.0d0*vrzg(k,3)*urz)
2434 cd            aggi(k,1)=ghalf1
2435 cd            aggi(k,2)=ghalf2
2436 cd            aggi(k,3)=ghalf3
2437 cd            aggi(k,4)=ghalf4
2438 C Derivatives in DC(i+1)
2439 cd            aggi1(k,1)=agg(k,1)
2440 cd            aggi1(k,2)=agg(k,2)
2441 cd            aggi1(k,3)=agg(k,3)
2442 cd            aggi1(k,4)=agg(k,4)
2443 C Derivatives in DC(j)
2444 cd            aggj(k,1)=ghalf1
2445 cd            aggj(k,2)=ghalf2
2446 cd            aggj(k,3)=ghalf3
2447 cd            aggj(k,4)=ghalf4
2448 C Derivatives in DC(j+1)
2449 cd            aggj1(k,1)=0.0d0
2450 cd            aggj1(k,2)=0.0d0
2451 cd            aggj1(k,3)=0.0d0
2452 cd            aggj1(k,4)=0.0d0
2453             if (j.eq.nres-1 .and. i.lt.j-2) then
2454               do l=1,4
2455                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2456 cd                aggj1(k,l)=agg(k,l)
2457               enddo
2458             endif
2459           enddo
2460           endif
2461 c          goto 11111
2462 C Check the loc-el terms by numerical integration
2463           acipa(1,1)=a22
2464           acipa(1,2)=a23
2465           acipa(2,1)=a32
2466           acipa(2,2)=a33
2467           a22=-a22
2468           a23=-a23
2469           do l=1,2
2470             do k=1,3
2471               agg(k,l)=-agg(k,l)
2472               aggi(k,l)=-aggi(k,l)
2473               aggi1(k,l)=-aggi1(k,l)
2474               aggj(k,l)=-aggj(k,l)
2475               aggj1(k,l)=-aggj1(k,l)
2476             enddo
2477           enddo
2478           if (j.lt.nres-1) then
2479             a22=-a22
2480             a32=-a32
2481             do l=1,3,2
2482               do k=1,3
2483                 agg(k,l)=-agg(k,l)
2484                 aggi(k,l)=-aggi(k,l)
2485                 aggi1(k,l)=-aggi1(k,l)
2486                 aggj(k,l)=-aggj(k,l)
2487                 aggj1(k,l)=-aggj1(k,l)
2488               enddo
2489             enddo
2490           else
2491             a22=-a22
2492             a23=-a23
2493             a32=-a32
2494             a33=-a33
2495             do l=1,4
2496               do k=1,3
2497                 agg(k,l)=-agg(k,l)
2498                 aggi(k,l)=-aggi(k,l)
2499                 aggi1(k,l)=-aggi1(k,l)
2500                 aggj(k,l)=-aggj(k,l)
2501                 aggj1(k,l)=-aggj1(k,l)
2502               enddo
2503             enddo
2504           endif
2505           ENDIF ! WCORR
2506 11111     continue
2507           IF (wel_loc.gt.0.0d0) THEN
2508 C Contribution to the local-electrostatic energy coming from the i-j pair
2509           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2510      &     +a33*muij(4)
2511 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2512 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2513           eel_loc=eel_loc+eel_loc_ij
2514 C Partial derivatives in virtual-bond dihedral angles gamma
2515           if (calc_grad) then
2516           if (i.gt.1)
2517      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2518      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2519      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2520           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2521      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2522      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2523 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2524 cd          write(iout,*) 'agg  ',agg
2525 cd          write(iout,*) 'aggi ',aggi
2526 cd          write(iout,*) 'aggi1',aggi1
2527 cd          write(iout,*) 'aggj ',aggj
2528 cd          write(iout,*) 'aggj1',aggj1
2529
2530 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2531           do l=1,3
2532             ggg(l)=agg(l,1)*muij(1)+
2533      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2534           enddo
2535           do k=i+2,j2
2536             do l=1,3
2537               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2538             enddo
2539           enddo
2540 C Remaining derivatives of eello
2541           do l=1,3
2542             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2543      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2544             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2545      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2546             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2547      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2548             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2549      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2550           enddo
2551           endif
2552           ENDIF
2553           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2554 C Contributions from turns
2555             a_temp(1,1)=a22
2556             a_temp(1,2)=a23
2557             a_temp(2,1)=a32
2558             a_temp(2,2)=a33
2559             call eturn34(i,j,eello_turn3,eello_turn4)
2560           endif
2561 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2562           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2563 C
2564 C Calculate the contact function. The ith column of the array JCONT will
2565 C contain the numbers of atoms that make contacts with the atom I (of numbers
2566 C greater than I). The arrays FACONT and GACONT will contain the values of
2567 C the contact function and its derivative.
2568 c           r0ij=1.02D0*rpp(iteli,itelj)
2569 c           r0ij=1.11D0*rpp(iteli,itelj)
2570             r0ij=2.20D0*rpp(iteli,itelj)
2571 c           r0ij=1.55D0*rpp(iteli,itelj)
2572             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2573             if (fcont.gt.0.0D0) then
2574               num_conti=num_conti+1
2575               if (num_conti.gt.maxconts) then
2576                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2577      &                         ' will skip next contacts for this conf.'
2578               else
2579                 jcont_hb(num_conti,i)=j
2580                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2581      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2582 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2583 C  terms.
2584                 d_cont(num_conti,i)=rij
2585 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2586 C     --- Electrostatic-interaction matrix ---
2587                 a_chuj(1,1,num_conti,i)=a22
2588                 a_chuj(1,2,num_conti,i)=a23
2589                 a_chuj(2,1,num_conti,i)=a32
2590                 a_chuj(2,2,num_conti,i)=a33
2591 C     --- Gradient of rij
2592                 do kkk=1,3
2593                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2594                 enddo
2595 c             if (i.eq.1) then
2596 c                a_chuj(1,1,num_conti,i)=-0.61d0
2597 c                a_chuj(1,2,num_conti,i)= 0.4d0
2598 c                a_chuj(2,1,num_conti,i)= 0.65d0
2599 c                a_chuj(2,2,num_conti,i)= 0.50d0
2600 c             else if (i.eq.2) then
2601 c                a_chuj(1,1,num_conti,i)= 0.0d0
2602 c                a_chuj(1,2,num_conti,i)= 0.0d0
2603 c                a_chuj(2,1,num_conti,i)= 0.0d0
2604 c                a_chuj(2,2,num_conti,i)= 0.0d0
2605 c             endif
2606 C     --- and its gradients
2607 cd                write (iout,*) 'i',i,' j',j
2608 cd                do kkk=1,3
2609 cd                write (iout,*) 'iii 1 kkk',kkk
2610 cd                write (iout,*) agg(kkk,:)
2611 cd                enddo
2612 cd                do kkk=1,3
2613 cd                write (iout,*) 'iii 2 kkk',kkk
2614 cd                write (iout,*) aggi(kkk,:)
2615 cd                enddo
2616 cd                do kkk=1,3
2617 cd                write (iout,*) 'iii 3 kkk',kkk
2618 cd                write (iout,*) aggi1(kkk,:)
2619 cd                enddo
2620 cd                do kkk=1,3
2621 cd                write (iout,*) 'iii 4 kkk',kkk
2622 cd                write (iout,*) aggj(kkk,:)
2623 cd                enddo
2624 cd                do kkk=1,3
2625 cd                write (iout,*) 'iii 5 kkk',kkk
2626 cd                write (iout,*) aggj1(kkk,:)
2627 cd                enddo
2628                 kkll=0
2629                 do k=1,2
2630                   do l=1,2
2631                     kkll=kkll+1
2632                     do m=1,3
2633                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2634                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2635                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2636                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2637                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2638 c                      do mm=1,5
2639 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2640 c                      enddo
2641                     enddo
2642                   enddo
2643                 enddo
2644                 ENDIF
2645                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2646 C Calculate contact energies
2647                 cosa4=4.0D0*cosa
2648                 wij=cosa-3.0D0*cosb*cosg
2649                 cosbg1=cosb+cosg
2650                 cosbg2=cosb-cosg
2651 c               fac3=dsqrt(-ael6i)/r0ij**3
2652                 fac3=dsqrt(-ael6i)*r3ij
2653                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2654                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2655 c               ees0mij=0.0D0
2656                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2657                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2658 C Diagnostics. Comment out or remove after debugging!
2659 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2660 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2661 c               ees0m(num_conti,i)=0.0D0
2662 C End diagnostics.
2663 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2664 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2665                 facont_hb(num_conti,i)=fcont
2666                 if (calc_grad) then
2667 C Angular derivatives of the contact function
2668                 ees0pij1=fac3/ees0pij
2669                 ees0mij1=fac3/ees0mij
2670                 fac3p=-3.0D0*fac3*rrmij
2671                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2672                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2673 c               ees0mij1=0.0D0
2674                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2675                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2676                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2677                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2678                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2679                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2680                 ecosap=ecosa1+ecosa2
2681                 ecosbp=ecosb1+ecosb2
2682                 ecosgp=ecosg1+ecosg2
2683                 ecosam=ecosa1-ecosa2
2684                 ecosbm=ecosb1-ecosb2
2685                 ecosgm=ecosg1-ecosg2
2686 C Diagnostics
2687 c               ecosap=ecosa1
2688 c               ecosbp=ecosb1
2689 c               ecosgp=ecosg1
2690 c               ecosam=0.0D0
2691 c               ecosbm=0.0D0
2692 c               ecosgm=0.0D0
2693 C End diagnostics
2694                 fprimcont=fprimcont/rij
2695 cd              facont_hb(num_conti,i)=1.0D0
2696 C Following line is for diagnostics.
2697 cd              fprimcont=0.0D0
2698                 do k=1,3
2699                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2700                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2701                 enddo
2702                 do k=1,3
2703                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2704                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2705                 enddo
2706                 gggp(1)=gggp(1)+ees0pijp*xj
2707                 gggp(2)=gggp(2)+ees0pijp*yj
2708                 gggp(3)=gggp(3)+ees0pijp*zj
2709                 gggm(1)=gggm(1)+ees0mijp*xj
2710                 gggm(2)=gggm(2)+ees0mijp*yj
2711                 gggm(3)=gggm(3)+ees0mijp*zj
2712 C Derivatives due to the contact function
2713                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2714                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2715                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2716                 do k=1,3
2717                   ghalfp=0.5D0*gggp(k)
2718                   ghalfm=0.5D0*gggm(k)
2719                   gacontp_hb1(k,num_conti,i)=ghalfp
2720      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2721      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2722                   gacontp_hb2(k,num_conti,i)=ghalfp
2723      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2724      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2725                   gacontp_hb3(k,num_conti,i)=gggp(k)
2726                   gacontm_hb1(k,num_conti,i)=ghalfm
2727      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2728      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2729                   gacontm_hb2(k,num_conti,i)=ghalfm
2730      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2731      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2732                   gacontm_hb3(k,num_conti,i)=gggm(k)
2733                 enddo
2734                 endif
2735 C Diagnostics. Comment out or remove after debugging!
2736 cdiag           do k=1,3
2737 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2738 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2739 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2740 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2741 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2742 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2743 cdiag           enddo
2744               ENDIF ! wcorr
2745               endif  ! num_conti.le.maxconts
2746             endif  ! fcont.gt.0
2747           endif    ! j.gt.i+1
2748  1216     continue
2749         enddo ! j
2750         num_cont_hb(i)=num_conti
2751  1215   continue
2752       enddo   ! i
2753 cd      do i=1,nres
2754 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2755 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2756 cd      enddo
2757 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2758 ccc      eel_loc=eel_loc+eello_turn3
2759       return
2760       end
2761 C-----------------------------------------------------------------------------
2762       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2763 C Third- and fourth-order contributions from turns
2764       implicit real*8 (a-h,o-z)
2765       include 'DIMENSIONS'
2766       include 'DIMENSIONS.ZSCOPT'
2767       include 'COMMON.IOUNITS'
2768       include 'COMMON.GEO'
2769       include 'COMMON.VAR'
2770       include 'COMMON.LOCAL'
2771       include 'COMMON.CHAIN'
2772       include 'COMMON.DERIV'
2773       include 'COMMON.INTERACT'
2774       include 'COMMON.CONTACTS'
2775       include 'COMMON.TORSION'
2776       include 'COMMON.VECTORS'
2777       include 'COMMON.FFIELD'
2778       dimension ggg(3)
2779       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2780      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2781      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2782       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2783      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2784       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2785       if (j.eq.i+2) then
2786       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2787 C changes suggested by Ana to avoid out of bounds
2788 C     & .or.((i+5).gt.nres)
2789 C     & .or.((i-1).le.0)
2790 C end of changes suggested by Ana
2791      &    .or. itype(i+2).eq.ntyp1
2792      &    .or. itype(i+3).eq.ntyp1
2793 C     &    .or. itype(i+5).eq.ntyp1
2794 C     &    .or. itype(i).eq.ntyp1
2795 C     &    .or. itype(i-1).eq.ntyp1
2796      &    ) goto 179
2797
2798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2799 C
2800 C               Third-order contributions
2801 C
2802 C                 (i+2)o----(i+3)
2803 C                      | |
2804 C                      | |
2805 C                 (i+1)o----i
2806 C
2807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2808 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2809         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2810         call transpose2(auxmat(1,1),auxmat1(1,1))
2811         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2812         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2813 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2814 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2815 cd     &    ' eello_turn3_num',4*eello_turn3_num
2816         if (calc_grad) then
2817 C Derivatives in gamma(i)
2818         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2819         call transpose2(auxmat2(1,1),pizda(1,1))
2820         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2821         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2822 C Derivatives in gamma(i+1)
2823         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2824         call transpose2(auxmat2(1,1),pizda(1,1))
2825         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2826         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2827      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2828 C Cartesian derivatives
2829         do l=1,3
2830           a_temp(1,1)=aggi(l,1)
2831           a_temp(1,2)=aggi(l,2)
2832           a_temp(2,1)=aggi(l,3)
2833           a_temp(2,2)=aggi(l,4)
2834           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2835           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2836      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2837           a_temp(1,1)=aggi1(l,1)
2838           a_temp(1,2)=aggi1(l,2)
2839           a_temp(2,1)=aggi1(l,3)
2840           a_temp(2,2)=aggi1(l,4)
2841           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2842           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2843      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2844           a_temp(1,1)=aggj(l,1)
2845           a_temp(1,2)=aggj(l,2)
2846           a_temp(2,1)=aggj(l,3)
2847           a_temp(2,2)=aggj(l,4)
2848           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2849           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2850      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2851           a_temp(1,1)=aggj1(l,1)
2852           a_temp(1,2)=aggj1(l,2)
2853           a_temp(2,1)=aggj1(l,3)
2854           a_temp(2,2)=aggj1(l,4)
2855           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2856           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2857      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2858         enddo
2859         endif
2860   179 continue
2861       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2862       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2863 C changes suggested by Ana to avoid out of bounds
2864 C     & .or.((i+5).gt.nres)
2865 C     & .or.((i-1).le.0)
2866 C end of changes suggested by Ana
2867      &    .or. itype(i+3).eq.ntyp1
2868      &    .or. itype(i+4).eq.ntyp1
2869 C     &    .or. itype(i+5).eq.ntyp1
2870      &    .or. itype(i).eq.ntyp1
2871 C     &    .or. itype(i-1).eq.ntyp1
2872      &    ) goto 178
2873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2874 C
2875 C               Fourth-order contributions
2876 C
2877 C                 (i+3)o----(i+4)
2878 C                     /  |
2879 C               (i+2)o   |
2880 C                     \  |
2881 C                 (i+1)o----i
2882 C
2883 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2884 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2885         iti1=itortyp(itype(i+1))
2886         iti2=itortyp(itype(i+2))
2887         iti3=itortyp(itype(i+3))
2888         call transpose2(EUg(1,1,i+1),e1t(1,1))
2889         call transpose2(Eug(1,1,i+2),e2t(1,1))
2890         call transpose2(Eug(1,1,i+3),e3t(1,1))
2891         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2892         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2893         s1=scalar2(b1(1,iti2),auxvec(1))
2894         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2895         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2896         s2=scalar2(b1(1,iti1),auxvec(1))
2897         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2898         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2900         eello_turn4=eello_turn4-(s1+s2+s3)
2901 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2902 cd     &    ' eello_turn4_num',8*eello_turn4_num
2903 C Derivatives in gamma(i)
2904         if (calc_grad) then
2905         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2906         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2907         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2908         s1=scalar2(b1(1,iti2),auxvec(1))
2909         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2911         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2912 C Derivatives in gamma(i+1)
2913         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2914         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2915         s2=scalar2(b1(1,iti1),auxvec(1))
2916         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2917         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2919         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2920 C Derivatives in gamma(i+2)
2921         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2922         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2923         s1=scalar2(b1(1,iti2),auxvec(1))
2924         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2925         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2926         s2=scalar2(b1(1,iti1),auxvec(1))
2927         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2928         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2929         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2930         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2931 C Cartesian derivatives
2932 C Derivatives of this turn contributions in DC(i+2)
2933         if (j.lt.nres-1) then
2934           do l=1,3
2935             a_temp(1,1)=agg(l,1)
2936             a_temp(1,2)=agg(l,2)
2937             a_temp(2,1)=agg(l,3)
2938             a_temp(2,2)=agg(l,4)
2939             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2940             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2941             s1=scalar2(b1(1,iti2),auxvec(1))
2942             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2943             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2944             s2=scalar2(b1(1,iti1),auxvec(1))
2945             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2946             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2947             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2948             ggg(l)=-(s1+s2+s3)
2949             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2950           enddo
2951         endif
2952 C Remaining derivatives of this turn contribution
2953         do l=1,3
2954           a_temp(1,1)=aggi(l,1)
2955           a_temp(1,2)=aggi(l,2)
2956           a_temp(2,1)=aggi(l,3)
2957           a_temp(2,2)=aggi(l,4)
2958           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2959           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2960           s1=scalar2(b1(1,iti2),auxvec(1))
2961           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2962           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2963           s2=scalar2(b1(1,iti1),auxvec(1))
2964           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2965           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2966           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2967           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2968           a_temp(1,1)=aggi1(l,1)
2969           a_temp(1,2)=aggi1(l,2)
2970           a_temp(2,1)=aggi1(l,3)
2971           a_temp(2,2)=aggi1(l,4)
2972           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2973           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2974           s1=scalar2(b1(1,iti2),auxvec(1))
2975           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2976           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2977           s2=scalar2(b1(1,iti1),auxvec(1))
2978           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2979           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2980           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2981           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2982           a_temp(1,1)=aggj(l,1)
2983           a_temp(1,2)=aggj(l,2)
2984           a_temp(2,1)=aggj(l,3)
2985           a_temp(2,2)=aggj(l,4)
2986           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2987           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2988           s1=scalar2(b1(1,iti2),auxvec(1))
2989           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2990           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2991           s2=scalar2(b1(1,iti1),auxvec(1))
2992           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2993           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2994           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2995           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2996           a_temp(1,1)=aggj1(l,1)
2997           a_temp(1,2)=aggj1(l,2)
2998           a_temp(2,1)=aggj1(l,3)
2999           a_temp(2,2)=aggj1(l,4)
3000           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3001           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3002           s1=scalar2(b1(1,iti2),auxvec(1))
3003           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3004           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3005           s2=scalar2(b1(1,iti1),auxvec(1))
3006           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3007           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3008           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3009           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3010         enddo
3011         endif
3012  178  continue
3013       endif
3014       return
3015       end
3016 C-----------------------------------------------------------------------------
3017       subroutine vecpr(u,v,w)
3018       implicit real*8(a-h,o-z)
3019       dimension u(3),v(3),w(3)
3020       w(1)=u(2)*v(3)-u(3)*v(2)
3021       w(2)=-u(1)*v(3)+u(3)*v(1)
3022       w(3)=u(1)*v(2)-u(2)*v(1)
3023       return
3024       end
3025 C-----------------------------------------------------------------------------
3026       subroutine unormderiv(u,ugrad,unorm,ungrad)
3027 C This subroutine computes the derivatives of a normalized vector u, given
3028 C the derivatives computed without normalization conditions, ugrad. Returns
3029 C ungrad.
3030       implicit none
3031       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3032       double precision vec(3)
3033       double precision scalar
3034       integer i,j
3035 c      write (2,*) 'ugrad',ugrad
3036 c      write (2,*) 'u',u
3037       do i=1,3
3038         vec(i)=scalar(ugrad(1,i),u(1))
3039       enddo
3040 c      write (2,*) 'vec',vec
3041       do i=1,3
3042         do j=1,3
3043           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3044         enddo
3045       enddo
3046 c      write (2,*) 'ungrad',ungrad
3047       return
3048       end
3049 C-----------------------------------------------------------------------------
3050       subroutine escp(evdw2,evdw2_14)
3051 C
3052 C This subroutine calculates the excluded-volume interaction energy between
3053 C peptide-group centers and side chains and its gradient in virtual-bond and
3054 C side-chain vectors.
3055 C
3056       implicit real*8 (a-h,o-z)
3057       include 'DIMENSIONS'
3058       include 'DIMENSIONS.ZSCOPT'
3059       include 'COMMON.GEO'
3060       include 'COMMON.VAR'
3061       include 'COMMON.LOCAL'
3062       include 'COMMON.CHAIN'
3063       include 'COMMON.DERIV'
3064       include 'COMMON.INTERACT'
3065       include 'COMMON.FFIELD'
3066       include 'COMMON.IOUNITS'
3067       dimension ggg(3)
3068       evdw2=0.0D0
3069       evdw2_14=0.0d0
3070 cd    print '(a)','Enter ESCP'
3071 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3072 c     &  ' scal14',scal14
3073       do i=iatscp_s,iatscp_e
3074         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3075         iteli=itel(i)
3076 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3077 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3078         if (iteli.eq.0) goto 1225
3079         xi=0.5D0*(c(1,i)+c(1,i+1))
3080         yi=0.5D0*(c(2,i)+c(2,i+1))
3081         zi=0.5D0*(c(3,i)+c(3,i+1))
3082 C Returning the ith atom to box
3083           xi=mod(xi,boxxsize)
3084           if (xi.lt.0) xi=xi+boxxsize
3085           yi=mod(yi,boxysize)
3086           if (yi.lt.0) yi=yi+boxysize
3087           zi=mod(zi,boxzsize)
3088           if (zi.lt.0) zi=zi+boxzsize
3089         do iint=1,nscp_gr(i)
3090
3091         do j=iscpstart(i,iint),iscpend(i,iint)
3092           itypj=iabs(itype(j))
3093           if (itypj.eq.ntyp1) cycle
3094 C Uncomment following three lines for SC-p interactions
3095 c         xj=c(1,nres+j)-xi
3096 c         yj=c(2,nres+j)-yi
3097 c         zj=c(3,nres+j)-zi
3098 C Uncomment following three lines for Ca-p interactions
3099           xj=c(1,j)
3100           yj=c(2,j)
3101           zj=c(3,j)
3102 C returning the jth atom to box
3103           xj=mod(xj,boxxsize)
3104           if (xj.lt.0) xj=xj+boxxsize
3105           yj=mod(yj,boxysize)
3106           if (yj.lt.0) yj=yj+boxysize
3107           zj=mod(zj,boxzsize)
3108           if (zj.lt.0) zj=zj+boxzsize
3109       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3110       xj_safe=xj
3111       yj_safe=yj
3112       zj_safe=zj
3113       subchap=0
3114 C Finding the closest jth atom
3115       do xshift=-1,1
3116       do yshift=-1,1
3117       do zshift=-1,1
3118           xj=xj_safe+xshift*boxxsize
3119           yj=yj_safe+yshift*boxysize
3120           zj=zj_safe+zshift*boxzsize
3121           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3122           if(dist_temp.lt.dist_init) then
3123             dist_init=dist_temp
3124             xj_temp=xj
3125             yj_temp=yj
3126             zj_temp=zj
3127             subchap=1
3128           endif
3129        enddo
3130        enddo
3131        enddo
3132        if (subchap.eq.1) then
3133           xj=xj_temp-xi
3134           yj=yj_temp-yi
3135           zj=zj_temp-zi
3136        else
3137           xj=xj_safe-xi
3138           yj=yj_safe-yi
3139           zj=zj_safe-zi
3140        endif
3141           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3142 C sss is scaling function for smoothing the cutoff gradient otherwise
3143 C the gradient would not be continuouse
3144           sss=sscale(1.0d0/(dsqrt(rrij)))
3145           if (sss.le.0.0d0) cycle
3146           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3147           fac=rrij**expon2
3148           e1=fac*fac*aad(itypj,iteli)
3149           e2=fac*bad(itypj,iteli)
3150           if (iabs(j-i) .le. 2) then
3151             e1=scal14*e1
3152             e2=scal14*e2
3153             evdw2_14=evdw2_14+(e1+e2)*sss
3154           endif
3155           evdwij=e1+e2
3156 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3157 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3158 c     &       bad(itypj,iteli)
3159           evdw2=evdw2+evdwij*sss
3160           if (calc_grad) then
3161 C
3162 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3163 C
3164           fac=-(evdwij+e1)*rrij*sss
3165           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3166           ggg(1)=xj*fac
3167           ggg(2)=yj*fac
3168           ggg(3)=zj*fac
3169           if (j.lt.i) then
3170 cd          write (iout,*) 'j<i'
3171 C Uncomment following three lines for SC-p interactions
3172 c           do k=1,3
3173 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3174 c           enddo
3175           else
3176 cd          write (iout,*) 'j>i'
3177             do k=1,3
3178               ggg(k)=-ggg(k)
3179 C Uncomment following line for SC-p interactions
3180 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3181             enddo
3182           endif
3183           do k=1,3
3184             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3185           enddo
3186           kstart=min0(i+1,j)
3187           kend=max0(i-1,j-1)
3188 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3189 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3190           do k=kstart,kend
3191             do l=1,3
3192               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3193             enddo
3194           enddo
3195           endif
3196         enddo
3197         enddo ! iint
3198  1225   continue
3199       enddo ! i
3200       do i=1,nct
3201         do j=1,3
3202           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3203           gradx_scp(j,i)=expon*gradx_scp(j,i)
3204         enddo
3205       enddo
3206 C******************************************************************************
3207 C
3208 C                              N O T E !!!
3209 C
3210 C To save time the factor EXPON has been extracted from ALL components
3211 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3212 C use!
3213 C
3214 C******************************************************************************
3215       return
3216       end
3217 C--------------------------------------------------------------------------
3218       subroutine edis(ehpb)
3219 C
3220 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3221 C
3222       implicit real*8 (a-h,o-z)
3223       include 'DIMENSIONS'
3224       include 'DIMENSIONS.FREE'
3225       include 'COMMON.SBRIDGE'
3226       include 'COMMON.CHAIN'
3227       include 'COMMON.DERIV'
3228       include 'COMMON.VAR'
3229       include 'COMMON.INTERACT'
3230       include 'COMMON.CONTROL'
3231       include 'COMMON.IOUNITS'
3232       dimension ggg(3),ggg_peak(3,100)
3233       ehpb=0.0D0
3234       do i=1,3
3235        ggg(i)=0.0d0
3236       enddo
3237 C      write (iout,*) ,"link_end",link_end,constr_dist
3238 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3239 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
3240 c     &  " constr_dist",constr_dist
3241       if (link_end.eq.0.and.link_end_peak.eq.0) return
3242       do i=link_start_peak,link_end_peak
3243         ehpb_peak=0.0d0
3244 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
3245 c     &   ipeak(1,i),ipeak(2,i)
3246         do ip=ipeak(1,i),ipeak(2,i)
3247           ii=ihpb_peak(ip)
3248           jj=jhpb_peak(ip)
3249           dd=dist(ii,jj)
3250           iip=ip-ipeak(1,i)+1
3251 C iii and jjj point to the residues for which the distance is assigned.
3252           if (ii.gt.nres) then
3253             iii=ii-nres
3254             jjj=jj-nres
3255           else
3256             iii=ii
3257             jjj=jj
3258           endif
3259           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
3260           aux=dexp(-scal_peak*aux)
3261           ehpb_peak=ehpb_peak+aux
3262           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
3263      &      forcon_peak(ip))*aux/dd
3264           do j=1,3
3265             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
3266           enddo
3267           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
3268      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
3269      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
3270         enddo
3271 c        write (iout,*) i,ii,jj,"ehpb_peak",ehpb_peak,
3272 c     &     " scal_peak",scal_peak
3273         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
3274         do ip=ipeak(1,i),ipeak(2,i)
3275           iip=ip-ipeak(1,i)+1
3276           do j=1,3
3277             ggg(j)=ggg_peak(j,iip)/ehpb_peak
3278           enddo
3279           ii=ihpb_peak(ip)
3280           jj=jhpb_peak(ip)
3281 C iii and jjj point to the residues for which the distance is assigned.
3282           if (ii.gt.nres) then
3283             iii=ii-nres
3284             jjj=jj-nres
3285           else
3286             iii=ii
3287             jjj=jj
3288           endif
3289           if (iii.lt.ii) then
3290             do j=1,3
3291               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3292               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3293             enddo
3294           endif
3295           do k=1,3
3296             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3297             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3298           enddo
3299         enddo
3300       enddo
3301       do i=link_start,link_end
3302 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3303 C CA-CA distance used in regularization of structure.
3304         ii=ihpb(i)
3305         jj=jhpb(i)
3306 C iii and jjj point to the residues for which the distance is assigned.
3307         if (ii.gt.nres) then
3308           iii=ii-nres
3309           jjj=jj-nres
3310         else
3311           iii=ii
3312           jjj=jj
3313         endif
3314 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3315 c     &    dhpb(i),dhpb1(i),forcon(i)
3316 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3317 C    distance and angle dependent SS bond potential.
3318 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3319 C     & iabs(itype(jjj)).eq.1) then
3320 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3321 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3322         if (.not.dyn_ss .and. i.le.nss) then
3323 C 15/02/13 CC dynamic SSbond - additional check
3324           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3325      &        iabs(itype(jjj)).eq.1) then
3326            call ssbond_ene(iii,jjj,eij)
3327            ehpb=ehpb+2*eij
3328          endif
3329 cd          write (iout,*) "eij",eij
3330 cd   &   ' waga=',waga,' fac=',fac
3331 !        else if (ii.gt.nres .and. jj.gt.nres) then
3332         else
3333 C Calculate the distance between the two points and its difference from the
3334 C target distance.
3335           dd=dist(ii,jj)
3336           if (irestr_type(i).eq.11) then
3337             ehpb=ehpb+fordepth(i)!**4.0d0
3338      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3339             fac=fordepth(i)!**4.0d0
3340      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3341 c            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
3342 c     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3343 c     &        ehpb,irestr_type(i)
3344           else if (irestr_type(i).eq.10) then
3345 c AL 6//19/2018 cross-link restraints
3346             xdis = 0.5d0*(dd/forcon(i))**2
3347             expdis = dexp(-xdis)
3348 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
3349             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
3350 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
3351 c     &          " wboltzd",wboltzd
3352             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
3353 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
3354             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
3355      &           *expdis/(aux*forcon(i)**2)
3356 c            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
3357 c     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3358 c     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
3359           else if (irestr_type(i).eq.2) then
3360 c Quartic restraints
3361             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3362 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3363 c     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3364 c     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
3365             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3366           else
3367 c Quadratic restraints
3368             rdis=dd-dhpb(i)
3369 C Get the force constant corresponding to this distance.
3370             waga=forcon(i)
3371 C Calculate the contribution to energy.
3372             ehpb=ehpb+0.5d0*waga*rdis*rdis
3373 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3374 c     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3375 c     &       0.5d0*waga*rdis*rdis,irestr_type(i)
3376 C
3377 C Evaluate gradient.
3378 C
3379             fac=waga*rdis/dd
3380           endif
3381 c Calculate Cartesian gradient
3382           do j=1,3
3383             ggg(j)=fac*(c(j,jj)-c(j,ii))
3384           enddo
3385 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3386 C If this is a SC-SC distance, we need to calculate the contributions to the
3387 C Cartesian gradient in the SC vectors (ghpbx).
3388           if (iii.lt.ii) then
3389             do j=1,3
3390               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3391               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3392             enddo
3393           endif
3394           do k=1,3
3395             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3396             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3397           enddo
3398         endif
3399       enddo
3400       return
3401       end
3402 C--------------------------------------------------------------------------
3403       subroutine ssbond_ene(i,j,eij)
3404 C
3405 C Calculate the distance and angle dependent SS-bond potential energy
3406 C using a free-energy function derived based on RHF/6-31G** ab initio
3407 C calculations of diethyl disulfide.
3408 C
3409 C A. Liwo and U. Kozlowska, 11/24/03
3410 C
3411       implicit real*8 (a-h,o-z)
3412       include 'DIMENSIONS'
3413       include 'DIMENSIONS.ZSCOPT'
3414       include 'COMMON.SBRIDGE'
3415       include 'COMMON.CHAIN'
3416       include 'COMMON.DERIV'
3417       include 'COMMON.LOCAL'
3418       include 'COMMON.INTERACT'
3419       include 'COMMON.VAR'
3420       include 'COMMON.IOUNITS'
3421       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3422       itypi=iabs(itype(i))
3423       xi=c(1,nres+i)
3424       yi=c(2,nres+i)
3425       zi=c(3,nres+i)
3426       dxi=dc_norm(1,nres+i)
3427       dyi=dc_norm(2,nres+i)
3428       dzi=dc_norm(3,nres+i)
3429       dsci_inv=dsc_inv(itypi)
3430       itypj=iabs(itype(j))
3431       dscj_inv=dsc_inv(itypj)
3432       xj=c(1,nres+j)-xi
3433       yj=c(2,nres+j)-yi
3434       zj=c(3,nres+j)-zi
3435       dxj=dc_norm(1,nres+j)
3436       dyj=dc_norm(2,nres+j)
3437       dzj=dc_norm(3,nres+j)
3438       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3439       rij=dsqrt(rrij)
3440       erij(1)=xj*rij
3441       erij(2)=yj*rij
3442       erij(3)=zj*rij
3443       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3444       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3445       om12=dxi*dxj+dyi*dyj+dzi*dzj
3446       do k=1,3
3447         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3448         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3449       enddo
3450       rij=1.0d0/rij
3451       deltad=rij-d0cm
3452       deltat1=1.0d0-om1
3453       deltat2=1.0d0+om2
3454       deltat12=om2-om1+2.0d0
3455       cosphi=om12-om1*om2
3456       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3457      &  +akct*deltad*deltat12
3458      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3459 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3460 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3461 c     &  " deltat12",deltat12," eij",eij
3462       ed=2*akcm*deltad+akct*deltat12
3463       pom1=akct*deltad
3464       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3465       eom1=-2*akth*deltat1-pom1-om2*pom2
3466       eom2= 2*akth*deltat2+pom1-om1*pom2
3467       eom12=pom2
3468       do k=1,3
3469         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3470       enddo
3471       do k=1,3
3472         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3473      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3474         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3475      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3476       enddo
3477 C
3478 C Calculate the components of the gradient in DC and X
3479 C
3480       do k=i,j-1
3481         do l=1,3
3482           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3483         enddo
3484       enddo
3485       return
3486       end
3487 C--------------------------------------------------------------------------
3488 c MODELLER restraint function
3489       subroutine e_modeller(ehomology_constr)
3490       implicit real*8 (a-h,o-z)
3491       include 'DIMENSIONS'
3492       include 'DIMENSIONS.ZSCOPT'
3493       include 'DIMENSIONS.FREE'
3494       integer nnn, i, j, k, ki, irec, l
3495       integer katy, odleglosci, test7
3496       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3497       real*8 distance(max_template),distancek(max_template),
3498      &    min_odl,godl(max_template),dih_diff(max_template)
3499
3500 c
3501 c     FP - 30/10/2014 Temporary specifications for homology restraints
3502 c
3503       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3504      &                 sgtheta
3505       double precision, dimension (maxres) :: guscdiff,usc_diff
3506       double precision, dimension (max_template) ::
3507      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3508      &           theta_diff
3509
3510       include 'COMMON.SBRIDGE'
3511       include 'COMMON.CHAIN'
3512       include 'COMMON.GEO'
3513       include 'COMMON.DERIV'
3514       include 'COMMON.LOCAL'
3515       include 'COMMON.INTERACT'
3516       include 'COMMON.VAR'
3517       include 'COMMON.IOUNITS'
3518       include 'COMMON.CONTROL'
3519       include 'COMMON.HOMRESTR'
3520 c
3521       include 'COMMON.SETUP'
3522       include 'COMMON.NAMES'
3523
3524       do i=1,max_template
3525         distancek(i)=9999999.9
3526       enddo
3527
3528       odleg=0.0d0
3529
3530 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3531 c function)
3532 C AL 5/2/14 - Introduce list of restraints
3533 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3534 #ifdef DEBUG
3535       write(iout,*) "------- dist restrs start -------"
3536 #endif
3537       do ii = link_start_homo,link_end_homo
3538          i = ires_homo(ii)
3539          j = jres_homo(ii)
3540          dij=dist(i,j)
3541 c        write (iout,*) "dij(",i,j,") =",dij
3542          nexl=0
3543          do k=1,constr_homology
3544            if(.not.l_homo(k,ii)) then
3545               nexl=nexl+1
3546               cycle
3547            endif
3548            distance(k)=odl(k,ii)-dij
3549 c          write (iout,*) "distance(",k,") =",distance(k)
3550 c
3551 c          For Gaussian-type Urestr
3552 c
3553            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3554 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3555 c          write (iout,*) "distancek(",k,") =",distancek(k)
3556 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3557 c
3558 c          For Lorentzian-type Urestr
3559 c
3560            if (waga_dist.lt.0.0d0) then
3561               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3562               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3563      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3564            endif
3565          enddo
3566
3567 c         min_odl=minval(distancek)
3568          do kk=1,constr_homology
3569           if(l_homo(kk,ii)) then
3570             min_odl=distancek(kk)
3571             exit
3572           endif
3573          enddo
3574          do kk=1,constr_homology
3575           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3576      &              min_odl=distancek(kk)
3577          enddo
3578 c        write (iout,* )"min_odl",min_odl
3579 #ifdef DEBUG
3580          write (iout,*) "ij dij",i,j,dij
3581          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3582          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3583          write (iout,* )"min_odl",min_odl
3584 #endif
3585 #ifdef OLDRESTR
3586          odleg2=0.0d0
3587 #else
3588          if (waga_dist.ge.0.0d0) then
3589            odleg2=nexl
3590          else
3591            odleg2=0.0d0
3592          endif
3593 #endif
3594          do k=1,constr_homology
3595 c Nie wiem po co to liczycie jeszcze raz!
3596 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3597 c     &              (2*(sigma_odl(i,j,k))**2))
3598            if(.not.l_homo(k,ii)) cycle
3599            if (waga_dist.ge.0.0d0) then
3600 c
3601 c          For Gaussian-type Urestr
3602 c
3603             godl(k)=dexp(-distancek(k)+min_odl)
3604             odleg2=odleg2+godl(k)
3605 c
3606 c          For Lorentzian-type Urestr
3607 c
3608            else
3609             odleg2=odleg2+distancek(k)
3610            endif
3611
3612 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3613 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3614 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3615 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3616
3617          enddo
3618 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3619 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3620 #ifdef DEBUG
3621          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3622          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3623 #endif
3624            if (waga_dist.ge.0.0d0) then
3625 c
3626 c          For Gaussian-type Urestr
3627 c
3628               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3629 c
3630 c          For Lorentzian-type Urestr
3631 c
3632            else
3633               odleg=odleg+odleg2/constr_homology
3634            endif
3635 c
3636 #ifdef GRAD
3637 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3638 c Gradient
3639 c
3640 c          For Gaussian-type Urestr
3641 c
3642          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3643          sum_sgodl=0.0d0
3644          do k=1,constr_homology
3645 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3646 c     &           *waga_dist)+min_odl
3647 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3648 c
3649          if(.not.l_homo(k,ii)) cycle
3650          if (waga_dist.ge.0.0d0) then
3651 c          For Gaussian-type Urestr
3652 c
3653            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3654 c
3655 c          For Lorentzian-type Urestr
3656 c
3657          else
3658            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3659      &           sigma_odlir(k,ii)**2)**2)
3660          endif
3661            sum_sgodl=sum_sgodl+sgodl
3662
3663 c            sgodl2=sgodl2+sgodl
3664 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3665 c      write(iout,*) "constr_homology=",constr_homology
3666 c      write(iout,*) i, j, k, "TEST K"
3667          enddo
3668          if (waga_dist.ge.0.0d0) then
3669 c
3670 c          For Gaussian-type Urestr
3671 c
3672             grad_odl3=waga_homology(iset)*waga_dist
3673      &                *sum_sgodl/(sum_godl*dij)
3674 c
3675 c          For Lorentzian-type Urestr
3676 c
3677          else
3678 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3679 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3680             grad_odl3=-waga_homology(iset)*waga_dist*
3681      &                sum_sgodl/(constr_homology*dij)
3682          endif
3683 c
3684 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3685
3686
3687 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3688 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3689 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3690
3691 ccc      write(iout,*) godl, sgodl, grad_odl3
3692
3693 c          grad_odl=grad_odl+grad_odl3
3694
3695          do jik=1,3
3696             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3697 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3698 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3699 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3700             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3701             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3702 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3703 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3704 c         if (i.eq.25.and.j.eq.27) then
3705 c         write(iout,*) "jik",jik,"i",i,"j",j
3706 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3707 c         write(iout,*) "grad_odl3",grad_odl3
3708 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3709 c         write(iout,*) "ggodl",ggodl
3710 c         write(iout,*) "ghpbc(",jik,i,")",
3711 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3712 c     &                 ghpbc(jik,j)
3713 c         endif
3714          enddo
3715 #endif
3716 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3717 ccc     & dLOG(odleg2),"-odleg=", -odleg
3718
3719       enddo ! ii-loop for dist
3720 #ifdef DEBUG
3721       write(iout,*) "------- dist restrs end -------"
3722 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3723 c    &     waga_d.eq.1.0d0) call sum_gradient
3724 #endif
3725 c Pseudo-energy and gradient from dihedral-angle restraints from
3726 c homology templates
3727 c      write (iout,*) "End of distance loop"
3728 c      call flush(iout)
3729       kat=0.0d0
3730 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3731 #ifdef DEBUG
3732       write(iout,*) "------- dih restrs start -------"
3733       do i=idihconstr_start_homo,idihconstr_end_homo
3734         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3735       enddo
3736 #endif
3737       do i=idihconstr_start_homo,idihconstr_end_homo
3738         kat2=0.0d0
3739 c        betai=beta(i,i+1,i+2,i+3)
3740         betai = phi(i)
3741 c       write (iout,*) "betai =",betai
3742         do k=1,constr_homology
3743           dih_diff(k)=pinorm(dih(k,i)-betai)
3744 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3745 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3746 c     &                                   -(6.28318-dih_diff(i,k))
3747 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3748 c     &                                   6.28318+dih_diff(i,k)
3749 #ifdef OLD_DIHED
3750           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3751 #else
3752           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3753 #endif
3754 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3755           gdih(k)=dexp(kat3)
3756           kat2=kat2+gdih(k)
3757 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3758 c          write(*,*)""
3759         enddo
3760 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3761 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3762 #ifdef DEBUG
3763         write (iout,*) "i",i," betai",betai," kat2",kat2
3764         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3765 #endif
3766         if (kat2.le.1.0d-14) cycle
3767         kat=kat-dLOG(kat2/constr_homology)
3768 c       write (iout,*) "kat",kat ! sum of -ln-s
3769
3770 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3771 ccc     & dLOG(kat2), "-kat=", -kat
3772
3773 #ifdef GRAD
3774 c ----------------------------------------------------------------------
3775 c Gradient
3776 c ----------------------------------------------------------------------
3777
3778         sum_gdih=kat2
3779         sum_sgdih=0.0d0
3780         do k=1,constr_homology
3781 #ifdef OLD_DIHED
3782           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3783 #else
3784           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3785 #endif
3786 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3787           sum_sgdih=sum_sgdih+sgdih
3788         enddo
3789 c       grad_dih3=sum_sgdih/sum_gdih
3790         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3791
3792 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3793 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3794 ccc     & gloc(nphi+i-3,icg)
3795         gloc(i,icg)=gloc(i,icg)+grad_dih3
3796 c        if (i.eq.25) then
3797 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3798 c        endif
3799 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3800 ccc     & gloc(nphi+i-3,icg)
3801 #endif
3802       enddo ! i-loop for dih
3803 #ifdef DEBUG
3804       write(iout,*) "------- dih restrs end -------"
3805 #endif
3806
3807 c Pseudo-energy and gradient for theta angle restraints from
3808 c homology templates
3809 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3810 c adapted
3811
3812 c
3813 c     For constr_homology reference structures (FP)
3814 c
3815 c     Uconst_back_tot=0.0d0
3816       Eval=0.0d0
3817       Erot=0.0d0
3818 c     Econstr_back legacy
3819 #ifdef GRAD
3820       do i=1,nres
3821 c     do i=ithet_start,ithet_end
3822        dutheta(i)=0.0d0
3823 c     enddo
3824 c     do i=loc_start,loc_end
3825         do j=1,3
3826           duscdiff(j,i)=0.0d0
3827           duscdiffx(j,i)=0.0d0
3828         enddo
3829       enddo
3830 #endif
3831 c
3832 c     do iref=1,nref
3833 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3834 c     write (iout,*) "waga_theta",waga_theta
3835       if (waga_theta.gt.0.0d0) then
3836 #ifdef DEBUG
3837       write (iout,*) "usampl",usampl
3838       write(iout,*) "------- theta restrs start -------"
3839 c     do i=ithet_start,ithet_end
3840 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3841 c     enddo
3842 #endif
3843 c     write (iout,*) "maxres",maxres,"nres",nres
3844
3845       do i=ithet_start,ithet_end
3846 c
3847 c     do i=1,nfrag_back
3848 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3849 c
3850 c Deviation of theta angles wrt constr_homology ref structures
3851 c
3852         utheta_i=0.0d0 ! argument of Gaussian for single k
3853         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3854 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3855 c       over residues in a fragment
3856 c       write (iout,*) "theta(",i,")=",theta(i)
3857         do k=1,constr_homology
3858 c
3859 c         dtheta_i=theta(j)-thetaref(j,iref)
3860 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3861           theta_diff(k)=thetatpl(k,i)-theta(i)
3862 c
3863           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3864 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3865           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3866           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3867 c         Gradient for single Gaussian restraint in subr Econstr_back
3868 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3869 c
3870         enddo
3871 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3872 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3873
3874 c
3875 #ifdef GRAD
3876 c         Gradient for multiple Gaussian restraint
3877         sum_gtheta=gutheta_i
3878         sum_sgtheta=0.0d0
3879         do k=1,constr_homology
3880 c        New generalized expr for multiple Gaussian from Econstr_back
3881          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3882 c
3883 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3884           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3885         enddo
3886 c
3887 c       Final value of gradient using same var as in Econstr_back
3888         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3889      &               *waga_homology(iset)
3890 c       dutheta(i)=sum_sgtheta/sum_gtheta
3891 c
3892 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3893 #endif
3894         Eval=Eval-dLOG(gutheta_i/constr_homology)
3895 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3896 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3897 c       Uconst_back=Uconst_back+utheta(i)
3898       enddo ! (i-loop for theta)
3899 #ifdef DEBUG
3900       write(iout,*) "------- theta restrs end -------"
3901 #endif
3902       endif
3903 c
3904 c Deviation of local SC geometry
3905 c
3906 c Separation of two i-loops (instructed by AL - 11/3/2014)
3907 c
3908 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3909 c     write (iout,*) "waga_d",waga_d
3910
3911 #ifdef DEBUG
3912       write(iout,*) "------- SC restrs start -------"
3913       write (iout,*) "Initial duscdiff,duscdiffx"
3914       do i=loc_start,loc_end
3915         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3916      &                 (duscdiffx(jik,i),jik=1,3)
3917       enddo
3918 #endif
3919       do i=loc_start,loc_end
3920         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3921         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3922 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3923 c       write(iout,*) "xxtab, yytab, zztab"
3924 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3925         do k=1,constr_homology
3926 c
3927           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3928 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3929           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3930           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3931 c         write(iout,*) "dxx, dyy, dzz"
3932 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3933 c
3934           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3935 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3936 c         uscdiffk(k)=usc_diff(i)
3937           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3938           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3939 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3940 c     &      xxref(j),yyref(j),zzref(j)
3941         enddo
3942 c
3943 c       Gradient
3944 c
3945 c       Generalized expression for multiple Gaussian acc to that for a single
3946 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3947 c
3948 c       Original implementation
3949 c       sum_guscdiff=guscdiff(i)
3950 c
3951 c       sum_sguscdiff=0.0d0
3952 c       do k=1,constr_homology
3953 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3954 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3955 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3956 c       enddo
3957 c
3958 c       Implementation of new expressions for gradient (Jan. 2015)
3959 c
3960 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3961 #ifdef GRAD
3962         do k=1,constr_homology
3963 c
3964 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3965 c       before. Now the drivatives should be correct
3966 c
3967           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3968 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3969           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3970           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3971 c
3972 c         New implementation
3973 c
3974           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3975      &                 sigma_d(k,i) ! for the grad wrt r'
3976 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3977 c
3978 c
3979 c        New implementation
3980          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3981          do jik=1,3
3982             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3983      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3984      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3985             duscdiff(jik,i)=duscdiff(jik,i)+
3986      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3987      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3988             duscdiffx(jik,i)=duscdiffx(jik,i)+
3989      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3990      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3991 c
3992 #ifdef DEBUG
3993              write(iout,*) "jik",jik,"i",i
3994              write(iout,*) "dxx, dyy, dzz"
3995              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3996              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3997 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3998 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3999 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4000 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4001 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4002 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4003 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4004 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4005 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4006 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4007 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4008 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4009 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4010 c            endif
4011 #endif
4012          enddo
4013         enddo
4014 #endif
4015 c
4016 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4017 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4018 c
4019 c        write (iout,*) i," uscdiff",uscdiff(i)
4020 c
4021 c Put together deviations from local geometry
4022
4023 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4024 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4025         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4026 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4027 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4028 c       Uconst_back=Uconst_back+usc_diff(i)
4029 c
4030 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4031 c
4032 c     New implment: multiplied by sum_sguscdiff
4033 c
4034
4035       enddo ! (i-loop for dscdiff)
4036
4037 c      endif
4038
4039 #ifdef DEBUG
4040       write(iout,*) "------- SC restrs end -------"
4041         write (iout,*) "------ After SC loop in e_modeller ------"
4042         do i=loc_start,loc_end
4043          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4044          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4045         enddo
4046       if (waga_theta.eq.1.0d0) then
4047       write (iout,*) "in e_modeller after SC restr end: dutheta"
4048       do i=ithet_start,ithet_end
4049         write (iout,*) i,dutheta(i)
4050       enddo
4051       endif
4052       if (waga_d.eq.1.0d0) then
4053       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4054       do i=1,nres
4055         write (iout,*) i,(duscdiff(j,i),j=1,3)
4056         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4057       enddo
4058       endif
4059 #endif
4060
4061 c Total energy from homology restraints
4062 #ifdef DEBUG
4063       write (iout,*) "odleg",odleg," kat",kat
4064       write (iout,*) "odleg",odleg," kat",kat
4065       write (iout,*) "Eval",Eval," Erot",Erot
4066       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4067       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4068       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4069 #endif
4070 c
4071 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4072 c
4073 c     ehomology_constr=odleg+kat
4074 c
4075 c     For Lorentzian-type Urestr
4076 c
4077
4078       if (waga_dist.ge.0.0d0) then
4079 c
4080 c          For Gaussian-type Urestr
4081 c
4082 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4083 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4084         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4085      &              waga_theta*Eval+waga_d*Erot
4086 c     write (iout,*) "ehomology_constr=",ehomology_constr
4087       else
4088 c
4089 c          For Lorentzian-type Urestr
4090 c
4091 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4092 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4093         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4094      &              waga_theta*Eval+waga_d*Erot
4095 c     write (iout,*) "ehomology_constr=",ehomology_constr
4096       endif
4097 #ifdef DEBUG
4098       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4099      & "Eval",waga_theta,eval,
4100      &   "Erot",waga_d,Erot
4101       write (iout,*) "ehomology_constr",ehomology_constr
4102 #endif
4103       return
4104
4105   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4106   747 format(a12,i4,i4,i4,f8.3,f8.3)
4107   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4108   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4109   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4110      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4111       end
4112 c-----------------------------------------------------------------------
4113       subroutine ebond(estr)
4114 c
4115 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4116 c
4117       implicit real*8 (a-h,o-z)
4118       include 'DIMENSIONS'
4119       include 'DIMENSIONS.ZSCOPT'
4120       include 'DIMENSIONS.FREE'
4121       include 'COMMON.LOCAL'
4122       include 'COMMON.GEO'
4123       include 'COMMON.INTERACT'
4124       include 'COMMON.DERIV'
4125       include 'COMMON.VAR'
4126       include 'COMMON.CHAIN'
4127       include 'COMMON.IOUNITS'
4128       include 'COMMON.NAMES'
4129       include 'COMMON.FFIELD'
4130       include 'COMMON.CONTROL'
4131       double precision u(3),ud(3)
4132       estr=0.0d0
4133 C      write (iout,*) "distchainmax",distchainmax
4134       estr1=0.0d0
4135 c      write (iout,*) "distchainmax",distchainmax
4136       do i=nnt+1,nct
4137         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4138 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4139 C          do j=1,3
4140 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4141 C     &      *dc(j,i-1)/vbld(i)
4142 C          enddo
4143 C          if (energy_dec) write(iout,*)
4144 C     &       "estr1",i,vbld(i),distchainmax,
4145 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4146 C        else
4147          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4148         diff = vbld(i)-vbldpDUM
4149 C         write(iout,*) i,diff
4150          else
4151           diff = vbld(i)-vbldp0
4152 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4153          endif
4154           estr=estr+diff*diff
4155           do j=1,3
4156             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4157           enddo
4158 C        endif
4159 C        write (iout,'(a7,i5,4f7.3)')
4160 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4161       enddo
4162       estr=0.5d0*AKP*estr+estr1
4163 c
4164 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4165 c
4166       do i=nnt,nct
4167         iti=iabs(itype(i))
4168         if (iti.ne.10 .and. iti.ne.ntyp1) then
4169           nbi=nbondterm(iti)
4170           if (nbi.eq.1) then
4171             diff=vbld(i+nres)-vbldsc0(1,iti)
4172 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4173 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4174             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4175             do j=1,3
4176               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4177             enddo
4178           else
4179             do j=1,nbi
4180               diff=vbld(i+nres)-vbldsc0(j,iti)
4181               ud(j)=aksc(j,iti)*diff
4182               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4183             enddo
4184             uprod=u(1)
4185             do j=2,nbi
4186               uprod=uprod*u(j)
4187             enddo
4188             usum=0.0d0
4189             usumsqder=0.0d0
4190             do j=1,nbi
4191               uprod1=1.0d0
4192               uprod2=1.0d0
4193               do k=1,nbi
4194                 if (k.ne.j) then
4195                   uprod1=uprod1*u(k)
4196                   uprod2=uprod2*u(k)*u(k)
4197                 endif
4198               enddo
4199               usum=usum+uprod1
4200               usumsqder=usumsqder+ud(j)*uprod2
4201             enddo
4202 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4203 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4204             estr=estr+uprod/usum
4205             do j=1,3
4206              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4207             enddo
4208           endif
4209         endif
4210       enddo
4211       return
4212       end
4213 #ifdef CRYST_THETA
4214 C--------------------------------------------------------------------------
4215       subroutine ebend(etheta)
4216 C
4217 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4218 C angles gamma and its derivatives in consecutive thetas and gammas.
4219 C
4220       implicit real*8 (a-h,o-z)
4221       include 'DIMENSIONS'
4222       include 'DIMENSIONS.ZSCOPT'
4223       include 'COMMON.LOCAL'
4224       include 'COMMON.GEO'
4225       include 'COMMON.INTERACT'
4226       include 'COMMON.DERIV'
4227       include 'COMMON.VAR'
4228       include 'COMMON.CHAIN'
4229       include 'COMMON.IOUNITS'
4230       include 'COMMON.NAMES'
4231       include 'COMMON.FFIELD'
4232       common /calcthet/ term1,term2,termm,diffak,ratak,
4233      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4234      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4235       double precision y(2),z(2)
4236       delta=0.02d0*pi
4237       time11=dexp(-2*time)
4238       time12=1.0d0
4239       etheta=0.0D0
4240 c      write (iout,*) "nres",nres
4241 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4242 c      write (iout,*) ithet_start,ithet_end
4243       do i=ithet_start,ithet_end
4244 C        if (itype(i-1).eq.ntyp1) cycle
4245 c        if (i.le.2) cycle
4246         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4247      &  .or.itype(i).eq.ntyp1) cycle
4248 C Zero the energy function and its derivative at 0 or pi.
4249         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4250         it=itype(i-1)
4251         ichir1=isign(1,itype(i-2))
4252         ichir2=isign(1,itype(i))
4253          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4254          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4255          if (itype(i-1).eq.10) then
4256           itype1=isign(10,itype(i-2))
4257           ichir11=isign(1,itype(i-2))
4258           ichir12=isign(1,itype(i-2))
4259           itype2=isign(10,itype(i))
4260           ichir21=isign(1,itype(i))
4261           ichir22=isign(1,itype(i))
4262          endif
4263          if (i.eq.3) then
4264           y(1)=0.0D0
4265           y(2)=0.0D0
4266           else
4267
4268         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4269 #ifdef OSF
4270           phii=phi(i)
4271 c          icrc=0
4272 c          call proc_proc(phii,icrc)
4273           if (icrc.eq.1) phii=150.0
4274 #else
4275           phii=phi(i)
4276 #endif
4277           y(1)=dcos(phii)
4278           y(2)=dsin(phii)
4279         else
4280           y(1)=0.0D0
4281           y(2)=0.0D0
4282         endif
4283         endif
4284         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4285 #ifdef OSF
4286           phii1=phi(i+1)
4287 c          icrc=0
4288 c          call proc_proc(phii1,icrc)
4289           if (icrc.eq.1) phii1=150.0
4290           phii1=pinorm(phii1)
4291           z(1)=cos(phii1)
4292 #else
4293           phii1=phi(i+1)
4294           z(1)=dcos(phii1)
4295 #endif
4296           z(2)=dsin(phii1)
4297         else
4298           z(1)=0.0D0
4299           z(2)=0.0D0
4300         endif
4301 C Calculate the "mean" value of theta from the part of the distribution
4302 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4303 C In following comments this theta will be referred to as t_c.
4304         thet_pred_mean=0.0d0
4305         do k=1,2
4306             athetk=athet(k,it,ichir1,ichir2)
4307             bthetk=bthet(k,it,ichir1,ichir2)
4308           if (it.eq.10) then
4309              athetk=athet(k,itype1,ichir11,ichir12)
4310              bthetk=bthet(k,itype2,ichir21,ichir22)
4311           endif
4312           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4313         enddo
4314 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4315         dthett=thet_pred_mean*ssd
4316         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4317 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4318 C Derivatives of the "mean" values in gamma1 and gamma2.
4319         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4320      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4321          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4322      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4323          if (it.eq.10) then
4324       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4325      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4326         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4327      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4328          endif
4329         if (theta(i).gt.pi-delta) then
4330           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4331      &         E_tc0)
4332           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4333           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4334           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4335      &        E_theta)
4336           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4337      &        E_tc)
4338         else if (theta(i).lt.delta) then
4339           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4340           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4341           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4342      &        E_theta)
4343           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4344           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4345      &        E_tc)
4346         else
4347           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4348      &        E_theta,E_tc)
4349         endif
4350         etheta=etheta+ethetai
4351 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4352 c     &      'ebend',i,ethetai,theta(i),itype(i)
4353 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4354 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4355         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4356         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4357         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4358 c 1215   continue
4359       enddo
4360       ethetacnstr=0.0d0
4361 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4362       do i=1,ntheta_constr
4363         itheta=itheta_constr(i)
4364         thetiii=theta(itheta)
4365         difi=pinorm(thetiii-theta_constr0(i))
4366         if (difi.gt.theta_drange(i)) then
4367           difi=difi-theta_drange(i)
4368           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4369           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4370      &    +for_thet_constr(i)*difi**3
4371         else if (difi.lt.-drange(i)) then
4372           difi=difi+drange(i)
4373           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4374           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4375      &    +for_thet_constr(i)*difi**3
4376         else
4377           difi=0.0
4378         endif
4379 C       if (energy_dec) then
4380 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4381 C     &    i,itheta,rad2deg*thetiii,
4382 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4383 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4384 C     &    gloc(itheta+nphi-2,icg)
4385 C        endif
4386       enddo
4387 C Ufff.... We've done all this!!!
4388       return
4389       end
4390 C---------------------------------------------------------------------------
4391       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4392      &     E_tc)
4393       implicit real*8 (a-h,o-z)
4394       include 'DIMENSIONS'
4395       include 'COMMON.LOCAL'
4396       include 'COMMON.IOUNITS'
4397       common /calcthet/ term1,term2,termm,diffak,ratak,
4398      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4399      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4400 C Calculate the contributions to both Gaussian lobes.
4401 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4402 C The "polynomial part" of the "standard deviation" of this part of
4403 C the distribution.
4404         sig=polthet(3,it)
4405         do j=2,0,-1
4406           sig=sig*thet_pred_mean+polthet(j,it)
4407         enddo
4408 C Derivative of the "interior part" of the "standard deviation of the"
4409 C gamma-dependent Gaussian lobe in t_c.
4410         sigtc=3*polthet(3,it)
4411         do j=2,1,-1
4412           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4413         enddo
4414         sigtc=sig*sigtc
4415 C Set the parameters of both Gaussian lobes of the distribution.
4416 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4417         fac=sig*sig+sigc0(it)
4418         sigcsq=fac+fac
4419         sigc=1.0D0/sigcsq
4420 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4421         sigsqtc=-4.0D0*sigcsq*sigtc
4422 c       print *,i,sig,sigtc,sigsqtc
4423 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4424         sigtc=-sigtc/(fac*fac)
4425 C Following variable is sigma(t_c)**(-2)
4426         sigcsq=sigcsq*sigcsq
4427         sig0i=sig0(it)
4428         sig0inv=1.0D0/sig0i**2
4429         delthec=thetai-thet_pred_mean
4430         delthe0=thetai-theta0i
4431         term1=-0.5D0*sigcsq*delthec*delthec
4432         term2=-0.5D0*sig0inv*delthe0*delthe0
4433 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4434 C NaNs in taking the logarithm. We extract the largest exponent which is added
4435 C to the energy (this being the log of the distribution) at the end of energy
4436 C term evaluation for this virtual-bond angle.
4437         if (term1.gt.term2) then
4438           termm=term1
4439           term2=dexp(term2-termm)
4440           term1=1.0d0
4441         else
4442           termm=term2
4443           term1=dexp(term1-termm)
4444           term2=1.0d0
4445         endif
4446 C The ratio between the gamma-independent and gamma-dependent lobes of
4447 C the distribution is a Gaussian function of thet_pred_mean too.
4448         diffak=gthet(2,it)-thet_pred_mean
4449         ratak=diffak/gthet(3,it)**2
4450         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4451 C Let's differentiate it in thet_pred_mean NOW.
4452         aktc=ak*ratak
4453 C Now put together the distribution terms to make complete distribution.
4454         termexp=term1+ak*term2
4455         termpre=sigc+ak*sig0i
4456 C Contribution of the bending energy from this theta is just the -log of
4457 C the sum of the contributions from the two lobes and the pre-exponential
4458 C factor. Simple enough, isn't it?
4459         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4460 C NOW the derivatives!!!
4461 C 6/6/97 Take into account the deformation.
4462         E_theta=(delthec*sigcsq*term1
4463      &       +ak*delthe0*sig0inv*term2)/termexp
4464         E_tc=((sigtc+aktc*sig0i)/termpre
4465      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4466      &       aktc*term2)/termexp)
4467       return
4468       end
4469 c-----------------------------------------------------------------------------
4470       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4471       implicit real*8 (a-h,o-z)
4472       include 'DIMENSIONS'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.IOUNITS'
4475       common /calcthet/ term1,term2,termm,diffak,ratak,
4476      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4477      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4478       delthec=thetai-thet_pred_mean
4479       delthe0=thetai-theta0i
4480 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4481       t3 = thetai-thet_pred_mean
4482       t6 = t3**2
4483       t9 = term1
4484       t12 = t3*sigcsq
4485       t14 = t12+t6*sigsqtc
4486       t16 = 1.0d0
4487       t21 = thetai-theta0i
4488       t23 = t21**2
4489       t26 = term2
4490       t27 = t21*t26
4491       t32 = termexp
4492       t40 = t32**2
4493       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4494      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4495      & *(-t12*t9-ak*sig0inv*t27)
4496       return
4497       end
4498 #else
4499 C--------------------------------------------------------------------------
4500       subroutine ebend(etheta)
4501 C
4502 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4503 C angles gamma and its derivatives in consecutive thetas and gammas.
4504 C ab initio-derived potentials from
4505 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4506 C
4507       implicit real*8 (a-h,o-z)
4508       include 'DIMENSIONS'
4509       include 'DIMENSIONS.ZSCOPT'
4510       include 'DIMENSIONS.FREE'
4511       include 'COMMON.LOCAL'
4512       include 'COMMON.GEO'
4513       include 'COMMON.INTERACT'
4514       include 'COMMON.DERIV'
4515       include 'COMMON.VAR'
4516       include 'COMMON.CHAIN'
4517       include 'COMMON.IOUNITS'
4518       include 'COMMON.NAMES'
4519       include 'COMMON.FFIELD'
4520       include 'COMMON.CONTROL'
4521       include 'COMMON.TORCNSTR'
4522       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4523      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4524      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4525      & sinph1ph2(maxdouble,maxdouble)
4526       logical lprn /.false./, lprn1 /.false./
4527       etheta=0.0D0
4528 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4529       do i=ithet_start,ithet_end
4530 c        if (i.eq.2) cycle
4531 c        print *,i,itype(i-1),itype(i),itype(i-2)
4532         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4533      &  .or.(itype(i).eq.ntyp1)) cycle
4534 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4535
4536         if (iabs(itype(i+1)).eq.20) iblock=2
4537         if (iabs(itype(i+1)).ne.20) iblock=1
4538         dethetai=0.0d0
4539         dephii=0.0d0
4540         dephii1=0.0d0
4541         theti2=0.5d0*theta(i)
4542         ityp2=ithetyp((itype(i-1)))
4543         do k=1,nntheterm
4544           coskt(k)=dcos(k*theti2)
4545           sinkt(k)=dsin(k*theti2)
4546         enddo
4547         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4548 #ifdef OSF
4549           phii=phi(i)
4550           if (phii.ne.phii) phii=150.0
4551 #else
4552           phii=phi(i)
4553 #endif
4554           ityp1=ithetyp((itype(i-2)))
4555           do k=1,nsingle
4556             cosph1(k)=dcos(k*phii)
4557             sinph1(k)=dsin(k*phii)
4558           enddo
4559         else
4560           phii=0.0d0
4561           ityp1=ithetyp(itype(i-2))
4562           do k=1,nsingle
4563             cosph1(k)=0.0d0
4564             sinph1(k)=0.0d0
4565           enddo
4566         endif
4567         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4568 #ifdef OSF
4569           phii1=phi(i+1)
4570           if (phii1.ne.phii1) phii1=150.0
4571           phii1=pinorm(phii1)
4572 #else
4573           phii1=phi(i+1)
4574 #endif
4575           ityp3=ithetyp((itype(i)))
4576           do k=1,nsingle
4577             cosph2(k)=dcos(k*phii1)
4578             sinph2(k)=dsin(k*phii1)
4579           enddo
4580         else
4581           phii1=0.0d0
4582           ityp3=ithetyp(itype(i))
4583           do k=1,nsingle
4584             cosph2(k)=0.0d0
4585             sinph2(k)=0.0d0
4586           enddo
4587         endif
4588 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4589 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4590 c        call flush(iout)
4591         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4592         do k=1,ndouble
4593           do l=1,k-1
4594             ccl=cosph1(l)*cosph2(k-l)
4595             ssl=sinph1(l)*sinph2(k-l)
4596             scl=sinph1(l)*cosph2(k-l)
4597             csl=cosph1(l)*sinph2(k-l)
4598             cosph1ph2(l,k)=ccl-ssl
4599             cosph1ph2(k,l)=ccl+ssl
4600             sinph1ph2(l,k)=scl+csl
4601             sinph1ph2(k,l)=scl-csl
4602           enddo
4603         enddo
4604         if (lprn) then
4605         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4606      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4607         write (iout,*) "coskt and sinkt"
4608         do k=1,nntheterm
4609           write (iout,*) k,coskt(k),sinkt(k)
4610         enddo
4611         endif
4612         do k=1,ntheterm
4613           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4614           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4615      &      *coskt(k)
4616           if (lprn)
4617      &    write (iout,*) "k",k,"
4618      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4619      &     " ethetai",ethetai
4620         enddo
4621         if (lprn) then
4622         write (iout,*) "cosph and sinph"
4623         do k=1,nsingle
4624           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4625         enddo
4626         write (iout,*) "cosph1ph2 and sinph2ph2"
4627         do k=2,ndouble
4628           do l=1,k-1
4629             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4630      &         sinph1ph2(l,k),sinph1ph2(k,l)
4631           enddo
4632         enddo
4633         write(iout,*) "ethetai",ethetai
4634         endif
4635         do m=1,ntheterm2
4636           do k=1,nsingle
4637             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4638      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4639      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4640      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4641             ethetai=ethetai+sinkt(m)*aux
4642             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4643             dephii=dephii+k*sinkt(m)*(
4644      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4645      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4646             dephii1=dephii1+k*sinkt(m)*(
4647      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4648      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4649             if (lprn)
4650      &      write (iout,*) "m",m," k",k," bbthet",
4651      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4652      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4653      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4654      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4655           enddo
4656         enddo
4657         if (lprn)
4658      &  write(iout,*) "ethetai",ethetai
4659         do m=1,ntheterm3
4660           do k=2,ndouble
4661             do l=1,k-1
4662               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4663      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4664      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4665      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4666               ethetai=ethetai+sinkt(m)*aux
4667               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4668               dephii=dephii+l*sinkt(m)*(
4669      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4670      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4671      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4672      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4673               dephii1=dephii1+(k-l)*sinkt(m)*(
4674      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4675      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4676      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4677      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4678               if (lprn) then
4679               write (iout,*) "m",m," k",k," l",l," ffthet",
4680      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4681      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4682      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4683      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4684      &            " ethetai",ethetai
4685               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4686      &            cosph1ph2(k,l)*sinkt(m),
4687      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4688               endif
4689             enddo
4690           enddo
4691         enddo
4692 10      continue
4693         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4694      &   i,theta(i)*rad2deg,phii*rad2deg,
4695      &   phii1*rad2deg,ethetai
4696         etheta=etheta+ethetai
4697         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4698         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4699 c        gloc(nphi+i-2,icg)=wang*dethetai
4700         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4701       enddo
4702 C now constrains
4703       ethetacnstr=0.0d0
4704 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4705       do i=1,ntheta_constr
4706         itheta=itheta_constr(i)
4707         thetiii=theta(itheta)
4708         difi=pinorm(thetiii-theta_constr0(i))
4709         if (difi.gt.theta_drange(i)) then
4710           difi=difi-theta_drange(i)
4711           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4712           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4713      &    +for_thet_constr(i)*difi**3
4714         else if (difi.lt.-drange(i)) then
4715           difi=difi+drange(i)
4716           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4717           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4718      &    +for_thet_constr(i)*difi**3
4719         else
4720           difi=0.0
4721         endif
4722 C       if (energy_dec) then
4723 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4724 C     &    i,itheta,rad2deg*thetiii,
4725 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4726 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4727 C     &    gloc(itheta+nphi-2,icg)
4728 C        endif
4729       enddo
4730       return
4731       end
4732
4733 #endif
4734 #ifdef CRYST_SC
4735 c-----------------------------------------------------------------------------
4736       subroutine esc(escloc)
4737 C Calculate the local energy of a side chain and its derivatives in the
4738 C corresponding virtual-bond valence angles THETA and the spherical angles
4739 C ALPHA and OMEGA.
4740       implicit real*8 (a-h,o-z)
4741       include 'DIMENSIONS'
4742       include 'DIMENSIONS.ZSCOPT'
4743       include 'COMMON.GEO'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.VAR'
4746       include 'COMMON.INTERACT'
4747       include 'COMMON.DERIV'
4748       include 'COMMON.CHAIN'
4749       include 'COMMON.IOUNITS'
4750       include 'COMMON.NAMES'
4751       include 'COMMON.FFIELD'
4752       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4753      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4754       common /sccalc/ time11,time12,time112,theti,it,nlobit
4755       delta=0.02d0*pi
4756       escloc=0.0D0
4757 C      write (iout,*) 'ESC'
4758       do i=loc_start,loc_end
4759         it=itype(i)
4760         if (it.eq.ntyp1) cycle
4761         if (it.eq.10) goto 1
4762         nlobit=nlob(iabs(it))
4763 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4764 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4765         theti=theta(i+1)-pipol
4766         x(1)=dtan(theti)
4767         x(2)=alph(i)
4768         x(3)=omeg(i)
4769 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4770
4771         if (x(2).gt.pi-delta) then
4772           xtemp(1)=x(1)
4773           xtemp(2)=pi-delta
4774           xtemp(3)=x(3)
4775           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4776           xtemp(2)=pi
4777           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4778           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4779      &        escloci,dersc(2))
4780           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4781      &        ddersc0(1),dersc(1))
4782           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4783      &        ddersc0(3),dersc(3))
4784           xtemp(2)=pi-delta
4785           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4786           xtemp(2)=pi
4787           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4788           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4789      &            dersc0(2),esclocbi,dersc02)
4790           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4791      &            dersc12,dersc01)
4792           call splinthet(x(2),0.5d0*delta,ss,ssd)
4793           dersc0(1)=dersc01
4794           dersc0(2)=dersc02
4795           dersc0(3)=0.0d0
4796           do k=1,3
4797             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4798           enddo
4799           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4800           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4801      &             esclocbi,ss,ssd
4802           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4803 c         escloci=esclocbi
4804 c         write (iout,*) escloci
4805         else if (x(2).lt.delta) then
4806           xtemp(1)=x(1)
4807           xtemp(2)=delta
4808           xtemp(3)=x(3)
4809           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4810           xtemp(2)=0.0d0
4811           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4812           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4813      &        escloci,dersc(2))
4814           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4815      &        ddersc0(1),dersc(1))
4816           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4817      &        ddersc0(3),dersc(3))
4818           xtemp(2)=delta
4819           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4820           xtemp(2)=0.0d0
4821           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4822           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4823      &            dersc0(2),esclocbi,dersc02)
4824           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4825      &            dersc12,dersc01)
4826           dersc0(1)=dersc01
4827           dersc0(2)=dersc02
4828           dersc0(3)=0.0d0
4829           call splinthet(x(2),0.5d0*delta,ss,ssd)
4830           do k=1,3
4831             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4832           enddo
4833           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4834 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4835 c     &             esclocbi,ss,ssd
4836           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4837 C         write (iout,*) 'i=',i, escloci
4838         else
4839           call enesc(x,escloci,dersc,ddummy,.false.)
4840         endif
4841
4842         escloc=escloc+escloci
4843 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4844             write (iout,'(a6,i5,0pf7.3)')
4845      &     'escloc',i,escloci
4846
4847         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4848      &   wscloc*dersc(1)
4849         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4850         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4851     1   continue
4852       enddo
4853       return
4854       end
4855 C---------------------------------------------------------------------------
4856       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4857       implicit real*8 (a-h,o-z)
4858       include 'DIMENSIONS'
4859       include 'COMMON.GEO'
4860       include 'COMMON.LOCAL'
4861       include 'COMMON.IOUNITS'
4862       common /sccalc/ time11,time12,time112,theti,it,nlobit
4863       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4864       double precision contr(maxlob,-1:1)
4865       logical mixed
4866 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4867         escloc_i=0.0D0
4868         do j=1,3
4869           dersc(j)=0.0D0
4870           if (mixed) ddersc(j)=0.0d0
4871         enddo
4872         x3=x(3)
4873
4874 C Because of periodicity of the dependence of the SC energy in omega we have
4875 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4876 C To avoid underflows, first compute & store the exponents.
4877
4878         do iii=-1,1
4879
4880           x(3)=x3+iii*dwapi
4881
4882           do j=1,nlobit
4883             do k=1,3
4884               z(k)=x(k)-censc(k,j,it)
4885             enddo
4886             do k=1,3
4887               Axk=0.0D0
4888               do l=1,3
4889                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4890               enddo
4891               Ax(k,j,iii)=Axk
4892             enddo
4893             expfac=0.0D0
4894             do k=1,3
4895               expfac=expfac+Ax(k,j,iii)*z(k)
4896             enddo
4897             contr(j,iii)=expfac
4898           enddo ! j
4899
4900         enddo ! iii
4901
4902         x(3)=x3
4903 C As in the case of ebend, we want to avoid underflows in exponentiation and
4904 C subsequent NaNs and INFs in energy calculation.
4905 C Find the largest exponent
4906         emin=contr(1,-1)
4907         do iii=-1,1
4908           do j=1,nlobit
4909             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4910           enddo
4911         enddo
4912         emin=0.5D0*emin
4913 cd      print *,'it=',it,' emin=',emin
4914
4915 C Compute the contribution to SC energy and derivatives
4916         do iii=-1,1
4917
4918           do j=1,nlobit
4919             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4920 cd          print *,'j=',j,' expfac=',expfac
4921             escloc_i=escloc_i+expfac
4922             do k=1,3
4923               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4924             enddo
4925             if (mixed) then
4926               do k=1,3,2
4927                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4928      &            +gaussc(k,2,j,it))*expfac
4929               enddo
4930             endif
4931           enddo
4932
4933         enddo ! iii
4934
4935         dersc(1)=dersc(1)/cos(theti)**2
4936         ddersc(1)=ddersc(1)/cos(theti)**2
4937         ddersc(3)=ddersc(3)
4938
4939         escloci=-(dlog(escloc_i)-emin)
4940         do j=1,3
4941           dersc(j)=dersc(j)/escloc_i
4942         enddo
4943         if (mixed) then
4944           do j=1,3,2
4945             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4946           enddo
4947         endif
4948       return
4949       end
4950 C------------------------------------------------------------------------------
4951       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4952       implicit real*8 (a-h,o-z)
4953       include 'DIMENSIONS'
4954       include 'COMMON.GEO'
4955       include 'COMMON.LOCAL'
4956       include 'COMMON.IOUNITS'
4957       common /sccalc/ time11,time12,time112,theti,it,nlobit
4958       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4959       double precision contr(maxlob)
4960       logical mixed
4961
4962       escloc_i=0.0D0
4963
4964       do j=1,3
4965         dersc(j)=0.0D0
4966       enddo
4967
4968       do j=1,nlobit
4969         do k=1,2
4970           z(k)=x(k)-censc(k,j,it)
4971         enddo
4972         z(3)=dwapi
4973         do k=1,3
4974           Axk=0.0D0
4975           do l=1,3
4976             Axk=Axk+gaussc(l,k,j,it)*z(l)
4977           enddo
4978           Ax(k,j)=Axk
4979         enddo
4980         expfac=0.0D0
4981         do k=1,3
4982           expfac=expfac+Ax(k,j)*z(k)
4983         enddo
4984         contr(j)=expfac
4985       enddo ! j
4986
4987 C As in the case of ebend, we want to avoid underflows in exponentiation and
4988 C subsequent NaNs and INFs in energy calculation.
4989 C Find the largest exponent
4990       emin=contr(1)
4991       do j=1,nlobit
4992         if (emin.gt.contr(j)) emin=contr(j)
4993       enddo
4994       emin=0.5D0*emin
4995
4996 C Compute the contribution to SC energy and derivatives
4997
4998       dersc12=0.0d0
4999       do j=1,nlobit
5000         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5001         escloc_i=escloc_i+expfac
5002         do k=1,2
5003           dersc(k)=dersc(k)+Ax(k,j)*expfac
5004         enddo
5005         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5006      &            +gaussc(1,2,j,it))*expfac
5007         dersc(3)=0.0d0
5008       enddo
5009
5010       dersc(1)=dersc(1)/cos(theti)**2
5011       dersc12=dersc12/cos(theti)**2
5012       escloci=-(dlog(escloc_i)-emin)
5013       do j=1,2
5014         dersc(j)=dersc(j)/escloc_i
5015       enddo
5016       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5017       return
5018       end
5019 #else
5020 c----------------------------------------------------------------------------------
5021       subroutine esc(escloc)
5022 C Calculate the local energy of a side chain and its derivatives in the
5023 C corresponding virtual-bond valence angles THETA and the spherical angles
5024 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5025 C added by Urszula Kozlowska. 07/11/2007
5026 C
5027       implicit real*8 (a-h,o-z)
5028       include 'DIMENSIONS'
5029       include 'DIMENSIONS.ZSCOPT'
5030       include 'DIMENSIONS.FREE'
5031       include 'COMMON.GEO'
5032       include 'COMMON.LOCAL'
5033       include 'COMMON.VAR'
5034       include 'COMMON.SCROT'
5035       include 'COMMON.INTERACT'
5036       include 'COMMON.DERIV'
5037       include 'COMMON.CHAIN'
5038       include 'COMMON.IOUNITS'
5039       include 'COMMON.NAMES'
5040       include 'COMMON.FFIELD'
5041       include 'COMMON.CONTROL'
5042       include 'COMMON.VECTORS'
5043       double precision x_prime(3),y_prime(3),z_prime(3)
5044      &    , sumene,dsc_i,dp2_i,x(65),
5045      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5046      &    de_dxx,de_dyy,de_dzz,de_dt
5047       double precision s1_t,s1_6_t,s2_t,s2_6_t
5048       double precision
5049      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5050      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5051      & dt_dCi(3),dt_dCi1(3)
5052       common /sccalc/ time11,time12,time112,theti,it,nlobit
5053       delta=0.02d0*pi
5054       escloc=0.0D0
5055       do i=loc_start,loc_end
5056         if (itype(i).eq.ntyp1) cycle
5057         costtab(i+1) =dcos(theta(i+1))
5058         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5059         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5060         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5061         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5062         cosfac=dsqrt(cosfac2)
5063         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5064         sinfac=dsqrt(sinfac2)
5065         it=iabs(itype(i))
5066         if (it.eq.10) goto 1
5067 c
5068 C  Compute the axes of tghe local cartesian coordinates system; store in
5069 c   x_prime, y_prime and z_prime
5070 c
5071         do j=1,3
5072           x_prime(j) = 0.00
5073           y_prime(j) = 0.00
5074           z_prime(j) = 0.00
5075         enddo
5076 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5077 C     &   dc_norm(3,i+nres)
5078         do j = 1,3
5079           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5080           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5081         enddo
5082         do j = 1,3
5083           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5084         enddo
5085 c       write (2,*) "i",i
5086 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5087 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5088 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5089 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5090 c      & " xy",scalar(x_prime(1),y_prime(1)),
5091 c      & " xz",scalar(x_prime(1),z_prime(1)),
5092 c      & " yy",scalar(y_prime(1),y_prime(1)),
5093 c      & " yz",scalar(y_prime(1),z_prime(1)),
5094 c      & " zz",scalar(z_prime(1),z_prime(1))
5095 c
5096 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5097 C to local coordinate system. Store in xx, yy, zz.
5098 c
5099         xx=0.0d0
5100         yy=0.0d0
5101         zz=0.0d0
5102         do j = 1,3
5103           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5104           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5105           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5106         enddo
5107
5108         xxtab(i)=xx
5109         yytab(i)=yy
5110         zztab(i)=zz
5111 C
5112 C Compute the energy of the ith side cbain
5113 C
5114 c        write (2,*) "xx",xx," yy",yy," zz",zz
5115         it=iabs(itype(i))
5116         do j = 1,65
5117           x(j) = sc_parmin(j,it)
5118         enddo
5119 #ifdef CHECK_COORD
5120 Cc diagnostics - remove later
5121         xx1 = dcos(alph(2))
5122         yy1 = dsin(alph(2))*dcos(omeg(2))
5123         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5124         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5125      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5126      &    xx1,yy1,zz1
5127 C,"  --- ", xx_w,yy_w,zz_w
5128 c end diagnostics
5129 #endif
5130         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5131      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5132      &   + x(10)*yy*zz
5133         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5134      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5135      & + x(20)*yy*zz
5136         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5137      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5138      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5139      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5140      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5141      &  +x(40)*xx*yy*zz
5142         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5143      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5144      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5145      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5146      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5147      &  +x(60)*xx*yy*zz
5148         dsc_i   = 0.743d0+x(61)
5149         dp2_i   = 1.9d0+x(62)
5150         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5151      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5152         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5153      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5154         s1=(1+x(63))/(0.1d0 + dscp1)
5155         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5156         s2=(1+x(65))/(0.1d0 + dscp2)
5157         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5158         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5159      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5160 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5161 c     &   sumene4,
5162 c     &   dscp1,dscp2,sumene
5163 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5164         escloc = escloc + sumene
5165 c        write (2,*) "escloc",escloc
5166 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5167 c     &  zz,xx,yy
5168         if (.not. calc_grad) goto 1
5169 #ifdef DEBUG
5170 C
5171 C This section to check the numerical derivatives of the energy of ith side
5172 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5173 C #define DEBUG in the code to turn it on.
5174 C
5175         write (2,*) "sumene               =",sumene
5176         aincr=1.0d-7
5177         xxsave=xx
5178         xx=xx+aincr
5179         write (2,*) xx,yy,zz
5180         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5181         de_dxx_num=(sumenep-sumene)/aincr
5182         xx=xxsave
5183         write (2,*) "xx+ sumene from enesc=",sumenep
5184         yysave=yy
5185         yy=yy+aincr
5186         write (2,*) xx,yy,zz
5187         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5188         de_dyy_num=(sumenep-sumene)/aincr
5189         yy=yysave
5190         write (2,*) "yy+ sumene from enesc=",sumenep
5191         zzsave=zz
5192         zz=zz+aincr
5193         write (2,*) xx,yy,zz
5194         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5195         de_dzz_num=(sumenep-sumene)/aincr
5196         zz=zzsave
5197         write (2,*) "zz+ sumene from enesc=",sumenep
5198         costsave=cost2tab(i+1)
5199         sintsave=sint2tab(i+1)
5200         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5201         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5202         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5203         de_dt_num=(sumenep-sumene)/aincr
5204         write (2,*) " t+ sumene from enesc=",sumenep
5205         cost2tab(i+1)=costsave
5206         sint2tab(i+1)=sintsave
5207 C End of diagnostics section.
5208 #endif
5209 C
5210 C Compute the gradient of esc
5211 C
5212         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5213         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5214         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5215         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5216         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5217         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5218         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5219         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5220         pom1=(sumene3*sint2tab(i+1)+sumene1)
5221      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5222         pom2=(sumene4*cost2tab(i+1)+sumene2)
5223      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5224         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5225         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5226      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5227      &  +x(40)*yy*zz
5228         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5229         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5230      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5231      &  +x(60)*yy*zz
5232         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5233      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5234      &        +(pom1+pom2)*pom_dx
5235 #ifdef DEBUG
5236         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5237 #endif
5238 C
5239         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5240         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5241      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5242      &  +x(40)*xx*zz
5243         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5244         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5245      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5246      &  +x(59)*zz**2 +x(60)*xx*zz
5247         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5248      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5249      &        +(pom1-pom2)*pom_dy
5250 #ifdef DEBUG
5251         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5252 #endif
5253 C
5254         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5255      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5256      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5257      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5258      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5259      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5260      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5261      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5262 #ifdef DEBUG
5263         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5264 #endif
5265 C
5266         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5267      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5268      &  +pom1*pom_dt1+pom2*pom_dt2
5269 #ifdef DEBUG
5270         write(2,*), "de_dt = ", de_dt,de_dt_num
5271 #endif
5272 c
5273 C
5274        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5275        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5276        cosfac2xx=cosfac2*xx
5277        sinfac2yy=sinfac2*yy
5278        do k = 1,3
5279          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5280      &      vbld_inv(i+1)
5281          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5282      &      vbld_inv(i)
5283          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5284          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5285 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5286 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5287 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5288 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5289          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5290          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5291          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5292          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5293          dZZ_Ci1(k)=0.0d0
5294          dZZ_Ci(k)=0.0d0
5295          do j=1,3
5296            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5297      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5298            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5299      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5300          enddo
5301
5302          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5303          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5304          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5305 c
5306          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5307          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5308        enddo
5309
5310        do k=1,3
5311          dXX_Ctab(k,i)=dXX_Ci(k)
5312          dXX_C1tab(k,i)=dXX_Ci1(k)
5313          dYY_Ctab(k,i)=dYY_Ci(k)
5314          dYY_C1tab(k,i)=dYY_Ci1(k)
5315          dZZ_Ctab(k,i)=dZZ_Ci(k)
5316          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5317          dXX_XYZtab(k,i)=dXX_XYZ(k)
5318          dYY_XYZtab(k,i)=dYY_XYZ(k)
5319          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5320        enddo
5321
5322        do k = 1,3
5323 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5324 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5325 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5326 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5327 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5328 c     &    dt_dci(k)
5329 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5330 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5331          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5332      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5333          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5334      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5335          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5336      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5337        enddo
5338 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5339 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5340
5341 C to check gradient call subroutine check_grad
5342
5343     1 continue
5344       enddo
5345       return
5346       end
5347 #endif
5348 c------------------------------------------------------------------------------
5349       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5350 C
5351 C This procedure calculates two-body contact function g(rij) and its derivative:
5352 C
5353 C           eps0ij                                     !       x < -1
5354 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5355 C            0                                         !       x > 1
5356 C
5357 C where x=(rij-r0ij)/delta
5358 C
5359 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5360 C
5361       implicit none
5362       double precision rij,r0ij,eps0ij,fcont,fprimcont
5363       double precision x,x2,x4,delta
5364 c     delta=0.02D0*r0ij
5365 c      delta=0.2D0*r0ij
5366       x=(rij-r0ij)/delta
5367       if (x.lt.-1.0D0) then
5368         fcont=eps0ij
5369         fprimcont=0.0D0
5370       else if (x.le.1.0D0) then
5371         x2=x*x
5372         x4=x2*x2
5373         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5374         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5375       else
5376         fcont=0.0D0
5377         fprimcont=0.0D0
5378       endif
5379       return
5380       end
5381 c------------------------------------------------------------------------------
5382       subroutine splinthet(theti,delta,ss,ssder)
5383       implicit real*8 (a-h,o-z)
5384       include 'DIMENSIONS'
5385       include 'DIMENSIONS.ZSCOPT'
5386       include 'COMMON.VAR'
5387       include 'COMMON.GEO'
5388       thetup=pi-delta
5389       thetlow=delta
5390       if (theti.gt.pipol) then
5391         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5392       else
5393         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5394         ssder=-ssder
5395       endif
5396       return
5397       end
5398 c------------------------------------------------------------------------------
5399       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5400       implicit none
5401       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5402       double precision ksi,ksi2,ksi3,a1,a2,a3
5403       a1=fprim0*delta/(f1-f0)
5404       a2=3.0d0-2.0d0*a1
5405       a3=a1-2.0d0
5406       ksi=(x-x0)/delta
5407       ksi2=ksi*ksi
5408       ksi3=ksi2*ksi
5409       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5410       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5411       return
5412       end
5413 c------------------------------------------------------------------------------
5414       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5415       implicit none
5416       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5417       double precision ksi,ksi2,ksi3,a1,a2,a3
5418       ksi=(x-x0)/delta
5419       ksi2=ksi*ksi
5420       ksi3=ksi2*ksi
5421       a1=fprim0x*delta
5422       a2=3*(f1x-f0x)-2*fprim0x*delta
5423       a3=fprim0x*delta-2*(f1x-f0x)
5424       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5425       return
5426       end
5427 C-----------------------------------------------------------------------------
5428 #ifdef CRYST_TOR
5429 C-----------------------------------------------------------------------------
5430       subroutine etor(etors,edihcnstr,fact)
5431       implicit real*8 (a-h,o-z)
5432       include 'DIMENSIONS'
5433       include 'DIMENSIONS.ZSCOPT'
5434       include 'COMMON.VAR'
5435       include 'COMMON.GEO'
5436       include 'COMMON.LOCAL'
5437       include 'COMMON.TORSION'
5438       include 'COMMON.INTERACT'
5439       include 'COMMON.DERIV'
5440       include 'COMMON.CHAIN'
5441       include 'COMMON.NAMES'
5442       include 'COMMON.IOUNITS'
5443       include 'COMMON.FFIELD'
5444       include 'COMMON.TORCNSTR'
5445       logical lprn
5446 C Set lprn=.true. for debugging
5447       lprn=.false.
5448 c      lprn=.true.
5449       etors=0.0D0
5450       do i=iphi_start,iphi_end
5451         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5452      &      .or. itype(i).eq.ntyp1) cycle
5453         itori=itortyp(itype(i-2))
5454         itori1=itortyp(itype(i-1))
5455         phii=phi(i)
5456         gloci=0.0D0
5457 C Proline-Proline pair is a special case...
5458         if (itori.eq.3 .and. itori1.eq.3) then
5459           if (phii.gt.-dwapi3) then
5460             cosphi=dcos(3*phii)
5461             fac=1.0D0/(1.0D0-cosphi)
5462             etorsi=v1(1,3,3)*fac
5463             etorsi=etorsi+etorsi
5464             etors=etors+etorsi-v1(1,3,3)
5465             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5466           endif
5467           do j=1,3
5468             v1ij=v1(j+1,itori,itori1)
5469             v2ij=v2(j+1,itori,itori1)
5470             cosphi=dcos(j*phii)
5471             sinphi=dsin(j*phii)
5472             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5473             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5474           enddo
5475         else
5476           do j=1,nterm_old
5477             v1ij=v1(j,itori,itori1)
5478             v2ij=v2(j,itori,itori1)
5479             cosphi=dcos(j*phii)
5480             sinphi=dsin(j*phii)
5481             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5482             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5483           enddo
5484         endif
5485         if (lprn)
5486      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5487      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5488      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5489         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5490 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5491       enddo
5492 ! 6/20/98 - dihedral angle constraints
5493       edihcnstr=0.0d0
5494       do i=1,ndih_constr
5495         itori=idih_constr(i)
5496         phii=phi(itori)
5497         difi=phii-phi0(i)
5498         if (difi.gt.drange(i)) then
5499           difi=difi-drange(i)
5500           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5501           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5502         else if (difi.lt.-drange(i)) then
5503           difi=difi+drange(i)
5504           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5505           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5506         endif
5507 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5508 C     &    i,itori,rad2deg*phii,
5509 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5510       enddo
5511 !      write (iout,*) 'edihcnstr',edihcnstr
5512       return
5513       end
5514 c------------------------------------------------------------------------------
5515 #else
5516       subroutine etor(etors,edihcnstr,fact)
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'DIMENSIONS.ZSCOPT'
5520       include 'COMMON.VAR'
5521       include 'COMMON.GEO'
5522       include 'COMMON.LOCAL'
5523       include 'COMMON.TORSION'
5524       include 'COMMON.INTERACT'
5525       include 'COMMON.DERIV'
5526       include 'COMMON.CHAIN'
5527       include 'COMMON.NAMES'
5528       include 'COMMON.IOUNITS'
5529       include 'COMMON.FFIELD'
5530       include 'COMMON.TORCNSTR'
5531       logical lprn
5532 C Set lprn=.true. for debugging
5533       lprn=.false.
5534 c      lprn=.true.
5535       etors=0.0D0
5536       do i=iphi_start,iphi_end
5537         if (i.le.2) cycle
5538         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5539      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5540 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5541 C     &       .or. itype(i).eq.ntyp1) cycle
5542         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5543          if (iabs(itype(i)).eq.20) then
5544          iblock=2
5545          else
5546          iblock=1
5547          endif
5548         itori=itortyp(itype(i-2))
5549         itori1=itortyp(itype(i-1))
5550         phii=phi(i)
5551         gloci=0.0D0
5552 C Regular cosine and sine terms
5553         do j=1,nterm(itori,itori1,iblock)
5554           v1ij=v1(j,itori,itori1,iblock)
5555           v2ij=v2(j,itori,itori1,iblock)
5556           cosphi=dcos(j*phii)
5557           sinphi=dsin(j*phii)
5558           etors=etors+v1ij*cosphi+v2ij*sinphi
5559           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5560         enddo
5561 C Lorentz terms
5562 C                         v1
5563 C  E = SUM ----------------------------------- - v1
5564 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5565 C
5566         cosphi=dcos(0.5d0*phii)
5567         sinphi=dsin(0.5d0*phii)
5568         do j=1,nlor(itori,itori1,iblock)
5569           vl1ij=vlor1(j,itori,itori1)
5570           vl2ij=vlor2(j,itori,itori1)
5571           vl3ij=vlor3(j,itori,itori1)
5572           pom=vl2ij*cosphi+vl3ij*sinphi
5573           pom1=1.0d0/(pom*pom+1.0d0)
5574           etors=etors+vl1ij*pom1
5575 c          if (energy_dec) etors_ii=etors_ii+
5576 c     &                vl1ij*pom1
5577           pom=-pom*pom1*pom1
5578           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5579         enddo
5580 C Subtract the constant term
5581         etors=etors-v0(itori,itori1,iblock)
5582         if (lprn)
5583      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5584      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5585      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5586         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5587 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5588  1215   continue
5589       enddo
5590 ! 6/20/98 - dihedral angle constraints
5591       edihcnstr=0.0d0
5592       do i=1,ndih_constr
5593         itori=idih_constr(i)
5594         phii=phi(itori)
5595         difi=pinorm(phii-phi0(i))
5596         edihi=0.0d0
5597         if (difi.gt.drange(i)) then
5598           difi=difi-drange(i)
5599           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5600           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5601           edihi=0.25d0*ftors(i)*difi**4
5602         else if (difi.lt.-drange(i)) then
5603           difi=difi+drange(i)
5604           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5605           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5606           edihi=0.25d0*ftors(i)*difi**4
5607         else
5608           difi=0.0d0
5609         endif
5610         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5611      &    i,itori,rad2deg*phii,
5612      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5613 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5614 c     &    drange(i),edihi
5615 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5616 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5617       enddo
5618 !      write (iout,*) 'edihcnstr',edihcnstr
5619       return
5620       end
5621 c----------------------------------------------------------------------------
5622       subroutine etor_d(etors_d,fact2)
5623 C 6/23/01 Compute double torsional energy
5624       implicit real*8 (a-h,o-z)
5625       include 'DIMENSIONS'
5626       include 'DIMENSIONS.ZSCOPT'
5627       include 'COMMON.VAR'
5628       include 'COMMON.GEO'
5629       include 'COMMON.LOCAL'
5630       include 'COMMON.TORSION'
5631       include 'COMMON.INTERACT'
5632       include 'COMMON.DERIV'
5633       include 'COMMON.CHAIN'
5634       include 'COMMON.NAMES'
5635       include 'COMMON.IOUNITS'
5636       include 'COMMON.FFIELD'
5637       include 'COMMON.TORCNSTR'
5638       logical lprn
5639 C Set lprn=.true. for debugging
5640       lprn=.false.
5641 c     lprn=.true.
5642       etors_d=0.0D0
5643       do i=iphi_start,iphi_end-1
5644         if (i.le.3) cycle
5645 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5646 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5647          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5648      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5649      &  (itype(i+1).eq.ntyp1)) cycle
5650         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5651      &     goto 1215
5652         itori=itortyp(itype(i-2))
5653         itori1=itortyp(itype(i-1))
5654         itori2=itortyp(itype(i))
5655         phii=phi(i)
5656         phii1=phi(i+1)
5657         gloci1=0.0D0
5658         gloci2=0.0D0
5659         iblock=1
5660         if (iabs(itype(i+1)).eq.20) iblock=2
5661 C Regular cosine and sine terms
5662         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5663           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5664           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5665           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5666           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5667           cosphi1=dcos(j*phii)
5668           sinphi1=dsin(j*phii)
5669           cosphi2=dcos(j*phii1)
5670           sinphi2=dsin(j*phii1)
5671           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5672      &     v2cij*cosphi2+v2sij*sinphi2
5673           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5674           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5675         enddo
5676         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5677           do l=1,k-1
5678             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5679             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5680             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5681             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5682             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5683             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5684             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5685             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5686             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5687      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5688             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5689      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5690             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5691      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5692           enddo
5693         enddo
5694         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5695         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5696  1215   continue
5697       enddo
5698       return
5699       end
5700 #endif
5701 c------------------------------------------------------------------------------
5702       subroutine eback_sc_corr(esccor)
5703 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5704 c        conformational states; temporarily implemented as differences
5705 c        between UNRES torsional potentials (dependent on three types of
5706 c        residues) and the torsional potentials dependent on all 20 types
5707 c        of residues computed from AM1 energy surfaces of terminally-blocked
5708 c        amino-acid residues.
5709       implicit real*8 (a-h,o-z)
5710       include 'DIMENSIONS'
5711       include 'DIMENSIONS.ZSCOPT'
5712       include 'DIMENSIONS.FREE'
5713       include 'COMMON.VAR'
5714       include 'COMMON.GEO'
5715       include 'COMMON.LOCAL'
5716       include 'COMMON.TORSION'
5717       include 'COMMON.SCCOR'
5718       include 'COMMON.INTERACT'
5719       include 'COMMON.DERIV'
5720       include 'COMMON.CHAIN'
5721       include 'COMMON.NAMES'
5722       include 'COMMON.IOUNITS'
5723       include 'COMMON.FFIELD'
5724       include 'COMMON.CONTROL'
5725       logical lprn
5726 C Set lprn=.true. for debugging
5727       lprn=.false.
5728 c      lprn=.true.
5729 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5730       esccor=0.0D0
5731       do i=itau_start,itau_end
5732         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5733         esccor_ii=0.0D0
5734         isccori=isccortyp(itype(i-2))
5735         isccori1=isccortyp(itype(i-1))
5736         phii=phi(i)
5737         do intertyp=1,3 !intertyp
5738 cc Added 09 May 2012 (Adasko)
5739 cc  Intertyp means interaction type of backbone mainchain correlation:
5740 c   1 = SC...Ca...Ca...Ca
5741 c   2 = Ca...Ca...Ca...SC
5742 c   3 = SC...Ca...Ca...SCi
5743         gloci=0.0D0
5744         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5745      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5746      &      (itype(i-1).eq.ntyp1)))
5747      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5748      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5749      &     .or.(itype(i).eq.ntyp1)))
5750      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5751      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5752      &      (itype(i-3).eq.ntyp1)))) cycle
5753         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5754         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5755      & cycle
5756        do j=1,nterm_sccor(isccori,isccori1)
5757           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5758           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5759           cosphi=dcos(j*tauangle(intertyp,i))
5760           sinphi=dsin(j*tauangle(intertyp,i))
5761            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5762            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5763          enddo
5764 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5765 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5766 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5767         if (lprn)
5768      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5769      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5770      &  (v1sccor(j,1,itori,itori1),j=1,6)
5771      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5772 c        gsccor_loc(i-3)=gloci
5773        enddo !intertyp
5774       enddo
5775       return
5776       end
5777 c------------------------------------------------------------------------------
5778       subroutine multibody(ecorr)
5779 C This subroutine calculates multi-body contributions to energy following
5780 C the idea of Skolnick et al. If side chains I and J make a contact and
5781 C at the same time side chains I+1 and J+1 make a contact, an extra
5782 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5783       implicit real*8 (a-h,o-z)
5784       include 'DIMENSIONS'
5785       include 'COMMON.IOUNITS'
5786       include 'COMMON.DERIV'
5787       include 'COMMON.INTERACT'
5788       include 'COMMON.CONTACTS'
5789       double precision gx(3),gx1(3)
5790       logical lprn
5791
5792 C Set lprn=.true. for debugging
5793       lprn=.false.
5794
5795       if (lprn) then
5796         write (iout,'(a)') 'Contact function values:'
5797         do i=nnt,nct-2
5798           write (iout,'(i2,20(1x,i2,f10.5))')
5799      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5800         enddo
5801       endif
5802       ecorr=0.0D0
5803       do i=nnt,nct
5804         do j=1,3
5805           gradcorr(j,i)=0.0D0
5806           gradxorr(j,i)=0.0D0
5807         enddo
5808       enddo
5809       do i=nnt,nct-2
5810
5811         DO ISHIFT = 3,4
5812
5813         i1=i+ishift
5814         num_conti=num_cont(i)
5815         num_conti1=num_cont(i1)
5816         do jj=1,num_conti
5817           j=jcont(jj,i)
5818           do kk=1,num_conti1
5819             j1=jcont(kk,i1)
5820             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5821 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5822 cd   &                   ' ishift=',ishift
5823 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5824 C The system gains extra energy.
5825               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5826             endif   ! j1==j+-ishift
5827           enddo     ! kk
5828         enddo       ! jj
5829
5830         ENDDO ! ISHIFT
5831
5832       enddo         ! i
5833       return
5834       end
5835 c------------------------------------------------------------------------------
5836       double precision function esccorr(i,j,k,l,jj,kk)
5837       implicit real*8 (a-h,o-z)
5838       include 'DIMENSIONS'
5839       include 'COMMON.IOUNITS'
5840       include 'COMMON.DERIV'
5841       include 'COMMON.INTERACT'
5842       include 'COMMON.CONTACTS'
5843       double precision gx(3),gx1(3)
5844       logical lprn
5845       lprn=.false.
5846       eij=facont(jj,i)
5847       ekl=facont(kk,k)
5848 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5849 C Calculate the multi-body contribution to energy.
5850 C Calculate multi-body contributions to the gradient.
5851 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5852 cd   & k,l,(gacont(m,kk,k),m=1,3)
5853       do m=1,3
5854         gx(m) =ekl*gacont(m,jj,i)
5855         gx1(m)=eij*gacont(m,kk,k)
5856         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5857         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5858         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5859         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5860       enddo
5861       do m=i,j-1
5862         do ll=1,3
5863           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5864         enddo
5865       enddo
5866       do m=k,l-1
5867         do ll=1,3
5868           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5869         enddo
5870       enddo
5871       esccorr=-eij*ekl
5872       return
5873       end
5874 c------------------------------------------------------------------------------
5875 #ifdef MPL
5876       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5877       implicit real*8 (a-h,o-z)
5878       include 'DIMENSIONS'
5879       integer dimen1,dimen2,atom,indx
5880       double precision buffer(dimen1,dimen2)
5881       double precision zapas
5882       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5883      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5884      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5885       num_kont=num_cont_hb(atom)
5886       do i=1,num_kont
5887         do k=1,7
5888           do j=1,3
5889             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5890           enddo ! j
5891         enddo ! k
5892         buffer(i,indx+22)=facont_hb(i,atom)
5893         buffer(i,indx+23)=ees0p(i,atom)
5894         buffer(i,indx+24)=ees0m(i,atom)
5895         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5896       enddo ! i
5897       buffer(1,indx+26)=dfloat(num_kont)
5898       return
5899       end
5900 c------------------------------------------------------------------------------
5901       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5902       implicit real*8 (a-h,o-z)
5903       include 'DIMENSIONS'
5904       integer dimen1,dimen2,atom,indx
5905       double precision buffer(dimen1,dimen2)
5906       double precision zapas
5907       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5908      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5909      &         ees0m(ntyp,maxres),
5910      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5911       num_kont=buffer(1,indx+26)
5912       num_kont_old=num_cont_hb(atom)
5913       num_cont_hb(atom)=num_kont+num_kont_old
5914       do i=1,num_kont
5915         ii=i+num_kont_old
5916         do k=1,7
5917           do j=1,3
5918             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5919           enddo ! j
5920         enddo ! k
5921         facont_hb(ii,atom)=buffer(i,indx+22)
5922         ees0p(ii,atom)=buffer(i,indx+23)
5923         ees0m(ii,atom)=buffer(i,indx+24)
5924         jcont_hb(ii,atom)=buffer(i,indx+25)
5925       enddo ! i
5926       return
5927       end
5928 c------------------------------------------------------------------------------
5929 #endif
5930       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5931 C This subroutine calculates multi-body contributions to hydrogen-bonding
5932       implicit real*8 (a-h,o-z)
5933       include 'DIMENSIONS'
5934       include 'DIMENSIONS.ZSCOPT'
5935       include 'COMMON.IOUNITS'
5936 #ifdef MPL
5937       include 'COMMON.INFO'
5938 #endif
5939       include 'COMMON.FFIELD'
5940       include 'COMMON.DERIV'
5941       include 'COMMON.INTERACT'
5942       include 'COMMON.CONTACTS'
5943 #ifdef MPL
5944       parameter (max_cont=maxconts)
5945       parameter (max_dim=2*(8*3+2))
5946       parameter (msglen1=max_cont*max_dim*4)
5947       parameter (msglen2=2*msglen1)
5948       integer source,CorrelType,CorrelID,Error
5949       double precision buffer(max_cont,max_dim)
5950 #endif
5951       double precision gx(3),gx1(3)
5952       logical lprn,ldone
5953
5954 C Set lprn=.true. for debugging
5955       lprn=.false.
5956 #ifdef MPL
5957       n_corr=0
5958       n_corr1=0
5959       if (fgProcs.le.1) goto 30
5960       if (lprn) then
5961         write (iout,'(a)') 'Contact function values:'
5962         do i=nnt,nct-2
5963           write (iout,'(2i3,50(1x,i2,f5.2))')
5964      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5965      &    j=1,num_cont_hb(i))
5966         enddo
5967       endif
5968 C Caution! Following code assumes that electrostatic interactions concerning
5969 C a given atom are split among at most two processors!
5970       CorrelType=477
5971       CorrelID=MyID+1
5972       ldone=.false.
5973       do i=1,max_cont
5974         do j=1,max_dim
5975           buffer(i,j)=0.0D0
5976         enddo
5977       enddo
5978       mm=mod(MyRank,2)
5979 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5980       if (mm) 20,20,10
5981    10 continue
5982 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5983       if (MyRank.gt.0) then
5984 C Send correlation contributions to the preceding processor
5985         msglen=msglen1
5986         nn=num_cont_hb(iatel_s)
5987         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5988 cd      write (iout,*) 'The BUFFER array:'
5989 cd      do i=1,nn
5990 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5991 cd      enddo
5992         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5993           msglen=msglen2
5994             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5995 C Clear the contacts of the atom passed to the neighboring processor
5996         nn=num_cont_hb(iatel_s+1)
5997 cd      do i=1,nn
5998 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5999 cd      enddo
6000             num_cont_hb(iatel_s)=0
6001         endif
6002 cd      write (iout,*) 'Processor ',MyID,MyRank,
6003 cd   & ' is sending correlation contribution to processor',MyID-1,
6004 cd   & ' msglen=',msglen
6005 cd      write (*,*) 'Processor ',MyID,MyRank,
6006 cd   & ' is sending correlation contribution to processor',MyID-1,
6007 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6008         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6009 cd      write (iout,*) 'Processor ',MyID,
6010 cd   & ' has sent correlation contribution to processor',MyID-1,
6011 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6012 cd      write (*,*) 'Processor ',MyID,
6013 cd   & ' has sent correlation contribution to processor',MyID-1,
6014 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6015         msglen=msglen1
6016       endif ! (MyRank.gt.0)
6017       if (ldone) goto 30
6018       ldone=.true.
6019    20 continue
6020 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6021       if (MyRank.lt.fgProcs-1) then
6022 C Receive correlation contributions from the next processor
6023         msglen=msglen1
6024         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6025 cd      write (iout,*) 'Processor',MyID,
6026 cd   & ' is receiving correlation contribution from processor',MyID+1,
6027 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6028 cd      write (*,*) 'Processor',MyID,
6029 cd   & ' is receiving correlation contribution from processor',MyID+1,
6030 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6031         nbytes=-1
6032         do while (nbytes.le.0)
6033           call mp_probe(MyID+1,CorrelType,nbytes)
6034         enddo
6035 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6036         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6037 cd      write (iout,*) 'Processor',MyID,
6038 cd   & ' has received correlation contribution from processor',MyID+1,
6039 cd   & ' msglen=',msglen,' nbytes=',nbytes
6040 cd      write (iout,*) 'The received BUFFER array:'
6041 cd      do i=1,max_cont
6042 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6043 cd      enddo
6044         if (msglen.eq.msglen1) then
6045           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6046         else if (msglen.eq.msglen2)  then
6047           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6048           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6049         else
6050           write (iout,*)
6051      & 'ERROR!!!! message length changed while processing correlations.'
6052           write (*,*)
6053      & 'ERROR!!!! message length changed while processing correlations.'
6054           call mp_stopall(Error)
6055         endif ! msglen.eq.msglen1
6056       endif ! MyRank.lt.fgProcs-1
6057       if (ldone) goto 30
6058       ldone=.true.
6059       goto 10
6060    30 continue
6061 #endif
6062       if (lprn) then
6063         write (iout,'(a)') 'Contact function values:'
6064         do i=nnt,nct-2
6065           write (iout,'(2i3,50(1x,i2,f5.2))')
6066      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6067      &    j=1,num_cont_hb(i))
6068         enddo
6069       endif
6070       ecorr=0.0D0
6071 C Remove the loop below after debugging !!!
6072       do i=nnt,nct
6073         do j=1,3
6074           gradcorr(j,i)=0.0D0
6075           gradxorr(j,i)=0.0D0
6076         enddo
6077       enddo
6078 C Calculate the local-electrostatic correlation terms
6079       do i=iatel_s,iatel_e+1
6080         i1=i+1
6081         num_conti=num_cont_hb(i)
6082         num_conti1=num_cont_hb(i+1)
6083         do jj=1,num_conti
6084           j=jcont_hb(jj,i)
6085           do kk=1,num_conti1
6086             j1=jcont_hb(kk,i1)
6087 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6088 c     &         ' jj=',jj,' kk=',kk
6089             if (j1.eq.j+1 .or. j1.eq.j-1) then
6090 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6091 C The system gains extra energy.
6092               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6093               n_corr=n_corr+1
6094             else if (j1.eq.j) then
6095 C Contacts I-J and I-(J+1) occur simultaneously.
6096 C The system loses extra energy.
6097 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6098             endif
6099           enddo ! kk
6100           do kk=1,num_conti
6101             j1=jcont_hb(kk,i)
6102 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6103 c    &         ' jj=',jj,' kk=',kk
6104             if (j1.eq.j+1) then
6105 C Contacts I-J and (I+1)-J occur simultaneously.
6106 C The system loses extra energy.
6107 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6108             endif ! j1==j+1
6109           enddo ! kk
6110         enddo ! jj
6111       enddo ! i
6112       return
6113       end
6114 c------------------------------------------------------------------------------
6115       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6116      &  n_corr1)
6117 C This subroutine calculates multi-body contributions to hydrogen-bonding
6118       implicit real*8 (a-h,o-z)
6119       include 'DIMENSIONS'
6120       include 'DIMENSIONS.ZSCOPT'
6121       include 'COMMON.IOUNITS'
6122 #ifdef MPL
6123       include 'COMMON.INFO'
6124 #endif
6125       include 'COMMON.FFIELD'
6126       include 'COMMON.DERIV'
6127       include 'COMMON.INTERACT'
6128       include 'COMMON.CONTACTS'
6129 #ifdef MPL
6130       parameter (max_cont=maxconts)
6131       parameter (max_dim=2*(8*3+2))
6132       parameter (msglen1=max_cont*max_dim*4)
6133       parameter (msglen2=2*msglen1)
6134       integer source,CorrelType,CorrelID,Error
6135       double precision buffer(max_cont,max_dim)
6136 #endif
6137       double precision gx(3),gx1(3)
6138       logical lprn,ldone
6139
6140 C Set lprn=.true. for debugging
6141       lprn=.false.
6142       eturn6=0.0d0
6143       ecorr6=0.0d0
6144 #ifdef MPL
6145       n_corr=0
6146       n_corr1=0
6147       if (fgProcs.le.1) goto 30
6148       if (lprn) then
6149         write (iout,'(a)') 'Contact function values:'
6150         do i=nnt,nct-2
6151           write (iout,'(2i3,50(1x,i2,f5.2))')
6152      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6153      &    j=1,num_cont_hb(i))
6154         enddo
6155       endif
6156 C Caution! Following code assumes that electrostatic interactions concerning
6157 C a given atom are split among at most two processors!
6158       CorrelType=477
6159       CorrelID=MyID+1
6160       ldone=.false.
6161       do i=1,max_cont
6162         do j=1,max_dim
6163           buffer(i,j)=0.0D0
6164         enddo
6165       enddo
6166       mm=mod(MyRank,2)
6167 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6168       if (mm) 20,20,10
6169    10 continue
6170 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6171       if (MyRank.gt.0) then
6172 C Send correlation contributions to the preceding processor
6173         msglen=msglen1
6174         nn=num_cont_hb(iatel_s)
6175         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6176 cd      write (iout,*) 'The BUFFER array:'
6177 cd      do i=1,nn
6178 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6179 cd      enddo
6180         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6181           msglen=msglen2
6182             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6183 C Clear the contacts of the atom passed to the neighboring processor
6184         nn=num_cont_hb(iatel_s+1)
6185 cd      do i=1,nn
6186 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6187 cd      enddo
6188             num_cont_hb(iatel_s)=0
6189         endif
6190 cd      write (iout,*) 'Processor ',MyID,MyRank,
6191 cd   & ' is sending correlation contribution to processor',MyID-1,
6192 cd   & ' msglen=',msglen
6193 cd      write (*,*) 'Processor ',MyID,MyRank,
6194 cd   & ' is sending correlation contribution to processor',MyID-1,
6195 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6196         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6197 cd      write (iout,*) 'Processor ',MyID,
6198 cd   & ' has sent correlation contribution to processor',MyID-1,
6199 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6200 cd      write (*,*) 'Processor ',MyID,
6201 cd   & ' has sent correlation contribution to processor',MyID-1,
6202 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6203         msglen=msglen1
6204       endif ! (MyRank.gt.0)
6205       if (ldone) goto 30
6206       ldone=.true.
6207    20 continue
6208 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6209       if (MyRank.lt.fgProcs-1) then
6210 C Receive correlation contributions from the next processor
6211         msglen=msglen1
6212         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6213 cd      write (iout,*) 'Processor',MyID,
6214 cd   & ' is receiving correlation contribution from processor',MyID+1,
6215 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6216 cd      write (*,*) 'Processor',MyID,
6217 cd   & ' is receiving correlation contribution from processor',MyID+1,
6218 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6219         nbytes=-1
6220         do while (nbytes.le.0)
6221           call mp_probe(MyID+1,CorrelType,nbytes)
6222         enddo
6223 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6224         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6225 cd      write (iout,*) 'Processor',MyID,
6226 cd   & ' has received correlation contribution from processor',MyID+1,
6227 cd   & ' msglen=',msglen,' nbytes=',nbytes
6228 cd      write (iout,*) 'The received BUFFER array:'
6229 cd      do i=1,max_cont
6230 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6231 cd      enddo
6232         if (msglen.eq.msglen1) then
6233           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6234         else if (msglen.eq.msglen2)  then
6235           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6236           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6237         else
6238           write (iout,*)
6239      & 'ERROR!!!! message length changed while processing correlations.'
6240           write (*,*)
6241      & 'ERROR!!!! message length changed while processing correlations.'
6242           call mp_stopall(Error)
6243         endif ! msglen.eq.msglen1
6244       endif ! MyRank.lt.fgProcs-1
6245       if (ldone) goto 30
6246       ldone=.true.
6247       goto 10
6248    30 continue
6249 #endif
6250       if (lprn) then
6251         write (iout,'(a)') 'Contact function values:'
6252         do i=nnt,nct-2
6253           write (iout,'(2i3,50(1x,i2,f5.2))')
6254      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6255      &    j=1,num_cont_hb(i))
6256         enddo
6257       endif
6258       ecorr=0.0D0
6259       ecorr5=0.0d0
6260       ecorr6=0.0d0
6261 C Remove the loop below after debugging !!!
6262       do i=nnt,nct
6263         do j=1,3
6264           gradcorr(j,i)=0.0D0
6265           gradxorr(j,i)=0.0D0
6266         enddo
6267       enddo
6268 C Calculate the dipole-dipole interaction energies
6269       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6270       do i=iatel_s,iatel_e+1
6271         num_conti=num_cont_hb(i)
6272         do jj=1,num_conti
6273           j=jcont_hb(jj,i)
6274           call dipole(i,j,jj)
6275         enddo
6276       enddo
6277       endif
6278 C Calculate the local-electrostatic correlation terms
6279       do i=iatel_s,iatel_e+1
6280         i1=i+1
6281         num_conti=num_cont_hb(i)
6282         num_conti1=num_cont_hb(i+1)
6283         do jj=1,num_conti
6284           j=jcont_hb(jj,i)
6285           do kk=1,num_conti1
6286             j1=jcont_hb(kk,i1)
6287 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6288 c     &         ' jj=',jj,' kk=',kk
6289             if (j1.eq.j+1 .or. j1.eq.j-1) then
6290 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6291 C The system gains extra energy.
6292               n_corr=n_corr+1
6293               sqd1=dsqrt(d_cont(jj,i))
6294               sqd2=dsqrt(d_cont(kk,i1))
6295               sred_geom = sqd1*sqd2
6296               IF (sred_geom.lt.cutoff_corr) THEN
6297                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6298      &            ekont,fprimcont)
6299 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6300 c     &         ' jj=',jj,' kk=',kk
6301                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6302                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6303                 do l=1,3
6304                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6305                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6306                 enddo
6307                 n_corr1=n_corr1+1
6308 cd               write (iout,*) 'sred_geom=',sred_geom,
6309 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6310                 call calc_eello(i,j,i+1,j1,jj,kk)
6311                 if (wcorr4.gt.0.0d0)
6312      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6313                 if (wcorr5.gt.0.0d0)
6314      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6315 c                print *,"wcorr5",ecorr5
6316 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6317 cd                write(2,*)'ijkl',i,j,i+1,j1
6318                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6319      &               .or. wturn6.eq.0.0d0))then
6320 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6321                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6322 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6323 cd     &            'ecorr6=',ecorr6
6324 cd                write (iout,'(4e15.5)') sred_geom,
6325 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6326 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6327 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6328                 else if (wturn6.gt.0.0d0
6329      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6330 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6331                   eturn6=eturn6+eello_turn6(i,jj,kk)
6332 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6333                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6334                    eturn6=0.0d0
6335                    ecorr6=0.0d0
6336                 endif
6337
6338               ENDIF
6339 1111          continue
6340             else if (j1.eq.j) then
6341 C Contacts I-J and I-(J+1) occur simultaneously.
6342 C The system loses extra energy.
6343 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6344             endif
6345           enddo ! kk
6346           do kk=1,num_conti
6347             j1=jcont_hb(kk,i)
6348 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6349 c    &         ' jj=',jj,' kk=',kk
6350             if (j1.eq.j+1) then
6351 C Contacts I-J and (I+1)-J occur simultaneously.
6352 C The system loses extra energy.
6353 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6354             endif ! j1==j+1
6355           enddo ! kk
6356         enddo ! jj
6357       enddo ! i
6358       write (iout,*) "eturn6",eturn6,ecorr6
6359       return
6360       end
6361 c------------------------------------------------------------------------------
6362       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6363       implicit real*8 (a-h,o-z)
6364       include 'DIMENSIONS'
6365       include 'COMMON.IOUNITS'
6366       include 'COMMON.DERIV'
6367       include 'COMMON.INTERACT'
6368       include 'COMMON.CONTACTS'
6369       double precision gx(3),gx1(3)
6370       logical lprn
6371       lprn=.false.
6372       eij=facont_hb(jj,i)
6373       ekl=facont_hb(kk,k)
6374       ees0pij=ees0p(jj,i)
6375       ees0pkl=ees0p(kk,k)
6376       ees0mij=ees0m(jj,i)
6377       ees0mkl=ees0m(kk,k)
6378       ekont=eij*ekl
6379       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6380 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6381 C Following 4 lines for diagnostics.
6382 cd    ees0pkl=0.0D0
6383 cd    ees0pij=1.0D0
6384 cd    ees0mkl=0.0D0
6385 cd    ees0mij=1.0D0
6386 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6387 c    &   ' and',k,l
6388 c     write (iout,*)'Contacts have occurred for peptide groups',
6389 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6390 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6391 C Calculate the multi-body contribution to energy.
6392       ecorr=ecorr+ekont*ees
6393       if (calc_grad) then
6394 C Calculate multi-body contributions to the gradient.
6395       do ll=1,3
6396         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6397         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6398      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6399      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6400         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6401      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6402      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6403         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6404         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6405      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6406      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6407         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6408      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6409      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6410       enddo
6411       do m=i+1,j-1
6412         do ll=1,3
6413           gradcorr(ll,m)=gradcorr(ll,m)+
6414      &     ees*ekl*gacont_hbr(ll,jj,i)-
6415      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6416      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6417         enddo
6418       enddo
6419       do m=k+1,l-1
6420         do ll=1,3
6421           gradcorr(ll,m)=gradcorr(ll,m)+
6422      &     ees*eij*gacont_hbr(ll,kk,k)-
6423      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6424      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6425         enddo
6426       enddo
6427       endif
6428       ehbcorr=ekont*ees
6429       return
6430       end
6431 C---------------------------------------------------------------------------
6432       subroutine dipole(i,j,jj)
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'DIMENSIONS.ZSCOPT'
6436       include 'COMMON.IOUNITS'
6437       include 'COMMON.CHAIN'
6438       include 'COMMON.FFIELD'
6439       include 'COMMON.DERIV'
6440       include 'COMMON.INTERACT'
6441       include 'COMMON.CONTACTS'
6442       include 'COMMON.TORSION'
6443       include 'COMMON.VAR'
6444       include 'COMMON.GEO'
6445       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6446      &  auxmat(2,2)
6447       iti1 = itortyp(itype(i+1))
6448       if (j.lt.nres-1) then
6449         if (itype(j).le.ntyp) then
6450           itj1 = itortyp(itype(j+1))
6451         else
6452           itj=ntortyp+1
6453         endif
6454       else
6455         itj1=ntortyp+1
6456       endif
6457       do iii=1,2
6458         dipi(iii,1)=Ub2(iii,i)
6459         dipderi(iii)=Ub2der(iii,i)
6460         dipi(iii,2)=b1(iii,iti1)
6461         dipj(iii,1)=Ub2(iii,j)
6462         dipderj(iii)=Ub2der(iii,j)
6463         dipj(iii,2)=b1(iii,itj1)
6464       enddo
6465       kkk=0
6466       do iii=1,2
6467         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6468         do jjj=1,2
6469           kkk=kkk+1
6470           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6471         enddo
6472       enddo
6473       if (.not.calc_grad) return
6474       do kkk=1,5
6475         do lll=1,3
6476           mmm=0
6477           do iii=1,2
6478             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6479      &        auxvec(1))
6480             do jjj=1,2
6481               mmm=mmm+1
6482               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6483             enddo
6484           enddo
6485         enddo
6486       enddo
6487       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6488       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6489       do iii=1,2
6490         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6491       enddo
6492       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6493       do iii=1,2
6494         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6495       enddo
6496       return
6497       end
6498 C---------------------------------------------------------------------------
6499       subroutine calc_eello(i,j,k,l,jj,kk)
6500 C
6501 C This subroutine computes matrices and vectors needed to calculate
6502 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6503 C
6504       implicit real*8 (a-h,o-z)
6505       include 'DIMENSIONS'
6506       include 'DIMENSIONS.ZSCOPT'
6507       include 'COMMON.IOUNITS'
6508       include 'COMMON.CHAIN'
6509       include 'COMMON.DERIV'
6510       include 'COMMON.INTERACT'
6511       include 'COMMON.CONTACTS'
6512       include 'COMMON.TORSION'
6513       include 'COMMON.VAR'
6514       include 'COMMON.GEO'
6515       include 'COMMON.FFIELD'
6516       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6517      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6518       logical lprn
6519       common /kutas/ lprn
6520 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6521 cd     & ' jj=',jj,' kk=',kk
6522 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6523       do iii=1,2
6524         do jjj=1,2
6525           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6526           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6527         enddo
6528       enddo
6529       call transpose2(aa1(1,1),aa1t(1,1))
6530       call transpose2(aa2(1,1),aa2t(1,1))
6531       do kkk=1,5
6532         do lll=1,3
6533           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6534      &      aa1tder(1,1,lll,kkk))
6535           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6536      &      aa2tder(1,1,lll,kkk))
6537         enddo
6538       enddo
6539       if (l.eq.j+1) then
6540 C parallel orientation of the two CA-CA-CA frames.
6541         if (i.gt.1 .and. itype(i).le.ntyp) then
6542           iti=itortyp(itype(i))
6543         else
6544           iti=ntortyp+1
6545         endif
6546         itk1=itortyp(itype(k+1))
6547         itj=itortyp(itype(j))
6548         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6549           itl1=itortyp(itype(l+1))
6550         else
6551           itl1=ntortyp+1
6552         endif
6553 C A1 kernel(j+1) A2T
6554 cd        do iii=1,2
6555 cd          write (iout,'(3f10.5,5x,3f10.5)')
6556 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6557 cd        enddo
6558         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6559      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6560      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6561 C Following matrices are needed only for 6-th order cumulants
6562         IF (wcorr6.gt.0.0d0) THEN
6563         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6564      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6565      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6566         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6567      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6568      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6569      &   ADtEAderx(1,1,1,1,1,1))
6570         lprn=.false.
6571         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6572      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6573      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6574      &   ADtEA1derx(1,1,1,1,1,1))
6575         ENDIF
6576 C End 6-th order cumulants
6577 cd        lprn=.false.
6578 cd        if (lprn) then
6579 cd        write (2,*) 'In calc_eello6'
6580 cd        do iii=1,2
6581 cd          write (2,*) 'iii=',iii
6582 cd          do kkk=1,5
6583 cd            write (2,*) 'kkk=',kkk
6584 cd            do jjj=1,2
6585 cd              write (2,'(3(2f10.5),5x)')
6586 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6587 cd            enddo
6588 cd          enddo
6589 cd        enddo
6590 cd        endif
6591         call transpose2(EUgder(1,1,k),auxmat(1,1))
6592         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6593         call transpose2(EUg(1,1,k),auxmat(1,1))
6594         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6595         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6596         do iii=1,2
6597           do kkk=1,5
6598             do lll=1,3
6599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6600      &          EAEAderx(1,1,lll,kkk,iii,1))
6601             enddo
6602           enddo
6603         enddo
6604 C A1T kernel(i+1) A2
6605         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6606      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6607      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6608 C Following matrices are needed only for 6-th order cumulants
6609         IF (wcorr6.gt.0.0d0) THEN
6610         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6611      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6612      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6613         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6614      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6615      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6616      &   ADtEAderx(1,1,1,1,1,2))
6617         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6618      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6619      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6620      &   ADtEA1derx(1,1,1,1,1,2))
6621         ENDIF
6622 C End 6-th order cumulants
6623         call transpose2(EUgder(1,1,l),auxmat(1,1))
6624         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6625         call transpose2(EUg(1,1,l),auxmat(1,1))
6626         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6627         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6628         do iii=1,2
6629           do kkk=1,5
6630             do lll=1,3
6631               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6632      &          EAEAderx(1,1,lll,kkk,iii,2))
6633             enddo
6634           enddo
6635         enddo
6636 C AEAb1 and AEAb2
6637 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6638 C They are needed only when the fifth- or the sixth-order cumulants are
6639 C indluded.
6640         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6641         call transpose2(AEA(1,1,1),auxmat(1,1))
6642         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6643         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6644         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6645         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6646         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6647         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6648         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6649         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6650         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6651         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6652         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6653         call transpose2(AEA(1,1,2),auxmat(1,1))
6654         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6655         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6656         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6657         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6658         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6659         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6660         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6661         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6662         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6663         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6664         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6665 C Calculate the Cartesian derivatives of the vectors.
6666         do iii=1,2
6667           do kkk=1,5
6668             do lll=1,3
6669               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6670               call matvec2(auxmat(1,1),b1(1,iti),
6671      &          AEAb1derx(1,lll,kkk,iii,1,1))
6672               call matvec2(auxmat(1,1),Ub2(1,i),
6673      &          AEAb2derx(1,lll,kkk,iii,1,1))
6674               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6675      &          AEAb1derx(1,lll,kkk,iii,2,1))
6676               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6677      &          AEAb2derx(1,lll,kkk,iii,2,1))
6678               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6679               call matvec2(auxmat(1,1),b1(1,itj),
6680      &          AEAb1derx(1,lll,kkk,iii,1,2))
6681               call matvec2(auxmat(1,1),Ub2(1,j),
6682      &          AEAb2derx(1,lll,kkk,iii,1,2))
6683               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6684      &          AEAb1derx(1,lll,kkk,iii,2,2))
6685               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6686      &          AEAb2derx(1,lll,kkk,iii,2,2))
6687             enddo
6688           enddo
6689         enddo
6690         ENDIF
6691 C End vectors
6692       else
6693 C Antiparallel orientation of the two CA-CA-CA frames.
6694         if (i.gt.1 .and. itype(i).le.ntyp) then
6695           iti=itortyp(itype(i))
6696         else
6697           iti=ntortyp+1
6698         endif
6699         itk1=itortyp(itype(k+1))
6700         itl=itortyp(itype(l))
6701         itj=itortyp(itype(j))
6702         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6703           itj1=itortyp(itype(j+1))
6704         else
6705           itj1=ntortyp+1
6706         endif
6707 C A2 kernel(j-1)T A1T
6708         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6709      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6710      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6711 C Following matrices are needed only for 6-th order cumulants
6712         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6713      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6714         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6715      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6716      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6717         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6718      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6719      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6720      &   ADtEAderx(1,1,1,1,1,1))
6721         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6722      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6723      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6724      &   ADtEA1derx(1,1,1,1,1,1))
6725         ENDIF
6726 C End 6-th order cumulants
6727         call transpose2(EUgder(1,1,k),auxmat(1,1))
6728         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6729         call transpose2(EUg(1,1,k),auxmat(1,1))
6730         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6731         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6732         do iii=1,2
6733           do kkk=1,5
6734             do lll=1,3
6735               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6736      &          EAEAderx(1,1,lll,kkk,iii,1))
6737             enddo
6738           enddo
6739         enddo
6740 C A2T kernel(i+1)T A1
6741         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6742      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6743      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6744 C Following matrices are needed only for 6-th order cumulants
6745         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6746      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6747         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6748      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6749      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6750         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6751      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6752      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6753      &   ADtEAderx(1,1,1,1,1,2))
6754         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6755      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6756      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6757      &   ADtEA1derx(1,1,1,1,1,2))
6758         ENDIF
6759 C End 6-th order cumulants
6760         call transpose2(EUgder(1,1,j),auxmat(1,1))
6761         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6762         call transpose2(EUg(1,1,j),auxmat(1,1))
6763         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6764         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6765         do iii=1,2
6766           do kkk=1,5
6767             do lll=1,3
6768               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6769      &          EAEAderx(1,1,lll,kkk,iii,2))
6770             enddo
6771           enddo
6772         enddo
6773 C AEAb1 and AEAb2
6774 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6775 C They are needed only when the fifth- or the sixth-order cumulants are
6776 C indluded.
6777         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6778      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6779         call transpose2(AEA(1,1,1),auxmat(1,1))
6780         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6781         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6782         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6783         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6784         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6785         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6786         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6787         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6788         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6789         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6790         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6791         call transpose2(AEA(1,1,2),auxmat(1,1))
6792         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6793         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6794         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6795         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6796         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6797         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6798         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6799         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6800         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6801         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6802         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6803 C Calculate the Cartesian derivatives of the vectors.
6804         do iii=1,2
6805           do kkk=1,5
6806             do lll=1,3
6807               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6808               call matvec2(auxmat(1,1),b1(1,iti),
6809      &          AEAb1derx(1,lll,kkk,iii,1,1))
6810               call matvec2(auxmat(1,1),Ub2(1,i),
6811      &          AEAb2derx(1,lll,kkk,iii,1,1))
6812               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6813      &          AEAb1derx(1,lll,kkk,iii,2,1))
6814               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6815      &          AEAb2derx(1,lll,kkk,iii,2,1))
6816               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6817               call matvec2(auxmat(1,1),b1(1,itl),
6818      &          AEAb1derx(1,lll,kkk,iii,1,2))
6819               call matvec2(auxmat(1,1),Ub2(1,l),
6820      &          AEAb2derx(1,lll,kkk,iii,1,2))
6821               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6822      &          AEAb1derx(1,lll,kkk,iii,2,2))
6823               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6824      &          AEAb2derx(1,lll,kkk,iii,2,2))
6825             enddo
6826           enddo
6827         enddo
6828         ENDIF
6829 C End vectors
6830       endif
6831       return
6832       end
6833 C---------------------------------------------------------------------------
6834       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6835      &  KK,KKderg,AKA,AKAderg,AKAderx)
6836       implicit none
6837       integer nderg
6838       logical transp
6839       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6840      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6841      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6842       integer iii,kkk,lll
6843       integer jjj,mmm
6844       logical lprn
6845       common /kutas/ lprn
6846       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6847       do iii=1,nderg
6848         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6849      &    AKAderg(1,1,iii))
6850       enddo
6851 cd      if (lprn) write (2,*) 'In kernel'
6852       do kkk=1,5
6853 cd        if (lprn) write (2,*) 'kkk=',kkk
6854         do lll=1,3
6855           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6856      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6857 cd          if (lprn) then
6858 cd            write (2,*) 'lll=',lll
6859 cd            write (2,*) 'iii=1'
6860 cd            do jjj=1,2
6861 cd              write (2,'(3(2f10.5),5x)')
6862 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6863 cd            enddo
6864 cd          endif
6865           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6866      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6867 cd          if (lprn) then
6868 cd            write (2,*) 'lll=',lll
6869 cd            write (2,*) 'iii=2'
6870 cd            do jjj=1,2
6871 cd              write (2,'(3(2f10.5),5x)')
6872 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6873 cd            enddo
6874 cd          endif
6875         enddo
6876       enddo
6877       return
6878       end
6879 C---------------------------------------------------------------------------
6880       double precision function eello4(i,j,k,l,jj,kk)
6881       implicit real*8 (a-h,o-z)
6882       include 'DIMENSIONS'
6883       include 'DIMENSIONS.ZSCOPT'
6884       include 'COMMON.IOUNITS'
6885       include 'COMMON.CHAIN'
6886       include 'COMMON.DERIV'
6887       include 'COMMON.INTERACT'
6888       include 'COMMON.CONTACTS'
6889       include 'COMMON.TORSION'
6890       include 'COMMON.VAR'
6891       include 'COMMON.GEO'
6892       double precision pizda(2,2),ggg1(3),ggg2(3)
6893 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6894 cd        eello4=0.0d0
6895 cd        return
6896 cd      endif
6897 cd      print *,'eello4:',i,j,k,l,jj,kk
6898 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6899 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6900 cold      eij=facont_hb(jj,i)
6901 cold      ekl=facont_hb(kk,k)
6902 cold      ekont=eij*ekl
6903       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6904       if (calc_grad) then
6905 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6906       gcorr_loc(k-1)=gcorr_loc(k-1)
6907      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6908       if (l.eq.j+1) then
6909         gcorr_loc(l-1)=gcorr_loc(l-1)
6910      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6911       else
6912         gcorr_loc(j-1)=gcorr_loc(j-1)
6913      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6914       endif
6915       do iii=1,2
6916         do kkk=1,5
6917           do lll=1,3
6918             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6919      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6920 cd            derx(lll,kkk,iii)=0.0d0
6921           enddo
6922         enddo
6923       enddo
6924 cd      gcorr_loc(l-1)=0.0d0
6925 cd      gcorr_loc(j-1)=0.0d0
6926 cd      gcorr_loc(k-1)=0.0d0
6927 cd      eel4=1.0d0
6928 cd      write (iout,*)'Contacts have occurred for peptide groups',
6929 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6930 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6931       if (j.lt.nres-1) then
6932         j1=j+1
6933         j2=j-1
6934       else
6935         j1=j-1
6936         j2=j-2
6937       endif
6938       if (l.lt.nres-1) then
6939         l1=l+1
6940         l2=l-1
6941       else
6942         l1=l-1
6943         l2=l-2
6944       endif
6945       do ll=1,3
6946 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6947         ggg1(ll)=eel4*g_contij(ll,1)
6948         ggg2(ll)=eel4*g_contij(ll,2)
6949         ghalf=0.5d0*ggg1(ll)
6950 cd        ghalf=0.0d0
6951         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6952         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6953         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6954         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6955 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6956         ghalf=0.5d0*ggg2(ll)
6957 cd        ghalf=0.0d0
6958         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6959         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6960         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6961         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6962       enddo
6963 cd      goto 1112
6964       do m=i+1,j-1
6965         do ll=1,3
6966 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6967           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6968         enddo
6969       enddo
6970       do m=k+1,l-1
6971         do ll=1,3
6972 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6973           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6974         enddo
6975       enddo
6976 1112  continue
6977       do m=i+2,j2
6978         do ll=1,3
6979           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6980         enddo
6981       enddo
6982       do m=k+2,l2
6983         do ll=1,3
6984           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6985         enddo
6986       enddo
6987 cd      do iii=1,nres-3
6988 cd        write (2,*) iii,gcorr_loc(iii)
6989 cd      enddo
6990       endif
6991       eello4=ekont*eel4
6992 cd      write (2,*) 'ekont',ekont
6993 cd      write (iout,*) 'eello4',ekont*eel4
6994       return
6995       end
6996 C---------------------------------------------------------------------------
6997       double precision function eello5(i,j,k,l,jj,kk)
6998       implicit real*8 (a-h,o-z)
6999       include 'DIMENSIONS'
7000       include 'DIMENSIONS.ZSCOPT'
7001       include 'COMMON.IOUNITS'
7002       include 'COMMON.CHAIN'
7003       include 'COMMON.DERIV'
7004       include 'COMMON.INTERACT'
7005       include 'COMMON.CONTACTS'
7006       include 'COMMON.TORSION'
7007       include 'COMMON.VAR'
7008       include 'COMMON.GEO'
7009       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7010       double precision ggg1(3),ggg2(3)
7011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7012 C                                                                              C
7013 C                            Parallel chains                                   C
7014 C                                                                              C
7015 C          o             o                   o             o                   C
7016 C         /l\           / \             \   / \           / \   /              C
7017 C        /   \         /   \             \ /   \         /   \ /               C
7018 C       j| o |l1       | o |              o| o |         | o |o                C
7019 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7020 C      \i/   \         /   \ /             /   \         /   \                 C
7021 C       o    k1             o                                                  C
7022 C         (I)          (II)                (III)          (IV)                 C
7023 C                                                                              C
7024 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7025 C                                                                              C
7026 C                            Antiparallel chains                               C
7027 C                                                                              C
7028 C          o             o                   o             o                   C
7029 C         /j\           / \             \   / \           / \   /              C
7030 C        /   \         /   \             \ /   \         /   \ /               C
7031 C      j1| o |l        | o |              o| o |         | o |o                C
7032 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7033 C      \i/   \         /   \ /             /   \         /   \                 C
7034 C       o     k1            o                                                  C
7035 C         (I)          (II)                (III)          (IV)                 C
7036 C                                                                              C
7037 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7038 C                                                                              C
7039 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7040 C                                                                              C
7041 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7042 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7043 cd        eello5=0.0d0
7044 cd        return
7045 cd      endif
7046 cd      write (iout,*)
7047 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7048 cd     &   ' and',k,l
7049       itk=itortyp(itype(k))
7050       itl=itortyp(itype(l))
7051       itj=itortyp(itype(j))
7052       eello5_1=0.0d0
7053       eello5_2=0.0d0
7054       eello5_3=0.0d0
7055       eello5_4=0.0d0
7056 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7057 cd     &   eel5_3_num,eel5_4_num)
7058       do iii=1,2
7059         do kkk=1,5
7060           do lll=1,3
7061             derx(lll,kkk,iii)=0.0d0
7062           enddo
7063         enddo
7064       enddo
7065 cd      eij=facont_hb(jj,i)
7066 cd      ekl=facont_hb(kk,k)
7067 cd      ekont=eij*ekl
7068 cd      write (iout,*)'Contacts have occurred for peptide groups',
7069 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7070 cd      goto 1111
7071 C Contribution from the graph I.
7072 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7073 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7074       call transpose2(EUg(1,1,k),auxmat(1,1))
7075       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7076       vv(1)=pizda(1,1)-pizda(2,2)
7077       vv(2)=pizda(1,2)+pizda(2,1)
7078       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7079      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7080       if (calc_grad) then
7081 C Explicit gradient in virtual-dihedral angles.
7082       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7083      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7084      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7085       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7086       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7087       vv(1)=pizda(1,1)-pizda(2,2)
7088       vv(2)=pizda(1,2)+pizda(2,1)
7089       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7090      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7091      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7092       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7093       vv(1)=pizda(1,1)-pizda(2,2)
7094       vv(2)=pizda(1,2)+pizda(2,1)
7095       if (l.eq.j+1) then
7096         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7097      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7098      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7099       else
7100         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7101      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7102      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7103       endif
7104 C Cartesian gradient
7105       do iii=1,2
7106         do kkk=1,5
7107           do lll=1,3
7108             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7109      &        pizda(1,1))
7110             vv(1)=pizda(1,1)-pizda(2,2)
7111             vv(2)=pizda(1,2)+pizda(2,1)
7112             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7113      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7114      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7115           enddo
7116         enddo
7117       enddo
7118 c      goto 1112
7119       endif
7120 c1111  continue
7121 C Contribution from graph II
7122       call transpose2(EE(1,1,itk),auxmat(1,1))
7123       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7124       vv(1)=pizda(1,1)+pizda(2,2)
7125       vv(2)=pizda(2,1)-pizda(1,2)
7126       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7127      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7128       if (calc_grad) then
7129 C Explicit gradient in virtual-dihedral angles.
7130       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7131      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7132       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7133       vv(1)=pizda(1,1)+pizda(2,2)
7134       vv(2)=pizda(2,1)-pizda(1,2)
7135       if (l.eq.j+1) then
7136         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7137      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7138      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7139       else
7140         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7141      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7142      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7143       endif
7144 C Cartesian gradient
7145       do iii=1,2
7146         do kkk=1,5
7147           do lll=1,3
7148             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7149      &        pizda(1,1))
7150             vv(1)=pizda(1,1)+pizda(2,2)
7151             vv(2)=pizda(2,1)-pizda(1,2)
7152             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7153      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7154      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7155           enddo
7156         enddo
7157       enddo
7158 cd      goto 1112
7159       endif
7160 cd1111  continue
7161       if (l.eq.j+1) then
7162 cd        goto 1110
7163 C Parallel orientation
7164 C Contribution from graph III
7165         call transpose2(EUg(1,1,l),auxmat(1,1))
7166         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7167         vv(1)=pizda(1,1)-pizda(2,2)
7168         vv(2)=pizda(1,2)+pizda(2,1)
7169         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7170      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7171         if (calc_grad) then
7172 C Explicit gradient in virtual-dihedral angles.
7173         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7174      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7175      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7176         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7177         vv(1)=pizda(1,1)-pizda(2,2)
7178         vv(2)=pizda(1,2)+pizda(2,1)
7179         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7180      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7181      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7182         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7183         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7184         vv(1)=pizda(1,1)-pizda(2,2)
7185         vv(2)=pizda(1,2)+pizda(2,1)
7186         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7187      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7188      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7189 C Cartesian gradient
7190         do iii=1,2
7191           do kkk=1,5
7192             do lll=1,3
7193               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7194      &          pizda(1,1))
7195               vv(1)=pizda(1,1)-pizda(2,2)
7196               vv(2)=pizda(1,2)+pizda(2,1)
7197               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7198      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7199      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7200             enddo
7201           enddo
7202         enddo
7203 cd        goto 1112
7204         endif
7205 C Contribution from graph IV
7206 cd1110    continue
7207         call transpose2(EE(1,1,itl),auxmat(1,1))
7208         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7209         vv(1)=pizda(1,1)+pizda(2,2)
7210         vv(2)=pizda(2,1)-pizda(1,2)
7211         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7212      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7213         if (calc_grad) then
7214 C Explicit gradient in virtual-dihedral angles.
7215         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7216      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7217         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7218         vv(1)=pizda(1,1)+pizda(2,2)
7219         vv(2)=pizda(2,1)-pizda(1,2)
7220         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7221      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7222      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7223 C Cartesian gradient
7224         do iii=1,2
7225           do kkk=1,5
7226             do lll=1,3
7227               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7228      &          pizda(1,1))
7229               vv(1)=pizda(1,1)+pizda(2,2)
7230               vv(2)=pizda(2,1)-pizda(1,2)
7231               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7232      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7233      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7234             enddo
7235           enddo
7236         enddo
7237         endif
7238       else
7239 C Antiparallel orientation
7240 C Contribution from graph III
7241 c        goto 1110
7242         call transpose2(EUg(1,1,j),auxmat(1,1))
7243         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7244         vv(1)=pizda(1,1)-pizda(2,2)
7245         vv(2)=pizda(1,2)+pizda(2,1)
7246         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7248         if (calc_grad) then
7249 C Explicit gradient in virtual-dihedral angles.
7250         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7251      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7252      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7253         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7254         vv(1)=pizda(1,1)-pizda(2,2)
7255         vv(2)=pizda(1,2)+pizda(2,1)
7256         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7257      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7258      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7259         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7260         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7261         vv(1)=pizda(1,1)-pizda(2,2)
7262         vv(2)=pizda(1,2)+pizda(2,1)
7263         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7264      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7265      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7266 C Cartesian gradient
7267         do iii=1,2
7268           do kkk=1,5
7269             do lll=1,3
7270               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7271      &          pizda(1,1))
7272               vv(1)=pizda(1,1)-pizda(2,2)
7273               vv(2)=pizda(1,2)+pizda(2,1)
7274               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7275      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7276      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7277             enddo
7278           enddo
7279         enddo
7280 cd        goto 1112
7281         endif
7282 C Contribution from graph IV
7283 1110    continue
7284         call transpose2(EE(1,1,itj),auxmat(1,1))
7285         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7286         vv(1)=pizda(1,1)+pizda(2,2)
7287         vv(2)=pizda(2,1)-pizda(1,2)
7288         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7289      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7290         if (calc_grad) then
7291 C Explicit gradient in virtual-dihedral angles.
7292         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7293      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7294         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7295         vv(1)=pizda(1,1)+pizda(2,2)
7296         vv(2)=pizda(2,1)-pizda(1,2)
7297         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7298      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7299      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7300 C Cartesian gradient
7301         do iii=1,2
7302           do kkk=1,5
7303             do lll=1,3
7304               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7305      &          pizda(1,1))
7306               vv(1)=pizda(1,1)+pizda(2,2)
7307               vv(2)=pizda(2,1)-pizda(1,2)
7308               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7309      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7310      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7311             enddo
7312           enddo
7313         enddo
7314       endif
7315       endif
7316 1112  continue
7317       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7318 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7319 cd        write (2,*) 'ijkl',i,j,k,l
7320 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7321 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7322 cd      endif
7323 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7324 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7325 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7326 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7327       if (calc_grad) then
7328       if (j.lt.nres-1) then
7329         j1=j+1
7330         j2=j-1
7331       else
7332         j1=j-1
7333         j2=j-2
7334       endif
7335       if (l.lt.nres-1) then
7336         l1=l+1
7337         l2=l-1
7338       else
7339         l1=l-1
7340         l2=l-2
7341       endif
7342 cd      eij=1.0d0
7343 cd      ekl=1.0d0
7344 cd      ekont=1.0d0
7345 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7346       do ll=1,3
7347         ggg1(ll)=eel5*g_contij(ll,1)
7348         ggg2(ll)=eel5*g_contij(ll,2)
7349 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7350         ghalf=0.5d0*ggg1(ll)
7351 cd        ghalf=0.0d0
7352         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7353         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7354         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7355         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7356 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7357         ghalf=0.5d0*ggg2(ll)
7358 cd        ghalf=0.0d0
7359         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7360         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7361         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7362         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7363       enddo
7364 cd      goto 1112
7365       do m=i+1,j-1
7366         do ll=1,3
7367 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7368           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7369         enddo
7370       enddo
7371       do m=k+1,l-1
7372         do ll=1,3
7373 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7374           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7375         enddo
7376       enddo
7377 c1112  continue
7378       do m=i+2,j2
7379         do ll=1,3
7380           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7381         enddo
7382       enddo
7383       do m=k+2,l2
7384         do ll=1,3
7385           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7386         enddo
7387       enddo
7388 cd      do iii=1,nres-3
7389 cd        write (2,*) iii,g_corr5_loc(iii)
7390 cd      enddo
7391       endif
7392       eello5=ekont*eel5
7393 cd      write (2,*) 'ekont',ekont
7394 cd      write (iout,*) 'eello5',ekont*eel5
7395       return
7396       end
7397 c--------------------------------------------------------------------------
7398       double precision function eello6(i,j,k,l,jj,kk)
7399       implicit real*8 (a-h,o-z)
7400       include 'DIMENSIONS'
7401       include 'DIMENSIONS.ZSCOPT'
7402       include 'COMMON.IOUNITS'
7403       include 'COMMON.CHAIN'
7404       include 'COMMON.DERIV'
7405       include 'COMMON.INTERACT'
7406       include 'COMMON.CONTACTS'
7407       include 'COMMON.TORSION'
7408       include 'COMMON.VAR'
7409       include 'COMMON.GEO'
7410       include 'COMMON.FFIELD'
7411       double precision ggg1(3),ggg2(3)
7412 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7413 cd        eello6=0.0d0
7414 cd        return
7415 cd      endif
7416 cd      write (iout,*)
7417 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7418 cd     &   ' and',k,l
7419       eello6_1=0.0d0
7420       eello6_2=0.0d0
7421       eello6_3=0.0d0
7422       eello6_4=0.0d0
7423       eello6_5=0.0d0
7424       eello6_6=0.0d0
7425 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7426 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7427       do iii=1,2
7428         do kkk=1,5
7429           do lll=1,3
7430             derx(lll,kkk,iii)=0.0d0
7431           enddo
7432         enddo
7433       enddo
7434 cd      eij=facont_hb(jj,i)
7435 cd      ekl=facont_hb(kk,k)
7436 cd      ekont=eij*ekl
7437 cd      eij=1.0d0
7438 cd      ekl=1.0d0
7439 cd      ekont=1.0d0
7440       if (l.eq.j+1) then
7441         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7442         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7443         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7444         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7445         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7446         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7447       else
7448         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7449         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7450         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7451         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7452         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7453           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7454         else
7455           eello6_5=0.0d0
7456         endif
7457         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7458       endif
7459 C If turn contributions are considered, they will be handled separately.
7460       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7461 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7462 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7463 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7464 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7465 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7466 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7467 cd      goto 1112
7468       if (calc_grad) then
7469       if (j.lt.nres-1) then
7470         j1=j+1
7471         j2=j-1
7472       else
7473         j1=j-1
7474         j2=j-2
7475       endif
7476       if (l.lt.nres-1) then
7477         l1=l+1
7478         l2=l-1
7479       else
7480         l1=l-1
7481         l2=l-2
7482       endif
7483       do ll=1,3
7484         ggg1(ll)=eel6*g_contij(ll,1)
7485         ggg2(ll)=eel6*g_contij(ll,2)
7486 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7487         ghalf=0.5d0*ggg1(ll)
7488 cd        ghalf=0.0d0
7489         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7490         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7491         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7492         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7493         ghalf=0.5d0*ggg2(ll)
7494 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7495 cd        ghalf=0.0d0
7496         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7497         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7498         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7499         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7500       enddo
7501 cd      goto 1112
7502       do m=i+1,j-1
7503         do ll=1,3
7504 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7505           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7506         enddo
7507       enddo
7508       do m=k+1,l-1
7509         do ll=1,3
7510 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7511           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7512         enddo
7513       enddo
7514 1112  continue
7515       do m=i+2,j2
7516         do ll=1,3
7517           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7518         enddo
7519       enddo
7520       do m=k+2,l2
7521         do ll=1,3
7522           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7523         enddo
7524       enddo
7525 cd      do iii=1,nres-3
7526 cd        write (2,*) iii,g_corr6_loc(iii)
7527 cd      enddo
7528       endif
7529       eello6=ekont*eel6
7530 cd      write (2,*) 'ekont',ekont
7531 cd      write (iout,*) 'eello6',ekont*eel6
7532       return
7533       end
7534 c--------------------------------------------------------------------------
7535       double precision function eello6_graph1(i,j,k,l,imat,swap)
7536       implicit real*8 (a-h,o-z)
7537       include 'DIMENSIONS'
7538       include 'DIMENSIONS.ZSCOPT'
7539       include 'COMMON.IOUNITS'
7540       include 'COMMON.CHAIN'
7541       include 'COMMON.DERIV'
7542       include 'COMMON.INTERACT'
7543       include 'COMMON.CONTACTS'
7544       include 'COMMON.TORSION'
7545       include 'COMMON.VAR'
7546       include 'COMMON.GEO'
7547       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7548       logical swap
7549       logical lprn
7550       common /kutas/ lprn
7551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7552 C                                                                              C
7553 C      Parallel       Antiparallel                                             C
7554 C                                                                              C
7555 C          o             o                                                     C
7556 C         /l\           /j\                                                    C
7557 C        /   \         /   \                                                   C
7558 C       /| o |         | o |\                                                  C
7559 C     \ j|/k\|  /   \  |/k\|l /                                                C
7560 C      \ /   \ /     \ /   \ /                                                 C
7561 C       o     o       o     o                                                  C
7562 C       i             i                                                        C
7563 C                                                                              C
7564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7565       itk=itortyp(itype(k))
7566       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7567       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7568       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7569       call transpose2(EUgC(1,1,k),auxmat(1,1))
7570       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7571       vv1(1)=pizda1(1,1)-pizda1(2,2)
7572       vv1(2)=pizda1(1,2)+pizda1(2,1)
7573       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7574       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7575       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7576       s5=scalar2(vv(1),Dtobr2(1,i))
7577 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7578       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7579       if (.not. calc_grad) return
7580       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7581      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7582      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7583      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7584      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7585      & +scalar2(vv(1),Dtobr2der(1,i)))
7586       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7587       vv1(1)=pizda1(1,1)-pizda1(2,2)
7588       vv1(2)=pizda1(1,2)+pizda1(2,1)
7589       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7590       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7591       if (l.eq.j+1) then
7592         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7593      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7594      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7595      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7596      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7597       else
7598         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7599      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7600      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7601      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7602      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7603       endif
7604       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7605       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7606       vv1(1)=pizda1(1,1)-pizda1(2,2)
7607       vv1(2)=pizda1(1,2)+pizda1(2,1)
7608       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7609      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7610      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7611      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7612       do iii=1,2
7613         if (swap) then
7614           ind=3-iii
7615         else
7616           ind=iii
7617         endif
7618         do kkk=1,5
7619           do lll=1,3
7620             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7621             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7622             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7623             call transpose2(EUgC(1,1,k),auxmat(1,1))
7624             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7625      &        pizda1(1,1))
7626             vv1(1)=pizda1(1,1)-pizda1(2,2)
7627             vv1(2)=pizda1(1,2)+pizda1(2,1)
7628             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7629             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7630      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7631             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7632      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7633             s5=scalar2(vv(1),Dtobr2(1,i))
7634             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7635           enddo
7636         enddo
7637       enddo
7638       return
7639       end
7640 c----------------------------------------------------------------------------
7641       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7642       implicit real*8 (a-h,o-z)
7643       include 'DIMENSIONS'
7644       include 'DIMENSIONS.ZSCOPT'
7645       include 'COMMON.IOUNITS'
7646       include 'COMMON.CHAIN'
7647       include 'COMMON.DERIV'
7648       include 'COMMON.INTERACT'
7649       include 'COMMON.CONTACTS'
7650       include 'COMMON.TORSION'
7651       include 'COMMON.VAR'
7652       include 'COMMON.GEO'
7653       logical swap
7654       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7655      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7656       logical lprn
7657       common /kutas/ lprn
7658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7659 C                                                                              C
7660 C      Parallel       Antiparallel                                             C
7661 C                                                                              C
7662 C          o             o                                                     C
7663 C     \   /l\           /j\   /                                                C
7664 C      \ /   \         /   \ /                                                 C
7665 C       o| o |         | o |o                                                  C
7666 C     \ j|/k\|      \  |/k\|l                                                  C
7667 C      \ /   \       \ /   \                                                   C
7668 C       o             o                                                        C
7669 C       i             i                                                        C
7670 C                                                                              C
7671 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7672 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7673 C AL 7/4/01 s1 would occur in the sixth-order moment,
7674 C           but not in a cluster cumulant
7675 #ifdef MOMENT
7676       s1=dip(1,jj,i)*dip(1,kk,k)
7677 #endif
7678       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7679       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7680       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7681       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7682       call transpose2(EUg(1,1,k),auxmat(1,1))
7683       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7684       vv(1)=pizda(1,1)-pizda(2,2)
7685       vv(2)=pizda(1,2)+pizda(2,1)
7686       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7687 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7688 #ifdef MOMENT
7689       eello6_graph2=-(s1+s2+s3+s4)
7690 #else
7691       eello6_graph2=-(s2+s3+s4)
7692 #endif
7693 c      eello6_graph2=-s3
7694       if (.not. calc_grad) return
7695 C Derivatives in gamma(i-1)
7696       if (i.gt.1) then
7697 #ifdef MOMENT
7698         s1=dipderg(1,jj,i)*dip(1,kk,k)
7699 #endif
7700         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7701         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7702         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7703         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7704 #ifdef MOMENT
7705         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7706 #else
7707         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7708 #endif
7709 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7710       endif
7711 C Derivatives in gamma(k-1)
7712 #ifdef MOMENT
7713       s1=dip(1,jj,i)*dipderg(1,kk,k)
7714 #endif
7715       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7716       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7717       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7718       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7719       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7720       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7721       vv(1)=pizda(1,1)-pizda(2,2)
7722       vv(2)=pizda(1,2)+pizda(2,1)
7723       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7724 #ifdef MOMENT
7725       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7726 #else
7727       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7728 #endif
7729 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7730 C Derivatives in gamma(j-1) or gamma(l-1)
7731       if (j.gt.1) then
7732 #ifdef MOMENT
7733         s1=dipderg(3,jj,i)*dip(1,kk,k)
7734 #endif
7735         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7736         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7737         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7738         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7739         vv(1)=pizda(1,1)-pizda(2,2)
7740         vv(2)=pizda(1,2)+pizda(2,1)
7741         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7742 #ifdef MOMENT
7743         if (swap) then
7744           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7745         else
7746           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7747         endif
7748 #endif
7749         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7750 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7751       endif
7752 C Derivatives in gamma(l-1) or gamma(j-1)
7753       if (l.gt.1) then
7754 #ifdef MOMENT
7755         s1=dip(1,jj,i)*dipderg(3,kk,k)
7756 #endif
7757         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7758         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7759         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7760         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7761         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7762         vv(1)=pizda(1,1)-pizda(2,2)
7763         vv(2)=pizda(1,2)+pizda(2,1)
7764         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7765 #ifdef MOMENT
7766         if (swap) then
7767           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7768         else
7769           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7770         endif
7771 #endif
7772         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7773 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7774       endif
7775 C Cartesian derivatives.
7776       if (lprn) then
7777         write (2,*) 'In eello6_graph2'
7778         do iii=1,2
7779           write (2,*) 'iii=',iii
7780           do kkk=1,5
7781             write (2,*) 'kkk=',kkk
7782             do jjj=1,2
7783               write (2,'(3(2f10.5),5x)')
7784      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7785             enddo
7786           enddo
7787         enddo
7788       endif
7789       do iii=1,2
7790         do kkk=1,5
7791           do lll=1,3
7792 #ifdef MOMENT
7793             if (iii.eq.1) then
7794               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7795             else
7796               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7797             endif
7798 #endif
7799             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7800      &        auxvec(1))
7801             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7802             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7803      &        auxvec(1))
7804             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7805             call transpose2(EUg(1,1,k),auxmat(1,1))
7806             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7807      &        pizda(1,1))
7808             vv(1)=pizda(1,1)-pizda(2,2)
7809             vv(2)=pizda(1,2)+pizda(2,1)
7810             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7811 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7812 #ifdef MOMENT
7813             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7814 #else
7815             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7816 #endif
7817             if (swap) then
7818               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7819             else
7820               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7821             endif
7822           enddo
7823         enddo
7824       enddo
7825       return
7826       end
7827 c----------------------------------------------------------------------------
7828       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7829       implicit real*8 (a-h,o-z)
7830       include 'DIMENSIONS'
7831       include 'DIMENSIONS.ZSCOPT'
7832       include 'COMMON.IOUNITS'
7833       include 'COMMON.CHAIN'
7834       include 'COMMON.DERIV'
7835       include 'COMMON.INTERACT'
7836       include 'COMMON.CONTACTS'
7837       include 'COMMON.TORSION'
7838       include 'COMMON.VAR'
7839       include 'COMMON.GEO'
7840       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7841       logical swap
7842 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7843 C                                                                              C
7844 C      Parallel       Antiparallel                                             C
7845 C                                                                              C
7846 C          o             o                                                     C
7847 C         /l\   /   \   /j\                                                    C
7848 C        /   \ /     \ /   \                                                   C
7849 C       /| o |o       o| o |\                                                  C
7850 C       j|/k\|  /      |/k\|l /                                                C
7851 C        /   \ /       /   \ /                                                 C
7852 C       /     o       /     o                                                  C
7853 C       i             i                                                        C
7854 C                                                                              C
7855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7856 C
7857 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7858 C           energy moment and not to the cluster cumulant.
7859       iti=itortyp(itype(i))
7860       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7861         itj1=itortyp(itype(j+1))
7862       else
7863         itj1=ntortyp+1
7864       endif
7865       itk=itortyp(itype(k))
7866       itk1=itortyp(itype(k+1))
7867       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7868         itl1=itortyp(itype(l+1))
7869       else
7870         itl1=ntortyp+1
7871       endif
7872 #ifdef MOMENT
7873       s1=dip(4,jj,i)*dip(4,kk,k)
7874 #endif
7875       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7876       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7877       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7878       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7879       call transpose2(EE(1,1,itk),auxmat(1,1))
7880       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7881       vv(1)=pizda(1,1)+pizda(2,2)
7882       vv(2)=pizda(2,1)-pizda(1,2)
7883       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7884 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7885 #ifdef MOMENT
7886       eello6_graph3=-(s1+s2+s3+s4)
7887 #else
7888       eello6_graph3=-(s2+s3+s4)
7889 #endif
7890 c      eello6_graph3=-s4
7891       if (.not. calc_grad) return
7892 C Derivatives in gamma(k-1)
7893       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7894       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7895       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7896       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7897 C Derivatives in gamma(l-1)
7898       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7899       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7900       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7901       vv(1)=pizda(1,1)+pizda(2,2)
7902       vv(2)=pizda(2,1)-pizda(1,2)
7903       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7904       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7905 C Cartesian derivatives.
7906       do iii=1,2
7907         do kkk=1,5
7908           do lll=1,3
7909 #ifdef MOMENT
7910             if (iii.eq.1) then
7911               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7912             else
7913               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7914             endif
7915 #endif
7916             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7917      &        auxvec(1))
7918             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7919             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7920      &        auxvec(1))
7921             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7922             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7923      &        pizda(1,1))
7924             vv(1)=pizda(1,1)+pizda(2,2)
7925             vv(2)=pizda(2,1)-pizda(1,2)
7926             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7927 #ifdef MOMENT
7928             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7929 #else
7930             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7931 #endif
7932             if (swap) then
7933               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7934             else
7935               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7936             endif
7937 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7938           enddo
7939         enddo
7940       enddo
7941       return
7942       end
7943 c----------------------------------------------------------------------------
7944       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7945       implicit real*8 (a-h,o-z)
7946       include 'DIMENSIONS'
7947       include 'DIMENSIONS.ZSCOPT'
7948       include 'COMMON.IOUNITS'
7949       include 'COMMON.CHAIN'
7950       include 'COMMON.DERIV'
7951       include 'COMMON.INTERACT'
7952       include 'COMMON.CONTACTS'
7953       include 'COMMON.TORSION'
7954       include 'COMMON.VAR'
7955       include 'COMMON.GEO'
7956       include 'COMMON.FFIELD'
7957       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7958      & auxvec1(2),auxmat1(2,2)
7959       logical swap
7960 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7961 C                                                                              C
7962 C      Parallel       Antiparallel                                             C
7963 C                                                                              C
7964 C          o             o                                                     C
7965 C         /l\   /   \   /j\                                                    C
7966 C        /   \ /     \ /   \                                                   C
7967 C       /| o |o       o| o |\                                                  C
7968 C     \ j|/k\|      \  |/k\|l                                                  C
7969 C      \ /   \       \ /   \                                                   C
7970 C       o     \       o     \                                                  C
7971 C       i             i                                                        C
7972 C                                                                              C
7973 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7974 C
7975 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7976 C           energy moment and not to the cluster cumulant.
7977 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7978       iti=itortyp(itype(i))
7979       itj=itortyp(itype(j))
7980       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7981         itj1=itortyp(itype(j+1))
7982       else
7983         itj1=ntortyp+1
7984       endif
7985       itk=itortyp(itype(k))
7986       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7987         itk1=itortyp(itype(k+1))
7988       else
7989         itk1=ntortyp+1
7990       endif
7991       itl=itortyp(itype(l))
7992       if (l.lt.nres-1) then
7993         itl1=itortyp(itype(l+1))
7994       else
7995         itl1=ntortyp+1
7996       endif
7997 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7998 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7999 cd     & ' itl',itl,' itl1',itl1
8000 #ifdef MOMENT
8001       if (imat.eq.1) then
8002         s1=dip(3,jj,i)*dip(3,kk,k)
8003       else
8004         s1=dip(2,jj,j)*dip(2,kk,l)
8005       endif
8006 #endif
8007       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8008       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8009       if (j.eq.l+1) then
8010         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8011         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8012       else
8013         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8014         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8015       endif
8016       call transpose2(EUg(1,1,k),auxmat(1,1))
8017       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8018       vv(1)=pizda(1,1)-pizda(2,2)
8019       vv(2)=pizda(2,1)+pizda(1,2)
8020       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8021 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8022 #ifdef MOMENT
8023       eello6_graph4=-(s1+s2+s3+s4)
8024 #else
8025       eello6_graph4=-(s2+s3+s4)
8026 #endif
8027       if (.not. calc_grad) return
8028 C Derivatives in gamma(i-1)
8029       if (i.gt.1) then
8030 #ifdef MOMENT
8031         if (imat.eq.1) then
8032           s1=dipderg(2,jj,i)*dip(3,kk,k)
8033         else
8034           s1=dipderg(4,jj,j)*dip(2,kk,l)
8035         endif
8036 #endif
8037         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8038         if (j.eq.l+1) then
8039           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8040           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8041         else
8042           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8043           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8044         endif
8045         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8046         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8047 cd          write (2,*) 'turn6 derivatives'
8048 #ifdef MOMENT
8049           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8050 #else
8051           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8052 #endif
8053         else
8054 #ifdef MOMENT
8055           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8056 #else
8057           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8058 #endif
8059         endif
8060       endif
8061 C Derivatives in gamma(k-1)
8062 #ifdef MOMENT
8063       if (imat.eq.1) then
8064         s1=dip(3,jj,i)*dipderg(2,kk,k)
8065       else
8066         s1=dip(2,jj,j)*dipderg(4,kk,l)
8067       endif
8068 #endif
8069       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8070       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8071       if (j.eq.l+1) then
8072         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8073         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8074       else
8075         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8076         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8077       endif
8078       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8079       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8080       vv(1)=pizda(1,1)-pizda(2,2)
8081       vv(2)=pizda(2,1)+pizda(1,2)
8082       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8083       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8084 #ifdef MOMENT
8085         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8086 #else
8087         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8088 #endif
8089       else
8090 #ifdef MOMENT
8091         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8092 #else
8093         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8094 #endif
8095       endif
8096 C Derivatives in gamma(j-1) or gamma(l-1)
8097       if (l.eq.j+1 .and. l.gt.1) then
8098         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8099         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8100         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8101         vv(1)=pizda(1,1)-pizda(2,2)
8102         vv(2)=pizda(2,1)+pizda(1,2)
8103         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8104         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8105       else if (j.gt.1) then
8106         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8107         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8108         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8109         vv(1)=pizda(1,1)-pizda(2,2)
8110         vv(2)=pizda(2,1)+pizda(1,2)
8111         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8112         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8113           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8114         else
8115           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8116         endif
8117       endif
8118 C Cartesian derivatives.
8119       do iii=1,2
8120         do kkk=1,5
8121           do lll=1,3
8122 #ifdef MOMENT
8123             if (iii.eq.1) then
8124               if (imat.eq.1) then
8125                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8126               else
8127                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8128               endif
8129             else
8130               if (imat.eq.1) then
8131                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8132               else
8133                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8134               endif
8135             endif
8136 #endif
8137             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8138      &        auxvec(1))
8139             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8140             if (j.eq.l+1) then
8141               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8142      &          b1(1,itj1),auxvec(1))
8143               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8144             else
8145               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8146      &          b1(1,itl1),auxvec(1))
8147               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8148             endif
8149             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8150      &        pizda(1,1))
8151             vv(1)=pizda(1,1)-pizda(2,2)
8152             vv(2)=pizda(2,1)+pizda(1,2)
8153             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8154             if (swap) then
8155               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8156 #ifdef MOMENT
8157                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8158      &             -(s1+s2+s4)
8159 #else
8160                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8161      &             -(s2+s4)
8162 #endif
8163                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8164               else
8165 #ifdef MOMENT
8166                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8167 #else
8168                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8169 #endif
8170                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8171               endif
8172             else
8173 #ifdef MOMENT
8174               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8175 #else
8176               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8177 #endif
8178               if (l.eq.j+1) then
8179                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8180               else
8181                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8182               endif
8183             endif
8184           enddo
8185         enddo
8186       enddo
8187       return
8188       end
8189 c----------------------------------------------------------------------------
8190       double precision function eello_turn6(i,jj,kk)
8191       implicit real*8 (a-h,o-z)
8192       include 'DIMENSIONS'
8193       include 'DIMENSIONS.ZSCOPT'
8194       include 'COMMON.IOUNITS'
8195       include 'COMMON.CHAIN'
8196       include 'COMMON.DERIV'
8197       include 'COMMON.INTERACT'
8198       include 'COMMON.CONTACTS'
8199       include 'COMMON.TORSION'
8200       include 'COMMON.VAR'
8201       include 'COMMON.GEO'
8202       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8203      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8204      &  ggg1(3),ggg2(3)
8205       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8206      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8207 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8208 C           the respective energy moment and not to the cluster cumulant.
8209       eello_turn6=0.0d0
8210       j=i+4
8211       k=i+1
8212       l=i+3
8213       iti=itortyp(itype(i))
8214       itk=itortyp(itype(k))
8215       itk1=itortyp(itype(k+1))
8216       itl=itortyp(itype(l))
8217       itj=itortyp(itype(j))
8218 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8219 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8220 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8221 cd        eello6=0.0d0
8222 cd        return
8223 cd      endif
8224 cd      write (iout,*)
8225 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8226 cd     &   ' and',k,l
8227 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8228       do iii=1,2
8229         do kkk=1,5
8230           do lll=1,3
8231             derx_turn(lll,kkk,iii)=0.0d0
8232           enddo
8233         enddo
8234       enddo
8235 cd      eij=1.0d0
8236 cd      ekl=1.0d0
8237 cd      ekont=1.0d0
8238       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8239 cd      eello6_5=0.0d0
8240 cd      write (2,*) 'eello6_5',eello6_5
8241 #ifdef MOMENT
8242       call transpose2(AEA(1,1,1),auxmat(1,1))
8243       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8244       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8245       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8246 #else
8247       s1 = 0.0d0
8248 #endif
8249       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8250       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8251       s2 = scalar2(b1(1,itk),vtemp1(1))
8252 #ifdef MOMENT
8253       call transpose2(AEA(1,1,2),atemp(1,1))
8254       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8255       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8256       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8257 #else
8258       s8=0.0d0
8259 #endif
8260       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8261       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8262       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8263 #ifdef MOMENT
8264       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8265       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8266       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8267       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8268       ss13 = scalar2(b1(1,itk),vtemp4(1))
8269       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8270 #else
8271       s13=0.0d0
8272 #endif
8273 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8274 c      s1=0.0d0
8275 c      s2=0.0d0
8276 c      s8=0.0d0
8277 c      s12=0.0d0
8278 c      s13=0.0d0
8279       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8280       if (calc_grad) then
8281 C Derivatives in gamma(i+2)
8282 #ifdef MOMENT
8283       call transpose2(AEA(1,1,1),auxmatd(1,1))
8284       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8285       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8286       call transpose2(AEAderg(1,1,2),atempd(1,1))
8287       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8288       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8289 #else
8290       s8d=0.0d0
8291 #endif
8292       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8293       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8294       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8295 c      s1d=0.0d0
8296 c      s2d=0.0d0
8297 c      s8d=0.0d0
8298 c      s12d=0.0d0
8299 c      s13d=0.0d0
8300       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8301 C Derivatives in gamma(i+3)
8302 #ifdef MOMENT
8303       call transpose2(AEA(1,1,1),auxmatd(1,1))
8304       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8305       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8306       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8307 #else
8308       s1d=0.0d0
8309 #endif
8310       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8311       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8312       s2d = scalar2(b1(1,itk),vtemp1d(1))
8313 #ifdef MOMENT
8314       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8315       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8316 #endif
8317       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8318 #ifdef MOMENT
8319       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8320       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8321       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8322 #else
8323       s13d=0.0d0
8324 #endif
8325 c      s1d=0.0d0
8326 c      s2d=0.0d0
8327 c      s8d=0.0d0
8328 c      s12d=0.0d0
8329 c      s13d=0.0d0
8330 #ifdef MOMENT
8331       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8332      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8333 #else
8334       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8335      &               -0.5d0*ekont*(s2d+s12d)
8336 #endif
8337 C Derivatives in gamma(i+4)
8338       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8339       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8340       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8341 #ifdef MOMENT
8342       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8343       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8344       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8345 #else
8346       s13d = 0.0d0
8347 #endif
8348 c      s1d=0.0d0
8349 c      s2d=0.0d0
8350 c      s8d=0.0d0
8351 C      s12d=0.0d0
8352 c      s13d=0.0d0
8353 #ifdef MOMENT
8354       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8355 #else
8356       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8357 #endif
8358 C Derivatives in gamma(i+5)
8359 #ifdef MOMENT
8360       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8361       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8362       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8363 #else
8364       s1d = 0.0d0
8365 #endif
8366       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8367       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8368       s2d = scalar2(b1(1,itk),vtemp1d(1))
8369 #ifdef MOMENT
8370       call transpose2(AEA(1,1,2),atempd(1,1))
8371       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8372       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8373 #else
8374       s8d = 0.0d0
8375 #endif
8376       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8377       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8378 #ifdef MOMENT
8379       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8380       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8381       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8382 #else
8383       s13d = 0.0d0
8384 #endif
8385 c      s1d=0.0d0
8386 c      s2d=0.0d0
8387 c      s8d=0.0d0
8388 c      s12d=0.0d0
8389 c      s13d=0.0d0
8390 #ifdef MOMENT
8391       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8392      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8393 #else
8394       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8395      &               -0.5d0*ekont*(s2d+s12d)
8396 #endif
8397 C Cartesian derivatives
8398       do iii=1,2
8399         do kkk=1,5
8400           do lll=1,3
8401 #ifdef MOMENT
8402             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8403             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8404             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8405 #else
8406             s1d = 0.0d0
8407 #endif
8408             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8409             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8410      &          vtemp1d(1))
8411             s2d = scalar2(b1(1,itk),vtemp1d(1))
8412 #ifdef MOMENT
8413             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8414             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8415             s8d = -(atempd(1,1)+atempd(2,2))*
8416      &           scalar2(cc(1,1,itl),vtemp2(1))
8417 #else
8418             s8d = 0.0d0
8419 #endif
8420             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8421      &           auxmatd(1,1))
8422             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8423             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8424 c      s1d=0.0d0
8425 c      s2d=0.0d0
8426 c      s8d=0.0d0
8427 c      s12d=0.0d0
8428 c      s13d=0.0d0
8429 #ifdef MOMENT
8430             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8431      &        - 0.5d0*(s1d+s2d)
8432 #else
8433             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8434      &        - 0.5d0*s2d
8435 #endif
8436 #ifdef MOMENT
8437             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8438      &        - 0.5d0*(s8d+s12d)
8439 #else
8440             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8441      &        - 0.5d0*s12d
8442 #endif
8443           enddo
8444         enddo
8445       enddo
8446 #ifdef MOMENT
8447       do kkk=1,5
8448         do lll=1,3
8449           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8450      &      achuj_tempd(1,1))
8451           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8452           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8453           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8454           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8455           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8456      &      vtemp4d(1))
8457           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8458           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8459           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8460         enddo
8461       enddo
8462 #endif
8463 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8464 cd     &  16*eel_turn6_num
8465 cd      goto 1112
8466       if (j.lt.nres-1) then
8467         j1=j+1
8468         j2=j-1
8469       else
8470         j1=j-1
8471         j2=j-2
8472       endif
8473       if (l.lt.nres-1) then
8474         l1=l+1
8475         l2=l-1
8476       else
8477         l1=l-1
8478         l2=l-2
8479       endif
8480       do ll=1,3
8481         ggg1(ll)=eel_turn6*g_contij(ll,1)
8482         ggg2(ll)=eel_turn6*g_contij(ll,2)
8483         ghalf=0.5d0*ggg1(ll)
8484 cd        ghalf=0.0d0
8485         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8486      &    +ekont*derx_turn(ll,2,1)
8487         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8488         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8489      &    +ekont*derx_turn(ll,4,1)
8490         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8491         ghalf=0.5d0*ggg2(ll)
8492 cd        ghalf=0.0d0
8493         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8494      &    +ekont*derx_turn(ll,2,2)
8495         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8496         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8497      &    +ekont*derx_turn(ll,4,2)
8498         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8499       enddo
8500 cd      goto 1112
8501       do m=i+1,j-1
8502         do ll=1,3
8503           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8504         enddo
8505       enddo
8506       do m=k+1,l-1
8507         do ll=1,3
8508           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8509         enddo
8510       enddo
8511 1112  continue
8512       do m=i+2,j2
8513         do ll=1,3
8514           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8515         enddo
8516       enddo
8517       do m=k+2,l2
8518         do ll=1,3
8519           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8520         enddo
8521       enddo
8522 cd      do iii=1,nres-3
8523 cd        write (2,*) iii,g_corr6_loc(iii)
8524 cd      enddo
8525       endif
8526       eello_turn6=ekont*eel_turn6
8527 cd      write (2,*) 'ekont',ekont
8528 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8529       return
8530       end
8531 crc-------------------------------------------------
8532       SUBROUTINE MATVEC2(A1,V1,V2)
8533       implicit real*8 (a-h,o-z)
8534       include 'DIMENSIONS'
8535       DIMENSION A1(2,2),V1(2),V2(2)
8536 c      DO 1 I=1,2
8537 c        VI=0.0
8538 c        DO 3 K=1,2
8539 c    3     VI=VI+A1(I,K)*V1(K)
8540 c        Vaux(I)=VI
8541 c    1 CONTINUE
8542
8543       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8544       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8545
8546       v2(1)=vaux1
8547       v2(2)=vaux2
8548       END
8549 C---------------------------------------
8550       SUBROUTINE MATMAT2(A1,A2,A3)
8551       implicit real*8 (a-h,o-z)
8552       include 'DIMENSIONS'
8553       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8554 c      DIMENSION AI3(2,2)
8555 c        DO  J=1,2
8556 c          A3IJ=0.0
8557 c          DO K=1,2
8558 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8559 c          enddo
8560 c          A3(I,J)=A3IJ
8561 c       enddo
8562 c      enddo
8563
8564       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8565       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8566       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8567       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8568
8569       A3(1,1)=AI3_11
8570       A3(2,1)=AI3_21
8571       A3(1,2)=AI3_12
8572       A3(2,2)=AI3_22
8573       END
8574
8575 c-------------------------------------------------------------------------
8576       double precision function scalar2(u,v)
8577       implicit none
8578       double precision u(2),v(2)
8579       double precision sc
8580       integer i
8581       scalar2=u(1)*v(1)+u(2)*v(2)
8582       return
8583       end
8584
8585 C-----------------------------------------------------------------------------
8586
8587       subroutine transpose2(a,at)
8588       implicit none
8589       double precision a(2,2),at(2,2)
8590       at(1,1)=a(1,1)
8591       at(1,2)=a(2,1)
8592       at(2,1)=a(1,2)
8593       at(2,2)=a(2,2)
8594       return
8595       end
8596 c--------------------------------------------------------------------------
8597       subroutine transpose(n,a,at)
8598       implicit none
8599       integer n,i,j
8600       double precision a(n,n),at(n,n)
8601       do i=1,n
8602         do j=1,n
8603           at(j,i)=a(i,j)
8604         enddo
8605       enddo
8606       return
8607       end
8608 C---------------------------------------------------------------------------
8609       subroutine prodmat3(a1,a2,kk,transp,prod)
8610       implicit none
8611       integer i,j
8612       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8613       logical transp
8614 crc      double precision auxmat(2,2),prod_(2,2)
8615
8616       if (transp) then
8617 crc        call transpose2(kk(1,1),auxmat(1,1))
8618 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8619 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8620
8621            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8622      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8623            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8624      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8625            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8626      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8627            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8628      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8629
8630       else
8631 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8632 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8633
8634            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8635      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8636            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8637      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8638            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8639      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8640            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8641      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8642
8643       endif
8644 c      call transpose2(a2(1,1),a2t(1,1))
8645
8646 crc      print *,transp
8647 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8648 crc      print *,((prod(i,j),i=1,2),j=1,2)
8649
8650       return
8651       end
8652 C-----------------------------------------------------------------------------
8653       double precision function scalar(u,v)
8654       implicit none
8655       double precision u(3),v(3)
8656       double precision sc
8657       integer i
8658       sc=0.0d0
8659       do i=1,3
8660         sc=sc+u(i)*v(i)
8661       enddo
8662       scalar=sc
8663       return
8664       end
8665 C-----------------------------------------------------------------------
8666       double precision function sscale(r)
8667       double precision r,gamm
8668       include "COMMON.SPLITELE"
8669       if(r.lt.r_cut-rlamb) then
8670         sscale=1.0d0
8671       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8672         gamm=(r-(r_cut-rlamb))/rlamb
8673         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8674       else
8675         sscale=0d0
8676       endif
8677       return
8678       end
8679 C-----------------------------------------------------------------------
8680 C-----------------------------------------------------------------------
8681       double precision function sscagrad(r)
8682       double precision r,gamm
8683       include "COMMON.SPLITELE"
8684       if(r.lt.r_cut-rlamb) then
8685         sscagrad=0.0d0
8686       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8687         gamm=(r-(r_cut-rlamb))/rlamb
8688         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8689       else
8690         sscagrad=0.0d0
8691       endif
8692       return
8693       end
8694 C-----------------------------------------------------------------------
8695 C-----------------------------------------------------------------------
8696       double precision function sscalelip(r)
8697       double precision r,gamm
8698       include "COMMON.SPLITELE"
8699 C      if(r.lt.r_cut-rlamb) then
8700 C        sscale=1.0d0
8701 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8702 C        gamm=(r-(r_cut-rlamb))/rlamb
8703         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8704 C      else
8705 C        sscale=0d0
8706 C      endif
8707       return
8708       end
8709 C-----------------------------------------------------------------------
8710       double precision function sscagradlip(r)
8711       double precision r,gamm
8712       include "COMMON.SPLITELE"
8713 C     if(r.lt.r_cut-rlamb) then
8714 C        sscagrad=0.0d0
8715 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8716 C        gamm=(r-(r_cut-rlamb))/rlamb
8717         sscagradlip=r*(6*r-6.0d0)
8718 C      else
8719 C        sscagrad=0.0d0
8720 C      endif
8721       return
8722       end
8723 c----------------------------------------------------------------------------
8724       double precision function sscale2(r,r_cut,r0,rlamb)
8725       implicit none
8726       double precision r,gamm,r_cut,r0,rlamb,rr
8727       rr = dabs(r-r0)
8728 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
8729 c      write (2,*) "rr",rr
8730       if(rr.lt.r_cut-rlamb) then
8731         sscale2=1.0d0
8732       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8733         gamm=(rr-(r_cut-rlamb))/rlamb
8734         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8735       else
8736         sscale2=0d0
8737       endif
8738       return
8739       end
8740 C-----------------------------------------------------------------------
8741       double precision function sscalgrad2(r,r_cut,r0,rlamb)
8742       implicit none
8743       double precision r,gamm,r_cut,r0,rlamb,rr
8744       rr = dabs(r-r0)
8745       if(rr.lt.r_cut-rlamb) then
8746         sscalgrad2=0.0d0
8747       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
8748         gamm=(rr-(r_cut-rlamb))/rlamb
8749         if (r.ge.r0) then
8750           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
8751         else
8752           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
8753         endif
8754       else
8755         sscalgrad2=0.0d0
8756       endif
8757       return
8758       end
8759 c----------------------------------------------------------------------------
8760       subroutine e_saxs(Esaxs_constr)
8761       implicit none
8762       include 'DIMENSIONS'
8763       include 'DIMENSIONS.ZSCOPT'
8764       include 'DIMENSIONS.FREE'
8765 #ifdef MPI
8766       include "mpif.h"
8767       include "COMMON.SETUP"
8768       integer IERR
8769 #endif
8770       include 'COMMON.SBRIDGE'
8771       include 'COMMON.CHAIN'
8772       include 'COMMON.GEO'
8773       include 'COMMON.LOCAL'
8774       include 'COMMON.INTERACT'
8775       include 'COMMON.VAR'
8776       include 'COMMON.IOUNITS'
8777       include 'COMMON.DERIV'
8778       include 'COMMON.CONTROL'
8779       include 'COMMON.NAMES'
8780       include 'COMMON.FFIELD'
8781       include 'COMMON.LANGEVIN'
8782 c
8783       double precision Esaxs_constr
8784       integer i,iint,j,k,l
8785       double precision PgradC(maxSAXS,3,maxres),
8786      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
8787 #ifdef MPI
8788       double precision PgradC_(maxSAXS,3,maxres),
8789      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
8790 #endif
8791       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
8792      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
8793      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
8794      & auxX,auxX1,CACAgrad,Cnorm
8795       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
8796       double precision dist
8797       external dist
8798 c  SAXS restraint penalty function
8799 #ifdef DEBUG
8800       write(iout,*) "------- SAXS penalty function start -------"
8801       write (iout,*) "nsaxs",nsaxs
8802       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
8803       write (iout,*) "Psaxs"
8804       do i=1,nsaxs
8805         write (iout,'(i5,e15.5)') i, Psaxs(i)
8806       enddo
8807 #endif
8808       Esaxs_constr = 0.0d0
8809       do k=1,nsaxs
8810         Pcalc(k)=0.0d0
8811         do j=1,nres
8812           do l=1,3
8813             PgradC(k,l,j)=0.0d0
8814             PgradX(k,l,j)=0.0d0
8815           enddo
8816         enddo
8817       enddo
8818       do i=iatsc_s,iatsc_e
8819        if (itype(i).eq.ntyp1) cycle
8820        do iint=1,nint_gr(i)
8821          do j=istart(i,iint),iend(i,iint)
8822            if (itype(j).eq.ntyp1) cycle
8823 #ifdef ALLSAXS
8824            dijCACA=dist(i,j)
8825            dijCASC=dist(i,j+nres)
8826            dijSCCA=dist(i+nres,j)
8827            dijSCSC=dist(i+nres,j+nres)
8828            sigma2CACA=2.0d0/(pstok**2)
8829            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
8830            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
8831            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
8832            do k=1,nsaxs
8833              dk = distsaxs(k)
8834              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8835              if (itype(j).ne.10) then
8836              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
8837              else
8838              endif
8839              expCASC = 0.0d0
8840              if (itype(i).ne.10) then
8841              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
8842              else
8843              expSCCA = 0.0d0
8844              endif
8845              if (itype(i).ne.10 .and. itype(j).ne.10) then
8846              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
8847              else
8848              expSCSC = 0.0d0
8849              endif
8850              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
8851 #ifdef DEBUG
8852              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8853 #endif
8854              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8855              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
8856              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
8857              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
8858              do l=1,3
8859 c CA CA
8860                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8861                PgradC(k,l,i) = PgradC(k,l,i)-aux
8862                PgradC(k,l,j) = PgradC(k,l,j)+aux
8863 c CA SC
8864                if (itype(j).ne.10) then
8865                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
8866                PgradC(k,l,i) = PgradC(k,l,i)-aux
8867                PgradC(k,l,j) = PgradC(k,l,j)+aux
8868                PgradX(k,l,j) = PgradX(k,l,j)+aux
8869                endif
8870 c SC CA
8871                if (itype(i).ne.10) then
8872                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
8873                PgradX(k,l,i) = PgradX(k,l,i)-aux
8874                PgradC(k,l,i) = PgradC(k,l,i)-aux
8875                PgradC(k,l,j) = PgradC(k,l,j)+aux
8876                endif
8877 c SC SC
8878                if (itype(i).ne.10 .and. itype(j).ne.10) then
8879                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
8880                PgradC(k,l,i) = PgradC(k,l,i)-aux
8881                PgradC(k,l,j) = PgradC(k,l,j)+aux
8882                PgradX(k,l,i) = PgradX(k,l,i)-aux
8883                PgradX(k,l,j) = PgradX(k,l,j)+aux
8884                endif
8885              enddo ! l
8886            enddo ! k
8887 #else
8888            dijCACA=dist(i,j)
8889            sigma2CACA=scal_rad**2*0.25d0/
8890      &        (restok(itype(j))**2+restok(itype(i))**2)
8891
8892            IF (saxs_cutoff.eq.0) THEN
8893            do k=1,nsaxs
8894              dk = distsaxs(k)
8895              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
8896              Pcalc(k) = Pcalc(k)+expCACA
8897              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
8898              do l=1,3
8899                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8900                PgradC(k,l,i) = PgradC(k,l,i)-aux
8901                PgradC(k,l,j) = PgradC(k,l,j)+aux
8902              enddo ! l
8903            enddo ! k
8904            ELSE
8905            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
8906            do k=1,nsaxs
8907              dk = distsaxs(k)
8908 c             write (2,*) "ijk",i,j,k
8909              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
8910              if (sss2.eq.0.0d0) cycle
8911              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
8912              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
8913              Pcalc(k) = Pcalc(k)+expCACA
8914 #ifdef DEBUG
8915              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
8916 #endif
8917              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
8918      &             ssgrad2*expCACA/sss2
8919              do l=1,3
8920 c CA CA
8921                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
8922                PgradC(k,l,i) = PgradC(k,l,i)+aux
8923                PgradC(k,l,j) = PgradC(k,l,j)-aux
8924              enddo ! l
8925            enddo ! k
8926            ENDIF
8927 #endif
8928          enddo ! j
8929        enddo ! iint
8930       enddo ! i
8931 #ifdef MPI
8932       if (nfgtasks.gt.1) then
8933         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
8934      &    MPI_SUM,king,FG_COMM,IERR)
8935         if (fg_rank.eq.king) then
8936           do k=1,nsaxs
8937             Pcalc(k) = Pcalc_(k)
8938           enddo
8939         endif
8940         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
8941      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8942         if (fg_rank.eq.king) then
8943           do i=1,nres
8944             do l=1,3
8945               do k=1,nsaxs
8946                 PgradC(k,l,i) = PgradC_(k,l,i)
8947               enddo
8948             enddo
8949           enddo
8950         endif
8951 #ifdef ALLSAXS
8952         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
8953      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
8954         if (fg_rank.eq.king) then
8955           do i=1,nres
8956             do l=1,3
8957               do k=1,nsaxs
8958                 PgradX(k,l,i) = PgradX_(k,l,i)
8959               enddo
8960             enddo
8961           enddo
8962         endif
8963 #endif
8964       endif
8965 #endif
8966 #ifdef MPI
8967       if (fg_rank.eq.king) then
8968 #endif
8969       Cnorm = 0.0d0
8970       do k=1,nsaxs
8971         Cnorm = Cnorm + Pcalc(k)
8972       enddo
8973       Esaxs_constr = dlog(Cnorm)-wsaxs0
8974       do k=1,nsaxs
8975         if (Pcalc(k).gt.0.0d0)
8976      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
8977 #ifdef DEBUG
8978         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
8979 #endif
8980       enddo
8981 #ifdef DEBUG
8982       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
8983 #endif
8984       do i=nnt,nct
8985         do l=1,3
8986           auxC=0.0d0
8987           auxC1=0.0d0
8988           auxX=0.0d0
8989           auxX1=0.d0
8990           do k=1,nsaxs
8991             if (Pcalc(k).gt.0)
8992      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
8993             auxC1 = auxC1+PgradC(k,l,i)
8994 #ifdef ALLSAXS
8995             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
8996             auxX1 = auxX1+PgradX(k,l,i)
8997 #endif
8998           enddo
8999           gsaxsC(l,i) = auxC - auxC1/Cnorm
9000 #ifdef ALLSAXS
9001           gsaxsX(l,i) = auxX - auxX1/Cnorm
9002 #endif
9003 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9004 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9005         enddo
9006       enddo
9007 #ifdef MPI
9008       endif
9009 #endif
9010       return
9011       end
9012 c----------------------------------------------------------------------------
9013       subroutine e_saxsC(Esaxs_constr)
9014       implicit none
9015       include 'DIMENSIONS'
9016       include 'DIMENSIONS.ZSCOPT'
9017       include 'DIMENSIONS.FREE'
9018 #ifdef MPI
9019       include "mpif.h"
9020       include "COMMON.SETUP"
9021       integer IERR
9022 #endif
9023       include 'COMMON.SBRIDGE'
9024       include 'COMMON.CHAIN'
9025       include 'COMMON.GEO'
9026       include 'COMMON.LOCAL'
9027       include 'COMMON.INTERACT'
9028       include 'COMMON.VAR'
9029       include 'COMMON.IOUNITS'
9030       include 'COMMON.DERIV'
9031       include 'COMMON.CONTROL'
9032       include 'COMMON.NAMES'
9033       include 'COMMON.FFIELD'
9034       include 'COMMON.LANGEVIN'
9035 c
9036       double precision Esaxs_constr
9037       integer i,iint,j,k,l
9038       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
9039 #ifdef MPI
9040       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9041 #endif
9042       double precision dk,dijCASPH,dijSCSPH,
9043      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9044      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9045      & auxX,auxX1,Cnorm
9046 c  SAXS restraint penalty function
9047 #ifdef DEBUG
9048       write(iout,*) "------- SAXS penalty function start -------"
9049       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9050      & " isaxs_end",isaxs_end
9051       write (iout,*) "nnt",nnt," ntc",nct
9052       do i=nnt,nct
9053         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9054      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9055       enddo
9056       do i=nnt,nct
9057         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9058       enddo
9059 #endif
9060       Esaxs_constr = 0.0d0
9061       logPtot=0.0d0
9062       do j=isaxs_start,isaxs_end
9063         Pcalc=0.0d0
9064         do i=1,nres
9065           do l=1,3
9066             PgradC(l,i)=0.0d0
9067             PgradX(l,i)=0.0d0
9068           enddo
9069         enddo
9070         do i=nnt,nct
9071           dijCASPH=0.0d0
9072           dijSCSPH=0.0d0
9073           do l=1,3
9074             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9075           enddo
9076           if (itype(i).ne.10) then
9077           do l=1,3
9078             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9079           enddo
9080           endif
9081           sigma2CA=2.0d0/pstok**2
9082           sigma2SC=4.0d0/restok(itype(i))**2
9083           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9084           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9085           Pcalc = Pcalc+expCASPH+expSCSPH
9086 #ifdef DEBUG
9087           write(*,*) "processor i j Pcalc",
9088      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
9089 #endif
9090           CASPHgrad = sigma2CA*expCASPH
9091           SCSPHgrad = sigma2SC*expSCSPH
9092           do l=1,3
9093             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9094             PgradX(l,i) = PgradX(l,i) + aux
9095             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9096           enddo ! l
9097         enddo ! i
9098         do i=nnt,nct
9099           do l=1,3
9100             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
9101             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
9102           enddo
9103         enddo
9104         logPtot = logPtot - dlog(Pcalc)
9105 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
9106 c     &    " logPtot",logPtot
9107       enddo ! j
9108 #ifdef MPI
9109       if (nfgtasks.gt.1) then
9110 c        write (iout,*) "logPtot before reduction",logPtot
9111         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9112      &    MPI_SUM,king,FG_COMM,IERR)
9113         logPtot = logPtot_
9114 c        write (iout,*) "logPtot after reduction",logPtot
9115         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9116      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9117         if (fg_rank.eq.king) then
9118           do i=1,nres
9119             do l=1,3
9120               gsaxsC(l,i) = gsaxsC_(l,i)
9121             enddo
9122           enddo
9123         endif
9124         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9125      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9126         if (fg_rank.eq.king) then
9127           do i=1,nres
9128             do l=1,3
9129               gsaxsX(l,i) = gsaxsX_(l,i)
9130             enddo
9131           enddo
9132         endif
9133       endif
9134 #endif
9135       Esaxs_constr = logPtot
9136       return
9137       end